wip modify_level(by) performance investigation

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)

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
 }
 
 

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
+
+}