diff --git a/NAMESPACE b/NAMESPACE index 64b8ed1..0119b6f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ export(fabricate) export(join) export(link_levels) export(modify_level) +export(modify_level2) export(nest_level) export(recycle) export(resample_data) diff --git a/R/helper_functions.R b/R/helper_functions.R index 7f7ac31..689dd2b 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -274,6 +274,7 @@ is_level_token <- function(x) x %in% c( "add_level", "nest_level", "modify_level", + "modify_level2", "cross_levels", "link_levels", "sac_level" @@ -367,7 +368,7 @@ check_rectangular <- function(working_data_list, N) { for (i in seq_along(working_data_list)) { wdl_i <- working_data_list[[i]] d <- dim(wdl_i) - if(length(d) %in% 0:1) { + if (length(d) <= 1) { len <- length(wdl_i) if (len == 1) { # Variable is a constant -- repeat it N times @@ -379,8 +380,8 @@ check_rectangular <- function(working_data_list, N) { names(working_data_list)[i], "` is length ", len) } } - else if(length(d) == 2){ - if(d[1] != N) { + else if (length(d) == 2) { + if (d[1] != N) { stop("Nested structures must all have `N.` rows. ", "In this call, `N` = ", N, " while the variable `", names(working_data_list)[i], "` has ", d[1], " rows.") @@ -390,7 +391,8 @@ check_rectangular <- function(working_data_list, N) { } } - return(working_data_list) + + working_data_list } diff --git a/R/modify_level.R b/R/modify_level.R index 21a8556..cbfdc11 100644 --- a/R/modify_level.R +++ b/R/modify_level.R @@ -8,6 +8,12 @@ modify_level <- function(..., by=NULL) { do_internal(N=NULL, ..., by=by, FUN=modify_level_internal, from="modify_level") } +#' @export +modify_level2 <- function(..., by=NULL) { + do_internal(N=NULL, ..., by=by, FUN=modify_level_internal2, from="modify_level") +} + + #' @importFrom rlang eval_tidy #' modify_level_internal <- function(N = NULL, ID_label = NULL, @@ -97,6 +103,102 @@ modify_level_internal <- function(N = NULL, ID_label = NULL, } +#' @importFrom rlang eval_tidy +#' +modify_level_internal2 <- function(N = NULL, ID_label = NULL, + workspace = NULL, by = NULL, + data_arguments=NULL) { + + + modify_level_internal_checks(ID_label, workspace) + + uu <- ID_label %||% attr(workspace, "active_df") + + df <- workspace[[uu]] %||% active_df(workspace) + + + + # There are two possibilities. One is that we are modifying the lowest level + # of data. In which case, we simply add variables, like if someone called + # add_level with a dataset. To check if that's the world we're in, check if + # we have any duplicates in the ID label: + if (!is.character(by)) { + # There is no subsetting going on, but modify_level was used anyway. + N <- nrow(df) + + # Coerce the working data frame into a list + working_data_list <- as.list(df) + + + check_variables_named(data_arguments, "modify_level") + + # Now loop over the variable creation. + for (i in names(data_arguments)) { + # Explicity mask N + dm <- as_data_mask(working_data_list) + dm$N <- N + + working_data_list[[i]] <- expand_or_error(eval_tidy( + data_arguments[[i]], + dm + ), N, i, data_arguments[[i]]) + + + # Nuke the current data argument -- if we have the same variable name + # created twice, this is OK, because it'll only erase the first one. + data_arguments[[i]] <- NULL + } + + # Before handing back data, ensure it's actually rectangular + working_data_list <- check_rectangular(working_data_list, N) + + # Overwrite the working data frame. + workspace[[uu]] <- data.frame( + working_data_list, + stringsAsFactors = FALSE, + row.names = NULL + ) + + attr_names <- grep("^fabricatr::", names(attributes(df)), value = TRUE) + attributes(workspace[[uu]])[attr_names] <- attributes(df)[attr_names] + + activate(workspace, uu) + # Return results + return(workspace) + } + + + df[["..idx"]] <- seq_len(nrow(df)) + + idx <- split(df[["..idx"]], df[by], drop = TRUE) + + out <- list() + + for(i in seq_along(idx)) { + wenv <- import_data_list(df[idx[[i]], ,drop=FALSE]) + + wenv <- modify_level_internal(N, ID_label, wenv, data_arguments=data_arguments) + + out[[i]] <- active_df(wenv) + + # If new columns were created, preallocate them, ow will be ignored w/ a warning + #df[setdiff(names(ret), names(df))] <- NA + + #df[slice, names(ret)] <- ret + + } + + res <- do.call(rbind, out) + rownames(res) <- NULL + res <- res[order(res[["..idx"]]), ] + res[["..idx"]] <- NULL + + workspace[[uu]] <- df + + activate(workspace, uu) + workspace + +}