Merge branch 'master' into issue6964

Author: venom1204

NAMESPACE

@@ -59,6 +59,7 @@ export(nafill)
 export(setnafill)
 export(.Last.updated)
 export(fcoalesce)
+export(cbindlist, setcbindlist)
 export(substitute2)
 #export(DT)  # mtcars |> DT(i,j,by)  #4872 #5472
 export(fctr)

NEWS.md

@@ -40,6 +40,8 @@
     # 2:     2     6     4     5
     ```
 
+8. `groupingsets()` gets a new argument `enclos` for use together with the `jj` argument in functions wrapping `groupingsets()`, including the existing wrappers `rollup()` and `cube()`. When forwarding a `j`-expression as `groupingsets(jj = substitute(j))`, make sure to pass `enclos = parent.frame()` as well, so that the `j`-expression will be evaluated in the right context. This makes it possible for `j` to refer to variables outside the `data.table`.
+
 ### BUG FIXES
 
 1. Custom binary operators from the `lubridate` package now work with objects of class `IDate` as with a `Date` subclass, [#6839](https://github.com/Rdatatable/data.table/issues/6839). Thanks @emallickhossain for the report and @aitap for the fix.
@@ -72,7 +74,11 @@
 
 15. Including an `ITime` object as a named input to `data.frame()` respects the provided name, i.e. `data.frame(a = as.ITime(...))` will have column `a`, [#4673](https://github.com/Rdatatable/data.table/issues/4673). Thanks @shrektan for the report and @MichaelChirico for the fix.
 
-16. `cube()`, `rollup()`, and `groupingsets()` no longer produce a spurious warning when using `min()` or `max()` as aggregations, [#6964](https://github.com/Rdatatable/data.table/issues/6964). Thanks @ferenci-tamas for the report and @venom1204 for the fix.
+16. `fread()` now handles the `na.strings` argument for quoted text columns, making it possible to specify `na.strings = '""'` and read empty quoted strings as `NA`s, [#6974](https://github.com/Rdatatable/data.table/issues/6974). Thanks to @AngelFelizR for the report and @aitap for the PR.
+
+17. A data.table with a column of class `vctrs_list_of` (from package {vctrs}) prints as expected, [#5948](https://github.com/Rdatatable/data.table/issues/5948). Before, they could be printed messily, e.g. printing every entry in a nested data.frame. Thanks @jesse-smith for the report, @DavisVaughan and @r2evans for contributing, and @MichaelChirico for the PR.
+
+18. `cube()`, `rollup()`, and `groupingsets()` no longer produce a spurious warning when using `min()` or `max()` as aggregations, [#6964](https://github.com/Rdatatable/data.table/issues/6964). Thanks @ferenci-tamas for the report and @venom1204 for the fix.
 
 ### NOTES
 

R/groupingsets.R

@@ -13,7 +13,7 @@ rollup.data.table = function(x, j, by, .SDcols, id = FALSE, label = NULL, ...) {
   sets = lapply(length(by):0L, function(i) by[0L:i])
   # redirect to workhorse function
   jj = substitute(j)
-  groupingsets.data.table(x, by=by, sets=sets, .SDcols=.SDcols, id=id, jj=jj, label=label)
+  groupingsets.data.table(x, by=by, sets=sets, .SDcols=.SDcols, id=id, jj=jj, label=label, enclos = parent.frame())
 }
 
 cube = function(x, ...) {
@@ -35,13 +35,13 @@ cube.data.table = function(x, j, by, .SDcols, id = FALSE, label = NULL, ...) {
   sets = lapply((2L^n):1L, function(jj) by[keepBool[jj, ]])
   # redirect to workhorse function
   jj = substitute(j)
-  groupingsets.data.table(x, by=by, sets=sets, .SDcols=.SDcols, id=id, jj=jj, label=label)
+  groupingsets.data.table(x, by=by, sets=sets, .SDcols=.SDcols, id=id, jj=jj, label=label, enclos = parent.frame())
 }
 
 groupingsets = function(x, ...) {
   UseMethod("groupingsets")
 }
-groupingsets.data.table = function(x, j, by, sets, .SDcols, id = FALSE, jj, label = NULL, ...) {
+groupingsets.data.table = function(x, j, by, sets, .SDcols, id = FALSE, jj, label = NULL, enclos = parent.frame(), ...) {
   # input data type basic validation
   if (!is.data.table(x))
     stopf("Argument 'x' must be a data.table object")
@@ -112,14 +112,10 @@ groupingsets.data.table = function(x, j, by, sets, .SDcols, id = FALSE, jj, labe
     .SDcols = if (".SD" %chin% av) setdiff(names(x), by) else NULL
   if (length(names(by))) by = unname(by)
   # 0 rows template data.table to keep colorder and type
-  empty = withCallingHandlers(
-  if (length(.SDcols)) x[0L, eval(jj), by, .SDcols=.SDcols] else x[0L, eval(jj), by],
-  simpleWarning = function(w) {
-    if (grepl("no non-missing arguments to min|max", w$message, ignore.case = TRUE)) {
-      invokeRestart("muffleWarning")
-    }
-  }
-  )
+  # inline all arguments that might clash with enclosing environment
+  pcall = substitute(x[0L, jj, by], list(x = x, jj = jj, by = by))
+  if (length(.SDcols)) pcall$.SDcols = .SDcols
+  empty = suppressWarnings(eval(pcall, list(.datatable.aware = TRUE), enclos))
   if (id && "grouping" %chin% names(empty)) # `j` could have been evaluated to `grouping` field
     stopf("When using `id=TRUE` the 'j' expression must not evaluate to a column named 'grouping'.")
   if (anyDuplicated(names(empty)) > 0L)
@@ -157,8 +153,12 @@ groupingsets.data.table = function(x, j, by, sets, .SDcols, id = FALSE, jj, labe
     stopf("Using integer64 class columns require to have 'bit64' package installed.") # nocov
   int64.by.cols = intersect(int64.cols, by)
   # aggregate function called for each grouping set
+  # inline all arguments that might clash with enclosing environment
+  pcall = substitute(x[, jj], list(x = x, jj = jj))
+  if (length(.SDcols)) pcall$.SDcols = .SDcols
   aggregate.set = function(by.set) {
-    r = if (length(.SDcols)) x[, eval(jj), by.set, .SDcols=.SDcols] else x[, eval(jj), by.set]
+    pcall$by = by.set
+    r = eval(pcall, list(.datatable.aware = TRUE), enclos)
     if (id) {
       # integer bit mask of aggregation levels: http://www.postgresql.org/docs/9.5/static/functions-aggregate.html#FUNCTIONS-GROUPING-TABLE
       # 3267: strtoi("", base = 2L) output apparently unstable across platforms

R/mergelist.R

@@ -0,0 +1,12 @@
+cbindlist_impl_ = function(l, copy) {
+  ans = .Call(Ccbindlist, l, copy)
+  if (anyDuplicated(names(ans))) { ## invalidate key and index
+    setattr(ans, "sorted", NULL)
+    setattr(ans, "index", NULL)
+  }
+  setDT(ans)
+  ans
+}
+
+cbindlist = function(l) cbindlist_impl_(l, copy=TRUE)
+setcbindlist = function(l) cbindlist_impl_(l, copy=FALSE)

R/print.data.table.R

@@ -199,8 +199,6 @@ has_format_method = function(x) {
 format_col.default = function(x, ...) {
   if (!is.null(dim(x)))
     "<multi-column>"
-  else if (has_format_method(x) && length(formatted<-format(x, ...))==length(x))
-    formatted  #PR5224 motivated by package sf where column class is c("sfc_MULTIPOLYGON","sfc") and sf:::format.sfc exists
   else if (is.list(x))
     vapply_1c(x, format_list_item, ...)
   else

inst/tests/mergelist.Rraw

@@ -0,0 +1,71 @@
+require(methods)
+
+if (exists("test.data.table", .GlobalEnv, inherits=FALSE)) {
+  if ((tt<-compiler::enableJIT(-1))>0)
+    cat("This is dev mode and JIT is enabled (level ", tt, ") so there will be a brief pause around the first test.\n", sep="")
+} else {
+  require(data.table)
+  test = data.table:::test
+}
+
+# cbindlist, setcbindlist
+
+local({
+  l = list(
+    d1 = data.table(x=1:3, v1=1L),
+    d2 = data.table(y=3:1, v2=2L),
+    d3 = data.table(z=2:4, v3=3L)
+  )
+  ans = cbindlist(l)
+  expected = data.table(l$d1, l$d2, l$d3)
+  test(11.01, ans, expected)
+  test(11.02, intersect(vapply(ans, address, ""), unlist(lapply(l, vapply, address, ""))), character())
+  ans = setcbindlist(l)
+  expected = setDT(c(l$d1, l$d2, l$d3))
+  test(11.03, ans, expected)
+  test(11.04, length(intersect(vapply(ans, address, ""), unlist(lapply(l, vapply, address, "")))), ncol(expected))
+})
+
+test(11.05, cbindlist(list(data.table(a=1L), data.table(), data.table(d=2L), data.table(f=3L))), data.table(a=1L, d=2L, f=3L))
+## codecov
+test(12.01, cbindlist(data.frame(a=1L)), error="must be a list")
+test(12.02, cbindlist(TRUE), error="must be a list")
+test(12.03, cbindlist(list(data.table(a=1L), 1L)), error="is not a data.table")
+test(12.04, options = c(datatable.verbose=TRUE), cbindlist(list(data.table(a=1:2), data.table(b=1:2))), data.table(a=1:2, b=1:2), output="cbindlist.*took")
+test(12.05, cbindlist(list(data.table(), data.table(a=1:2), data.table(b=1:2))), data.table(a=1:2, b=1:2))
+test(12.06, cbindlist(list(data.table(), data.table(a=1:2), list(b=1:2))), data.table(a=1:2, b=1:2))
+test(12.07, cbindlist(list(data.table(a=integer()), list(b=integer()))), data.table(a=integer(), b=integer()))
+## duplicated names
+test(12.08, cbindlist(list(data.table(a=1L, b=2L), data.table(b=3L, d=4L))), data.table(a=1L, b=2L, b=3L, d=4L))
+local({
+  # also test that keys, indices are wiped
+  ans = cbindlist(list(setindexv(data.table(a=2:1, b=1:2), "a"), data.table(a=1:2, b=2:1, key="a"), data.table(a=2:1, b=1:2)))
+  test(12.09, ans, data.table(a=2:1, b=1:2, a=1:2, b=2:1, a=2:1, b=1:2))
+  test(12.10, indices(ans), NULL)
+})
+## recycling, first ensure cbind recycling that we want to match to
+test(12.11, cbind(data.table(x=integer()), data.table(a=1:2)), data.table(x=c(NA_integer_, NA), a=1:2))
+test(12.12, cbind(data.table(x=1L), data.table(a=1:2)), data.table(x=c(1L, 1L), a=1:2))
+test(12.13, cbindlist(list(data.table(a=integer()), data.table(b=1:2))), error="Recycling.*not yet implemented")
+test(12.14, cbindlist(list(data.table(a=1L), data.table(b=1:2))), error="Recycling.*not yet implemented")
+test(12.15, setcbindlist(list(data.table(a=integer()), data.table(b=1:2))), error="have to have the same number of rows")
+test(12.16, setcbindlist(list(data.table(a=1L), data.table(b=1:2))), error="have to have the same number of rows")
+
+## retain indices
+local({
+  l = list(
+    data.table(id1=1:5, id2=5:1, id3=1:5, v1=1:5),
+    data.table(id4=5:1, id5=1:5, v2=1:5),
+    data.table(id6=5:1, id7=1:5, v3=1:5),
+    data.table(id8=5:1, id9=5:1, v4=1:5)
+  )
+  setkeyv(l[[1L]], "id1"); setindexv(l[[1L]], list("id1", "id2", "id3", c("id1","id2","id3"))); setindexv(l[[3L]], list("id6", "id7")); setindexv(l[[4L]], "id9")
+  ii = lapply(l, indices)
+  ans = cbindlist(l)
+  test(13.1, key(ans), "id1")
+  test(13.2, indices(ans), c("id1", "id2", "id3", "id1__id2__id3", "id6", "id7", "id9"))
+  test(13.3, ii, lapply(l, indices)) ## this tests that original indices have not been touched, shallow_duplicate in mergeIndexAttrib
+})
+test(13.4, cbindlist(list(data.table(a=1:2), data.table(b=3:4, key="b"))), data.table(a=1:2, b=3:4, key="b"))
+# TODO(#7116): this could be supported
+# test(13.5, cbindlist(list(data.table(a=1:2, key="a"), data.table(b=3:4, key="b"))), data.table(a=1:2, b=3:4, key=c("a", "b")))

inst/tests/other.Rraw

@@ -1,4 +1,4 @@
-pkgs = c("ggplot2", "hexbin", "plyr", "dplyr", "caret", "zoo", "xts", "gdata", "nlme", "bit64", "knitr", "parallel", "sf", "nanotime", "R.utils", "yaml")
+pkgs = c("bit64", "caret", "dplyr", "gdata", "ggplot2", "hexbin", "knitr", "nanotime", "nlme", "parallel", "plyr", "R.utils", "sf", "vctrs", "xts", "yaml", "zoo")
 # First expression of this file must be as above: .gitlab-ci.yml uses parse(,n=1L) to read one expression from this file and installs pkgs.
 # So that these dependencies of other.Rraw are maintained in a single place.
 # TEST_DATA_TABLE_WITH_OTHER_PACKAGES is off by default so this other.Rraw doesn't run on CRAN. It is run by GLCI, locally in dev, and by
@@ -221,6 +221,7 @@ test(14.2, {example('CJ', package='data.table', local=TRUE, echo=FALSE); TRUE})
 if (loaded[["sf"]]) {  #2273
   DT = as.data.table(st_read(system.file("shape/nc.shp", package = "sf"), quiet=TRUE))
   test(15, DT[1:3, .(NAME, FIPS, geometry)], output="Ashe.*-81.4.*Surry.*-80.4")
+  test(15.1, DT, output="MULTIPOLYGON (((") # make sure individual list items are formatted, #6637, #5224
 
   dsf = sf::st_as_sf(data.table(x=1:10, y=1:10, s=sample(1:2, 10, TRUE)), coords=1:2)
   test(16, split(dsf, dsf$s), list(`1` = dsf[dsf$s == 1, ], `2` = dsf[dsf$s == 2, ]))
@@ -774,3 +775,9 @@ if (loaded[["nanotime"]]) {
 res <- tables(env=.e)
 test(32, res[, .(NAME,NROW,NCOL,MB)], data.table(NAME="DT",NROW=20000000L,NCOL=15L,MB=2288.0))
 rm(.e, res)
+
+if (loaded[["vctrs"]]) {
+  # vctrs::list_of() columns are treated the same as other list() columns
+  DT = data.table(a = 1, b = list_of(mtcars))
+  test(33, DT, output="<vctrs_list_of>.*<data\\.frame\\[32x11\\]>")
+}

inst/tests/tests.Rraw

@@ -16800,15 +16800,15 @@ registerS3method("format_col", "complex", format_col.default)
 # then i) test 1610.1 fails if test.data.table() is rerun, ii) user display of complex data would be affected
 # did try wrapping with on.exit(,add=TRUE) but perhaps because this is a script that is sys.source'd, it ran straight away
 
-# format method for column takes predecedence over format method for each list item
+# as of #6637, format individual list items but not the whole list
 registerS3method("format", "myclass2130", function(x, ...) paste0("<", class(x)[1L], ":", x$id, ">"))
 DT = data.table(row=1:2, objs=list(structure(list(id="foo"), class="myclass2130"), structure(list(id="bar"), class="myclass2130")))
 test(2130.13, print(DT), output="myclass2130:foo.*myclass2130:bar")
 setattr(DT$objs, "class", "foo2130")
 registerS3method("format", "foo2130", function(x, ...) "All hail foo")
 test(2130.14, print(DT), output="myclass2130:foo.*myclass2130:bar") # because length 1 from format but needs to be length(x)
 registerS3method("format", "foo2130", function(x, ...) rep("All hail foo",length(x)))
-test(2130.15, print(DT), output="All hail foo")  # e.g. sf:::format.sfc rather than sf:::format.sfg on each item
+test(2130.15, print(DT), output="myclass2130:foo.*myclass2130:bar") # used to call format(column), not vapply_1c(column, format)
 setattr(DT$objs, "class", "bar2130_with_no_method")
 test(2130.16, print(DT), output="myclass2130:foo.*myclass2130:bar")
 registerS3method("format", "myclass2130", format.default)
@@ -21252,3 +21252,54 @@ it <- as.ITime('00:00:00')
 test(2323.1, names(data.frame(COL = it)), "COL")
 test(2323.2, names(data.frame(b = 1, COL = it)), c("b", "COL"))
 test(2323.3, names(as.data.frame(it, optional=TRUE)), NULL)
+
+# 'sets' is a local variable in groupingsets(), cube(), rollup() and shouldn't leak into the 'j' expression
+n = 24L
+set.seed(25)
+DT = data.table(
+    color = sample(c("green","yellow","red"), n, TRUE),
+    year = as.Date(sample(paste0(2011:2015,"-01-01"), n, TRUE)),
+    status = as.factor(sample(c("removed","active","inactive","archived"), n, TRUE)),
+    amount = sample(1:5, n, TRUE),
+    value = sample(c(3, 3.5, 2.5, 2), n, TRUE)
+)
+sets = 0
+test(2324.0,
+  groupingsets(DT, j = c(list(count=.N + ..sets)), by = c("color","year","status"), sets = list("color", c("year","status"), character()), id=TRUE),
+  groupingsets(DT, j = c(list(count=.N + 0)), by = c("color","year","status"), sets = list("color", c("year","status"), character()), id=TRUE)
+)
+test(2324.1,
+  cube(DT, j = sum(value) + ..sets, by = c("color","year","status"), id=TRUE),
+  cube(DT, j = sum(value), by = c("color","year","status"), id=TRUE)
+)
+test(2324.2,
+  rollup(DT, j = sum(value) + ..sets, by=c("color","year","status"), label="total"),
+  rollup(DT, j = sum(value), by=c("color","year","status"), label="total")
+)
+
+# allow na.strings to be quoted, #6974
+f = tempfile()
+DT = data.table(
+  "Date Example"=c("12/5/2012", NA),
+  "Question 1"=c("Yes", NA),
+  "Question 2"=c("Yes", NA),
+  "Site: Country"=c("Chile", "Virgin Islands, British")
+)
+fwrite(DT, f, na='""')
+test(2325.1, fread(f, na.strings='""'), DT)
+unlink(f)
+test(2325.2,
+     fread('"foo","bar","baz"\n"a","b","c"', na.strings=c('"foo"', '"bar"', '"baz"'), header=FALSE),
+     data.table(V1=c(NA, "a"), V2=c(NA, "b"), V3=c(NA, "c")))
+
+## ensure setDT will retain key and indices when it is called on the list (cbindlist assumes this)
+local({
+  d = data.table(x=1:2, y=2:1, z=2:1, v1=1:2)
+  setkeyv(d, "x"); setindexv(d, list("y", "z"))
+  a = attributes(d)
+  attributes(d) = a[!names(a) %in% c("class", ".internal.selfref", "row.names")]
+  test(2326.1, class(d), "list")
+  setDT(d)
+  test(2326.2, key(d), "x")
+  test(2326.3, indices(d), c("y", "z"))
+})

man/cbindlist.Rd

@@ -0,0 +1,41 @@
+\name{cbindlist}
+\alias{cbindlist}
+\alias{setcbindlist}
+\alias{cbind}
+\alias{cbind.data.table}
+\title{Column bind multiple data.tables}
+\description{
+  Column bind multiple \code{data.table}s.
+}
+\usage{
+  cbindlist(l)
+  setcbindlist(l)
+}
+\arguments{
+  \item{l}{ \code{list} of \code{data.table}s to merge. }
+}
+\details{
+  Column bind only stacks input elements. Works like \code{\link{data.table}}, but takes \code{list} type on input. Zero-column tables in \code{l} are omitted. Tables in \code{l} should have matching row count; recycling of length-1 rows is not yet implemented. Indices of the input tables are transferred to the resulting table, as well as the \emph{key} of the first keyed table.
+}
+\value{
+  A new \code{data.table} based on the stacked objects.
+  
+  For \code{setcbindlist}, columns in the output will be shared with the input, i.e., \emph{no copy is made}.
+}
+\note{
+  No attempt is made to deduplicate resulting names. If the result has any duplicate names, keys and indices are removed.
+}
+\seealso{
+  \code{\link{data.table}}, \code{\link{rbindlist}}, \code{\link{setDT}}
+}
+\examples{
+d1 = data.table(x=1:3, v1=1L, key="x")
+d2 = data.table(y=3:1, v2=2L, key="y")
+d3 = data.table(z=2:4, v3=3L)
+cbindlist(list(d1, d2, d3))
+cbindlist(list(d1, d1))
+d4 = setcbindlist(list(d1))
+d4[, v1:=2L]
+identical(d4, d1)
+}
+\keyword{ data }

man/fctr.Rd

@@ -3,7 +3,7 @@
 \alias{factor}
 \title{Create a factor retaining original ordering}
 \description{
-  Creates a code{\link[base:factor]{factor}}.
+  Creates a \code{\link[base]{factor}}.
 
   By default, the output will have its levels in the original order, i.e., \code{levels = unique(x)}, as opposed to \code{factor}'s default where \code{levels = sort(unique(x))}.
 }
@@ -13,7 +13,7 @@ fctr(x, levels=unique(x), ..., sort=FALSE, rev=FALSE)
 \arguments{
   \item{x}{ Object to be turned into a factor. }
   \item{levels}{ Levels for the new factor; \code{unique(x)} by default. }
-  \item{\dots}{ Other arguments passed to code{\link[base:factor]{factor}}. }
+  \item{\dots}{ Other arguments passed to \code{\link[base]{factor}}. }
   \item{sort}{ Logical, default \code{FALSE}. Should \code{levels} be sorted? }
   \item{rev}{ Logical, default \code{FALSE}. Should \code{levels} be reversed? Applied \emph{after} \code{sort}. }
 }