wip shift multiple n return data.table rather than list

Author: mattdowle

R/shift.R

@@ -23,6 +23,7 @@ shift = function(x, n=1L, fill, type=c("lag", "lead", "shift", "cyclic"), give.n
     }
     setattr(ans, "names",  paste(rep(nx,each=length(n)), type, n, sep="_"))
   }
+  if (length(n)>1L) setDT(ans)
   ans
 }
 

inst/tests/tests.Rraw

@@ -6707,68 +6707,68 @@ test(1462.3, DT[, sum(unlist(mget(cols, as.environment(-1)))), by=x], DT[, sum(u
 x=1:5
 y=factor(x)
 test(1463.01, shift(x,1L),                   as.integer(c(NA, 1:4)))
-test(1463.02, shift(x,1:2),                  list(as.integer(c(NA, 1:4)), as.integer(c(NA, NA, 1:3))))
+test(1463.02, shift(x,1:2),                  data.table(as.integer(c(NA, 1:4)), as.integer(c(NA, NA, 1:3))))
 test(1463.03, shift(x,1L, 0L),               as.integer(c(0L, 1:4)))
 test(1463.04, shift(x,1L,    type="lead"),   as.integer(c(2:5, NA)))
-test(1463.05, shift(x,1:2,   type="lead"),   list(as.integer(c(2:5, NA)), as.integer(c(3:5, NA, NA))))
+test(1463.05, shift(x,1:2,   type="lead"),   data.table(as.integer(c(2:5, NA)), as.integer(c(3:5, NA, NA))))
 test(1463.06, shift(x,1L, 0L,type="lead"),   as.integer(c(2:5, 0L)))
 test(1463.07, shift(y,1L),                   factor(c(NA,1:4), levels=1:5))
 test(1463.08, shift(y,1L,    type="lead"),   factor(c(2:5, NA), levels=1:5))
 test(1463.09, shift(x,1L,    type="cyclic"), as.integer(c(5, 1:4)))
-test(1463.10, shift(x,1:2,   type="cyclic"), list(as.integer(c(5, 1:4)), as.integer(c(4:5, 1:3))))
+test(1463.10, shift(x,1:2,   type="cyclic"), data.table(as.integer(c(5, 1:4)), as.integer(c(4:5, 1:3))))
 test(1463.11, shift(x,-1L,   type="cyclic"), as.integer(c(2:5, 1)))
-test(1463.12, shift(x,-(1:2),type="cyclic"), list(as.integer(c(2:5, 1)), as.integer(c(3:5,1:2))))
+test(1463.12, shift(x,-(1:2),type="cyclic"), data.table(as.integer(c(2:5, 1)), as.integer(c(3:5,1:2))))
 
 x=as.numeric(x)
 test(1463.13, shift(x,1L),                   as.numeric(c(NA, 1:4)))
-test(1463.14, shift(x,1:2),                  list(as.numeric(c(NA, 1:4)), as.numeric(c(NA, NA, 1:3))))
+test(1463.14, shift(x,1:2),                  data.table(as.numeric(c(NA, 1:4)), as.numeric(c(NA, NA, 1:3))))
 test(1463.15, shift(x,1L, 0L),               as.numeric(c(0L, 1:4)))
 test(1463.16, shift(x,1L,    type="lead"),   as.numeric(c(2:5, NA)))
-test(1463.17, shift(x,1:2,   type="lead"),   list(as.numeric(c(2:5, NA)), as.numeric(c(3:5, NA, NA))))
+test(1463.17, shift(x,1:2,   type="lead"),   data.table(as.numeric(c(2:5, NA)), as.numeric(c(3:5, NA, NA))))
 test(1463.18, shift(x,1L, 0L,type="lead"),   as.numeric(c(2:5, 0L)))
 test(1463.19, shift(x,1L,    type="cyclic"), as.numeric(c(5, 1:4)))
-test(1463.20, shift(x,1:2,   type="cyclic"), list(as.numeric(c(5, 1:4)), as.numeric(c(4:5, 1:3))))
+test(1463.20, shift(x,1:2,   type="cyclic"), data.table(as.numeric(c(5, 1:4)), as.numeric(c(4:5, 1:3))))
 test(1463.21, shift(x,-1L,   type="cyclic"), as.numeric(c(2:5, 1)))
-test(1463.22, shift(x,-(1:2),type="cyclic"), list(as.numeric(c(2:5, 1)), as.numeric(c(3:5,1:2))))
+test(1463.22, shift(x,-(1:2),type="cyclic"), data.table(as.numeric(c(2:5, 1)), as.numeric(c(3:5,1:2))))
 
 
 if (test_bit64) {
   x=as.integer64(x)
   test(1463.23, shift(x,1L),                    as.integer64(c(NA, 1:4)))
-  test(1463.24, shift(x,1:2),                   list(as.integer64(c(NA, 1:4)), as.integer64(c(NA, NA, 1:3))))
+  test(1463.24, shift(x,1:2),                   data.table(as.integer64(c(NA, 1:4)), as.integer64(c(NA, NA, 1:3))))
   test(1463.25, shift(x,1L, 0L),                as.integer64(c(0L, 1:4)))
   test(1463.26, shift(x,1L,     type="lead"),   as.integer64(c(2:5, NA)))
-  test(1463.27, shift(x,1:2,    type="lead"),   list(as.integer64(c(2:5, NA)), as.integer64(c(3:5, NA, NA))))
+  test(1463.27, shift(x,1:2,    type="lead"),   data.table(as.integer64(c(2:5, NA)), as.integer64(c(3:5, NA, NA))))
   test(1463.28, shift(x,1L, 0L, type="lead"),   as.integer64(c(2:5, 0L)))
   test(1463.29, shift(x,1L,     type="cyclic"), as.integer64(c(5, 1:4)))
-  test(1463.30, shift(x,1:2,    type="cyclic"), list(as.integer64(c(5, 1:4)), as.integer64(c(4:5, 1:3))))
+  test(1463.30, shift(x,1:2,    type="cyclic"), data.table(as.integer64(c(5, 1:4)), as.integer64(c(4:5, 1:3))))
   test(1463.31, shift(x,-1L,    type="cyclic"), as.integer64(c(2:5, 1)))
-  test(1463.32, shift(x,-(1:2), type="cyclic"), list(as.integer64(c(2:5, 1)), as.integer64(c(3:5,1:2))))
+  test(1463.32, shift(x,-(1:2), type="cyclic"), data.table(as.integer64(c(2:5, 1)), as.integer64(c(3:5,1:2))))
 }
 
 x=as.character(x)
 test(1463.33, shift(x,1L),                    as.character(c(NA, 1:4)))
-test(1463.34, shift(x,1:2),                   list(as.character(c(NA, 1:4)), as.character(c(NA, NA, 1:3))))
+test(1463.34, shift(x,1:2),                   data.table(as.character(c(NA, 1:4)), as.character(c(NA, NA, 1:3))))
 test(1463.35, shift(x,1L, 0L),                as.character(c(0L, 1:4)))
 test(1463.36, shift(x,1L,     type="lead"),   as.character(c(2:5, NA)))
-test(1463.37, shift(x,1:2,    type="lead"),   list(as.character(c(2:5, NA)), as.character(c(3:5, NA, NA))))
+test(1463.37, shift(x,1:2,    type="lead"),   data.table(as.character(c(2:5, NA)), as.character(c(3:5, NA, NA))))
 test(1463.38, shift(x,1L, 0L, type="lead"),   as.character(c(2:5, 0L)))
 test(1463.39, shift(x,1L,     type="cyclic"), as.character(c(5, 1:4)))
-test(1463.40, shift(x,1:2,    type="cyclic"), list(as.character(c(5, 1:4)), as.character(c(4:5, 1:3))))
+test(1463.40, shift(x,1:2,    type="cyclic"), data.table(as.character(c(5, 1:4)), as.character(c(4:5, 1:3))))
 test(1463.41, shift(x,-1L,    type="cyclic"), as.character(c(2:5, 1)))
-test(1463.42, shift(x,-(1:2), type="cyclic"), list(as.character(c(2:5, 1)), as.character(c(3:5,1:2))))
+test(1463.42, shift(x,-(1:2), type="cyclic"), data.table(as.character(c(2:5, 1)), as.character(c(3:5,1:2))))
 
 x=c(TRUE,FALSE,TRUE,FALSE,TRUE)
 test(1463.43, shift(x,1L),                    c(NA, x[-5L]))
-test(1463.44, shift(x,1:2),                   list(c(NA, x[-5L]), c(NA, NA, x[-(4:5)])))
+test(1463.44, shift(x,1:2),                   data.table(c(NA, x[-5L]), c(NA, NA, x[-(4:5)])))
 test(1463.45, shift(x,1L, 0L),                c(FALSE, x[-5L]))
 test(1463.46, shift(x,1L,     type="lead"),   c(x[-1L], NA))
-test(1463.47, shift(x,1:2,    type="lead"),   list(c(x[-1L],NA), c(x[-(1:2)],NA,NA)))
+test(1463.47, shift(x,1:2,    type="lead"),   data.table(c(x[-1L],NA), c(x[-(1:2)],NA,NA)))
 test(1463.48, shift(x,1L, 0L, type="lead"),   c(x[-(1)], FALSE))
 test(1463.49, shift(x,1L,     type="cyclic"), c(x[5L], x[-5L]))
-test(1463.50, shift(x,1:2,    type="cyclic"), list(c(x[5L], x[-5L]), c(x[4L:5L], x[-4L:-5L])))
+test(1463.50, shift(x,1:2,    type="cyclic"), data.table(c(x[5L], x[-5L]), c(x[4L:5L], x[-4L:-5L])))
 test(1463.51, shift(x,-1L,    type="cyclic"), c(x[-1L], x[1L]))
-test(1463.52, shift(x,-(1:2), type="cyclic"), list(c(x[-1L], x[1L]), c(x[-1L:-2L], x[1L:2L])))
+test(1463.52, shift(x,-(1:2), type="cyclic"), data.table(c(x[-1L], x[1L]), c(x[-1L:-2L], x[1L:2L])))
 
 # for list of list, #1595
 x = data.table(foo = c(list(c("a","b","c")), list(c("b","c")), list(c("a","b")), list(c("a"))), id = c(1,1,2,2))
@@ -6794,7 +6794,7 @@ test(1463.60, shift(mean), error="type 'closure' passed to shift(). Must be a ve
 # test for 'give.names=TRUE' on vectors
 x = 1:10
 nm = c("x_lag_1", "x_lag_2")
-ans = list(as.integer(c(NA, 1:9)), as.integer(c(NA, NA, 1:8)))
+ans = data.table(as.integer(c(NA, 1:9)), as.integer(c(NA, NA, 1:8)))
 setattr(ans, 'names', nm)
 test(1463.61, shift(x, 1:2, give.names=TRUE), ans)
 
@@ -7001,7 +7001,7 @@ dt.query <- data.table(q1=c(-0.2, -0.05, 0.05, 0.15), q2=c(-0.2, -0.05, 0.05, 0.
 test(1471, foverlaps(dt.query, dt.ref), data.table(dt.ref, dt.query, key=c("q1", "q2")))
 
 # #1014 (segfault) fix
-test(1472, shift(1, 1:2, NA, 'lag'), list(NA_real_, NA_real_))
+test(1472, shift(1, 1:2, NA, 'lag'), data.table(NA_real_, NA_real_))
 
 # #528, type=equal simple test
 dt1 = data.table(x=1:5, y=6:10)
@@ -13945,21 +13945,21 @@ test(1963.03, shift(DT$x, -1, fill = 0L),
 test(1963.04, shift(DT$x, -1, give.names = TRUE), # give.names is ignored because we do not return list
      c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA))
 test(1963.05, shift(DT$x, -1:1),
-     list(c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA), 1:10,
-          c(NA, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L)))
+     data.table(c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA), 1:10,
+                c(NA, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L)))
 test(1963.06, shift(DT, -1),
-     list(c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA),
-          c(9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, NA)))
+     data.table(x=c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA),
+                y=c(9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, NA)))
 test(1963.07, shift(DT, -1:1),
-     list(c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA), 1:10,
+     data.table(c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA), 1:10,
           c(NA, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L),
           c(9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, NA), 10:1,
           c(NA, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L)))
 ## some coverage tests for good measure
 test(1963.08, shift(DT$x, type = 'some_other_type'), error='should be one of.*lag.*lead')
 test(1963.09, shift(as.raw(0:1)), error = "Type 'raw' is not supported")
 test(1963.10, shift(DT, -1:1, type="shift", give.names = TRUE), # new type="shift" #3223
-     ans <- list(`x_shift_-1` = c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA),
+     ans <- data.table(`x_shift_-1` = c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA),
           x_shift_0 = 1:10,
           x_shift_1 = c(NA, 1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L),
           `y_shift_-1` = c(9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L, NA),
@@ -16375,8 +16375,8 @@ test(2074.33, merge(DT, DT, by.x = 1i, by.y=1i), error="A non-empty vector of co
 # shift naming
 test(2074.34, shift(list(a=1:5, b=6:10), give.names=TRUE), list(a_lag_1=c(NA, 1:4), b_lag_1=c(NA, 6:9)))
 test(2074.345, shift(list(a=1:5, b=6:10), type="cyclic", give.names=TRUE), list(a_cyclic_1=c(5L, 1:4), b_cyclic_1=c(10L, 6:9)))
-test(2074.35, shift(1:5, 1:2, give.names=TRUE), list(V1_lag_1=c(NA, 1:4), V1_lag_2=c(NA, NA, 1:3)))
-test(2074.355, shift(1:5, 1:2, type="cyclic", give.names=TRUE), list(V1_cyclic_1=c(5L, 1:4), V1_cyclic_2=c(4L:5L, 1:3)))
+test(2074.35, shift(1:5, 1:2, give.names=TRUE), data.table(V1_lag_1=c(NA, 1:4), V1_lag_2=c(NA, NA, 1:3)))
+test(2074.355, shift(1:5, 1:2, type="cyclic", give.names=TRUE), data.table(V1_cyclic_1=c(5L, 1:4), V1_cyclic_2=c(4L:5L, 1:3)))
 
 # bmerge.c
 x = data.table(a='a')

src/assign.c

@@ -212,7 +212,7 @@ SEXP alloccol(SEXP dt, R_len_t n, Rboolean verbose)
   names = getAttrib(dt,R_NamesSymbol);
   // names may be NULL when null.data.table() passes list() to alloccol for example.
   // So, careful to use length() on names, not LENGTH().
-  if (length(names)!=l) error(_("Internal error: length of names (%d) is not length of dt (%d)"),length(names),l); // # nocov
+  if (length(names)!=l && length(names)>0) error(_("Internal error: length of names (%d) is not length of dt (%d)"),length(names),l); // # nocov
   if (!selfrefok(dt,verbose))
     return shallow(dt,R_NilValue,(n>l) ? n : l);  // e.g. test 848 and 851 in R > 3.0.2
     // added (n>l) ? ... for #970, see test 1481.

src/data.table.h

@@ -245,6 +245,7 @@ SEXP islockedR(SEXP x);
 bool need2utf8(SEXP x);
 SEXP coerceUtf8IfNeeded(SEXP x);
 SEXP coerceAs(SEXP x, SEXP as, SEXP copyArg);
+SEXP setDT(SEXP list);
 
 // types.c
 char *end(char *start);

src/gsumm.c

@@ -1462,10 +1462,16 @@ SEXP gshift(SEXP x, SEXP nArg, SEXP fillArg, SEXP typeArg) {
   for (int i=0; i<nk; i++) if (kd[i]==NA_INTEGER) error(_("Item %d of n is NA"), i+1);
 
   SEXP ans = PROTECT(allocVector(VECSXP, nk)); nprotect++;
+  setDT(ans);  // to tell gforce() clearly that these are columns without ambiguity over being a list column when DT or the group has 1 row
+  
+  // TODO: do we still need to set gforce dynamic here???
   SEXP att = PROTECT(allocVector(VECSXP, 3)); nprotect++;
   SET_VECTOR_ELT(att, 0, R_NilValue);
-  SET_VECTOR_ELT(att, 1, ScalarLogical(true));    // first/last doesn't matter for gshift
+  SET_VECTOR_ELT(att, 1, ScalarLogical(true));    // first/last doesn't matter for gshift which returns the same length as its input
   SET_VECTOR_ELT(att, 2, ScalarInteger(INT_MAX)); // i.e. grpsize; TODO: perhaps point lens directly to grpsize instead
+  setAttrib(ans, sym_gforce_dynamic, att);
+  //
+  
   SEXP thisfill = PROTECT(coerceAs(fillArg, x, ScalarLogical(0))); nprotect++;
   for (int g=0; g<nk; g++) {
     lag = stype == LAG || stype == CYCLIC;
@@ -1478,7 +1484,6 @@ SEXP gshift(SEXP x, SEXP nArg, SEXP fillArg, SEXP typeArg) {
     R_xlen_t ansi = 0;
     SEXP tmp;
     SET_VECTOR_ELT(ans, g, tmp=allocVector(TYPEOF(x), nx));
-    setAttrib(tmp, sym_gforce_dynamic, att);
     #define SHIFT(CTYPE, RTYPE, ASSIGN) {                                                                         \
       const CTYPE *xd = (const CTYPE *)RTYPE(x);                                                                  \
       const CTYPE fill = RTYPE(thisfill)[0];                                                                      \

src/utils.c

@@ -406,3 +406,12 @@ SEXP startsWithAny(const SEXP x, const SEXP y, SEXP start) {
   return ScalarLogical(false);
 }
 
+SEXP setDT(SEXP x) {
+  // used by gsumm.c to return a barebones DT (e.g. no names, not over-allocated) to gforce when n is a vector of shifts
+  SEXP class;
+  setAttrib(x, R_ClassSymbol, class=allocVector(STRSXP, 2));
+  SET_STRING_ELT(class,0,char_datatable);
+  SET_STRING_ELT(class,1,char_dataframe);
+  return x;
+}
+