copy(): only overwrite the list when necessary, consider the attributes

NEWS.md

@@ -62,6 +62,8 @@
 
 13. `rbindlist()` (and therefore the `rbind()` method for `data.table`s) no longer raises an error upon encountering more than approximately 50000 columns in a list entry, [#7793](https://github.com/Rdatatable/data.table/issues/7793). The bug was introduced in `data.table` version 1.18.2.1. Thanks to @rickhelmus for the report and @aitap for the fix.
 
+14. `copy()` is now more consistent about reallocating nested `data.table`s, [#7456](https://github.com/Rdatatable/data.table/issues/7456). The resulting list is now only overwritten when necessary, and its attributes are walked in search of data.tables to reallocate as well. Thanks to @be-marc for the report, @david-cortes for additional information, and @aitap for the fix.
+
 ### Notes
 
 1. {data.table} now depends on R 3.5.0 (2018).

R/data.table.R

@@ -567,7 +567,7 @@
         stopf("When by and keyby are both provided, keyby must be TRUE or FALSE")
     }
     if (missing(by)) { missingby=TRUE; by=bysub=NULL }  # possible when env is used, PR#4304
     else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "by", paste(deparse(bysub, width.cutoff=500L), collapse="\n"))
   }
   bynull = !missingby && is.null(by) #3530
   byjoin = !is.null(by) && is.symbol(bysub) && bysub==".EACHI"
@@ -632,7 +632,7 @@
         substitute2(.j, env),
         list(.j = substitute(j))
       ))
       if (missing(jsub)) {j = substitute(); jsub=NULL} else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "j", paste(deparse(jsub, width.cutoff=500L), collapse="\n"))
     }
   }
   if (!missing(j)) {
@@ -722,7 +722,7 @@
         substitute2(.i, env),
         list(.i = substitute(i))
       ))
       if (missing(isub)) {i = substitute(); isub=NULL} else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "i", paste(deparse(isub, width.cutoff=500L), collapse="\n"))
     }
   }
   if (!missing(i)) {
@@ -2252,7 +2252,7 @@
 
 # What's the name of the top-level call in 'j'?
 # NB: earlier, we used 'as.character()' but that fails for closures/builtins (#6026).
 root_name = function(jsub) if (is.call(jsub)) paste(deparse(jsub[[1L]]), collapse = " ") else ""
 
 DT = function(x, ...) {  #4872
   old = getOption("datatable.optimize")
@@ -2780,26 +2780,8 @@
 
 # TO DO, add more warnings e.g. for by.data.table(), telling user what the data.table syntax is but letting them dispatch to data.frame if they want
 
-copy = function(x) {
-  newx = .Call(Ccopy,x)  # copies at length but R's duplicate() also copies truelength over.
-                         # TO DO: inside Ccopy it could reset tl to 0 or length, but no matter as selfrefok detects it
-                         # TO DO: revisit duplicate.c in R 3.0.3 and see where it's at
-
-  reallocate = function(y) {
-    if (is.data.table(y)) {
-      .Call(C_unlock, y)
-      setalloccol(y)
-    } else if (is.list(y)) {
-      oldClass = class(y)
-      setattr(y, 'class', NULL)  # otherwise [[.person method (which returns itself) results in infinite recursion, #4620
-      y[] = lapply(y, reallocate)
-      if (!identical(oldClass, 'list')) setattr(y, 'class', oldClass)
-    }
-    y
-  }
-
-  reallocate(newx)
-}
+copy = function(x)
+  .Call(Ccopy, x, getOption('datatable.alloccol'))
 
 .shallow = function(x, cols = NULL, retain.key = FALSE, unlock = FALSE) {
   wasnull = is.null(cols)

inst/tests/tests.Rraw

@@ -21831,3 +21831,9 @@ test(2378.92, .Call(CresizeVector, x, 2:3), error = "must be length 1 non-NA non
 test(2378.93, .Call(CresizeVector, x, -2L), error = "must be length 1 non-NA non-negative integer value")
 test(2378.94, .Call(CresizeVector, x, NA_integer_), error = "must be length 1 non-NA non-negative integer value")
 test(2378.95, .Call(CresizeVector, NULL, 2L), error = "must be a vector")
+
+# copy() reallocates data.tables inside list attributes, #7820
+x = list()
+attr(x, 'dt') = data.table()
+test(2379, truelength(attr(copy(x), 'dt')) > 0L)
+rm(x)

src/data.table.h

@@ -409,7 +409,7 @@ SEXP copyCols(SEXP x, SEXP cols);
 // where there are no arguments, it must be (void) not () to be a strict prototype
 SEXP setattrib(SEXP, SEXP, SEXP);
 SEXP assign(SEXP, SEXP, SEXP, SEXP, SEXP);
-SEXP copy(SEXP);
+SEXP copy(SEXP, SEXP);
 SEXP setdt_nrows(SEXP);
 SEXP alloccolwrapper(SEXP, SEXP, SEXP);
 SEXP allocrowwrapper(SEXP, SEXP);

src/init.c

@@ -54,7 +54,7 @@ static const R_CallMethodDef callMethods[] = {
     {"Cbmerge", (DL_FUNC)&bmerge, -1},
     {"Cassign", (DL_FUNC)&assign, -1},
     {"Cdogroups", (DL_FUNC)&dogroups, -1},
-    {"Ccopy", (DL_FUNC)&copy, -1},
+    {"Ccopy", (DL_FUNC)&copy, 2},
     {"Cshallowwrapper", (DL_FUNC)&shallowwrapper, -1},
     {"Csetdt_nrows", (DL_FUNC)&setdt_nrows, -1},
     {"Calloccolwrapper", (DL_FUNC)&alloccolwrapper, -1},

src/wrappers.c

@@ -57,9 +57,48 @@ SEXP setlevels(SEXP x, SEXP levels, SEXP ulevels) {
   return(x);
 }
 
-SEXP copy(SEXP x)
-{
-  return(duplicate(x));
+struct realloc_nested_dt_attr_ctx {
+  SEXP x;
+  int overAlloc;
+};
+static SEXP realloc_nested_dt_list(SEXP x, int overAlloc, bool);
+static SEXP realloc_nested_dt_list_attr(SEXP tag, SEXP att, void *ctx_) {
+  struct realloc_nested_dt_attr_ctx *ctx = ctx_;
+  SEXP newatt = realloc_nested_dt_list(att, ctx->overAlloc, false);
+  if (newatt != att) {
+    PROTECT(newatt);
+    setAttrib(ctx->x, tag, newatt);
+    UNPROTECT(1);
+  }
+  return R_NilValue;
+}
+static SEXP realloc_nested_dt_list(SEXP x, int overAlloc, bool replacePairlists) {
+  int nprot = 0;
+  if (inherits(x, "data.table")) {
+    x = PROTECT(alloccol(x, LENGTH(x) + overAlloc, FALSE)); ++nprot;
+    unlock(x);
+  }
+  if (replacePairlists && TYPEOF(x) == LISTSXP) {
+    x = PROTECT(coerceVector(x, VECSXP)); ++nprot;
+  }
+  if (TYPEOF(x) == VECSXP) for (R_xlen_t i = 0; i < XLENGTH(x); ++i) {
+    SEXP xi = VECTOR_ELT(x, i);
+    SEXP xinew = realloc_nested_dt_list(xi, overAlloc, false);
+    if (xinew != xi)
+      SET_VECTOR_ELT(x, i, xinew);
+  }
+  struct realloc_nested_dt_attr_ctx ctx = { .x = x, .overAlloc = overAlloc };
+  R_mapAttrib(x, realloc_nested_dt_list_attr, &ctx);
+  UNPROTECT(nprot);
+  return x;
+}
+
+SEXP copy(SEXP x, SEXP overAllocArg) {
+  int overAlloc = checkOverAlloc(overAllocArg);
+  PROTECT(x = duplicate(x));
+  x = realloc_nested_dt_list(x, overAlloc, true);
+  UNPROTECT(1);
+  return x;
 }
 
 // Internal use only. So that := can update elements of a list of data.table, #2204. Just needed to overallocate/grow the VECSXP.