Merge remote-tracking branch 'origin/master' into issue777666777

Author: venom1204

.ci/atime/tests.R

@@ -64,7 +64,14 @@ for(retGrp_chr in c("T","F"))extra.test.list[[sprintf(
 # - seconds.limit: The maximum median timing (in seconds) of an expression. No timings for larger N are computed past that threshold. Default of 0.01 seconds should be sufficient for most tests.
 # - Historical references (short version name = commit SHA1).
 #   For historical regressions, use version names 'Before', 'Regression', and 'Fixed'
-#   When there was no regression, use 'Slow' and 'Fast' 
+#   When there was no regression, use 'Slow' and 'Fast'
+# - Caveat: atime installs each version as a separate package but runs them all in ONE R session.
+#   State registered outside a package's own namespace therefore persists across versions and can
+#   mask a regression. The clearest case is S3 methods for base group generics (Ops, Math, Summary)
+#   and helpers like chooseOpsMethod: these register into the base namespace's S3 table
+#   (get(".__S3MethodsTable__.", envir = baseenv())), which is shared. If one version registers such
+#   a method, it stays active while a version that lacks it is measured. When a test depends on
+#   such state, reset it inside `expr` to match the version under test (see the #7213 test below).
 # @note Please check https://github.com/tdhock/atime/blob/main/vignettes/data.table.Rmd for more information.
 # nolint start: undesirable_operator_linter. ':::' needed+appropriate here.
 test.list <- atime::atime_test_list(
@@ -335,8 +342,8 @@ test.list <- atime::atime_test_list(
       L = as.data.table(as.character(rnorm(N, 1, 0.5)))
       setkey(L, V1)
     },
-    Fast = "680b5e8e6d3f16a09dfb2f86ac7b2ce5ce70c3f1", # Merge commit in the PR (https://github.com/Rdatatable/data.table/pull/4501/commits) that fixes the issue 
-    Slow = "3ca83738d70d5597d9e168077f3768e32569c790", # Circa 2024 master parent of close-to-last merge commit (https://github.com/Rdatatable/data.table/commit/353dc7a6b66563b61e44b2fa0d7b73a0f97ca461) in the PR (https://github.com/Rdatatable/data.table/pull/4501/commits) that fixes the issue 
+    Fast = "680b5e8e6d3f16a09dfb2f86ac7b2ce5ce70c3f1", # Merge commit in the PR (https://github.com/Rdatatable/data.table/pull/4501/commits) that fixes the issue
+    Slow = "3ca83738d70d5597d9e168077f3768e32569c790", # Circa 2024 master parent of close-to-last merge commit (https://github.com/Rdatatable/data.table/commit/353dc7a6b66563b61e44b2fa0d7b73a0f97ca461) in the PR (https://github.com/Rdatatable/data.table/pull/4501/commits) that fixes the issue
     Slower = "cacdc92df71b777369a217b6c902c687cf35a70d", # Circa 2020 parent of the first commit (https://github.com/Rdatatable/data.table/commit/74636333d7da965a11dad04c322c752a409db098) in the PR (https://github.com/Rdatatable/data.table/pull/4501/commits) that fixes the issue
     ## New DT can safely retain key.
     expr = data.table:::`[.data.table`(L, , .SD)),
@@ -371,7 +378,7 @@ test.list <- atime::atime_test_list(
         x = rep(NA, N)
         x[i] = i
         x
-      })  
+      })
     },
     Slow = "fd24a3105953f7785ea7414678ed8e04524e6955", # Parent of the merge commit (https://github.com/Rdatatable/data.table/commit/ed72e398df76a0fcfd134a4ad92356690e4210ea) of the PR (https://github.com/Rdatatable/data.table/pull/5054) that fixes the issue
     Fast = "ed72e398df76a0fcfd134a4ad92356690e4210ea", # Merge commit of the PR (https://github.com/Rdatatable/data.table/pull/5054) that fixes the issue
@@ -400,6 +407,35 @@ test.list <- atime::atime_test_list(
     Fast = "2715663fcf0344c3f7c73241d391d8de347bdb9d",  # Merge commit of the PR that improves efficiency
     expr = data.table:::as.data.table.array(arr, na.rm=FALSE)),
 
+  # Date-IDate subtraction became much slower when chooseOpsMethod.IDate was added in #7213.
+  "Date-IDate subtraction regression in #7213" = atime::atime_test(
+    N = as.integer(10^seq(1, 5, by=0.5)),
+    setup = {
+      short_date = as.Date("2000-01-01") + seq_len(40L)
+      long_date = as.Date("2000-01-01") + seq_len(N)
+    },
+    Before = "84b0e32f7a1bfdd8ec3a2c4012010b3ec072b31f", # Parent of the regression commit.
+    Regression = "cfa9f49bd27195962573ad493a31600d173abc5c", # Merge commit of #7213 which added chooseOpsMethod.IDate.
+    seconds.limit = 1,
+    # Reset the shared base S3 table to match the version under test (see "Caveat" in the intro above).
+    expr = {
+      ns = environment(data.table::as.IDate)
+      s3_table = get(".__S3MethodsTable__.", envir = baseenv())
+      s3_generics = c("chooseOpsMethod.IDate" = "chooseOpsMethod", "-.IDate" = "-")
+      for (s3_method in names(s3_generics)) {
+        if (exists(s3_method, envir = s3_table, inherits = FALSE)) {
+          rm(list = s3_method, envir = s3_table)
+        }
+        if (exists(s3_method, envir = ns, inherits = FALSE)) {
+          base::registerS3method(
+            s3_generics[[s3_method]], "IDate",
+            get(s3_method, envir = ns, inherits = FALSE),
+            envir = ns)
+        }
+      }
+      outer(short_date, data.table::as.IDate(long_date), `-`)
+    }),
+
   # https://github.com/Rdatatable/data.table/pull/7144 added the speedup code and this performance test.
   "isoweek improved in #7144" = atime::atime_test(
     setup = {

.dev/cc.R

@@ -51,7 +51,7 @@ sourceImports = function(path=getwd(), quiet=FALSE) {
     #   https://stat.ethz.ch/pipermail/r-devel/2024-April/083319.html
     for (import in imported) assign(import, getExportedValue(entry[[1L]], import), .GlobalEnv)
   }
-  return(invisible())
+  invisible()
 }
 
 cc = function(test=FALSE, clean=FALSE, debug=FALSE, omp=!debug, path=Sys.getenv("PROJ_PATH", unset=normalizePath(".")), CC="gcc", quiet=FALSE) {
@@ -70,7 +70,7 @@ cc = function(test=FALSE, clean=FALSE, debug=FALSE, omp=!debug, path=Sys.getenv(
   dll = grep("data_table.so", dll, fixed=TRUE, value=TRUE)
   sapply(dll, dyn.unload)
   gc()
-  
+
   # hack for windows under mingw-like environment
   # PROJ_PATH must be windows like i.e.: export PROJ_PATH=$(Rscript -e 'getwd()')
   if (.Platform$OS.type == "windows") {
@@ -90,10 +90,11 @@ cc = function(test=FALSE, clean=FALSE, debug=FALSE, omp=!debug, path=Sys.getenv(
   if (!quiet) cat(getwd(),"\n")
   if (clean) system("rm *.o *.so")
   OMP = if (omp) "openmp" else "no-openmp"
+  R = file.path(R.home("bin"), "R")
   if (debug) {
-    cmd = sprintf(R"(MAKEFLAGS='-j CC=%s PKG_CFLAGS=-f% CFLAGS=-std=c11\ -O0\ -ggdb\ %s\ -pedantic' R CMD SHLIB -d -o data_table.so *.c)", CC, OMP, W32)
+    cmd = sprintf(R"(MAKEFLAGS='-j CC=%s PKG_CFLAGS=-f%s CFLAGS=-std=c11\ -O0\ -ggdb\ %s\ -pedantic' %s CMD SHLIB -d -o data_table.so *.c)", CC, OMP, W32, R)
   } else {
-    cmd = sprintf(R"(MAKEFLAGS='-j CC=%s CFLAGS=-f%s\ -std=c11\ -O3\ -pipe\ -Wall\ -pedantic\ -Wstrict-prototypes\ -isystem\ /usr/share/R/include\ %s\ -fno-common' R CMD SHLIB -o data_table.so *.c)", CC, OMP, W32)
+    cmd = sprintf(R"(MAKEFLAGS='-j CC=%s CFLAGS=-f%s\ -std=c11\ -O3\ -pipe\ -Wall\ -pedantic\ -Wstrict-prototypes\ -isystem\ %s\ %s\ -fno-common' %s CMD SHLIB -o data_table.so *.c)", CC, OMP, R.home("include"), W32, R)
     # the -isystem suppresses strict-prototypes warnings from R's headers, #5477. Look at the output to see what -I is and pass the same path to -isystem.
     # TODO add -Wextra too?
   }
@@ -126,4 +127,3 @@ cc = function(test=FALSE, clean=FALSE, debug=FALSE, omp=!debug, path=Sys.getenv(
 }
 
 dd = function(omp=FALSE)cc(test=FALSE,debug=TRUE,omp=omp,clean=TRUE)
-

NAMESPACE

@@ -206,6 +206,8 @@ S3method(rep, IDate)
 S3method(rep, ITime)
 S3method(round, IDate)
 S3method(round, ITime)
+S3method(is.numeric, IDate)
+S3method(is.numeric, ITime)
 S3method(trunc, ITime)
 S3method(seq, IDate)
 S3method(seq, ITime)

NEWS.md

@@ -12,6 +12,8 @@
 
 3. options `"datatable.old.matrix.autoname"` is now `FALSE` by default, meaning `names(data.table(x=1, cbind(1)))` is now `c("x", "V2")`. Toggle the option to retain the old behavior for now; future releases will work to remove this possibility. See the release notes for 1.18.0, item 1 under `NOTE OF INTENDED FUTURE POTENTIAL BREAKING CHANGES`.
 
+4. `is.numeric()` now returns `FALSE` for `IDate` and `ITime`, since these classes don't support arbitrary numeric operations, [#7746](https://github.com/Rdatatable/data.table/issues/7746). Thanks @aitap for the report and fix.
+
 ### NEW FEATURES
 
 1. `nafill()`, `setnafill()` extended to work on logical, factor and character vectors (part of [#3992](https://github.com/Rdatatable/data.table/issues/3992)). Includes support for `Date`, `IDate`, `POSIXct` and character vectors. Thanks @jangorecki for the request and @jangorecki, @MichaelChirico and @ben-schwen for the PRs.
@@ -64,6 +66,10 @@
 
 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. Subtracting an `IDate` from a `Date` is fast again by avoiding unnecessary conversion to `POSIXlt`/`POSIXct`, [#7825](https://github.com/Rdatatable/data.table/issues/7825). Thanks @gilesheywood for the report and @ben-schwen for the fix.
+
+15. `as.IDate()` and `as.ITime()` now preserve names, matching base `as.Date()` behavior, [#7252](https://github.com/Rdatatable/data.table/issues/7252). Thanks @DavisVaughan for the report and @venom1204 for the PR.
+
 ### Notes
 
 1. {data.table} now depends on R 3.5.0 (2018).

R/IDateTime.R

@@ -5,6 +5,11 @@
 
 as.IDate = function(x, ...) UseMethod("as.IDate")
 
+copy_names = function(ans, nm) {
+  if (!is.null(nm)) setattr(ans, "names", nm)
+  ans
+}
+
 as.IDate.default = function(x, ..., tz = attr(x, "tzone", exact=TRUE)) {
   if (is.null(tz)) tz = "UTC"
   if (is.character(x)) {
@@ -17,30 +22,35 @@ as.IDate.default = function(x, ..., tz = attr(x, "tzone", exact=TRUE)) {
 as.IDate.numeric = function(x, origin = "1970-01-01", ...) {
   if (origin=="1970-01-01") {
     # standard epoch
+    nm = names(x)
     x = as.integer(x)
     class(x) = c("IDate", "Date")
     # We used to use structure() here because class(x)<- copied several times in R before v3.1.0
     # Since R 3.1.0 improved class()<- and data.table's oldest oldest supported R is now >3.1.0, we can use class<- again
     # structure() contains a match() and replace for specials, which we don't need.
     # class()<- ensures at least 1 shallow copy as appropriate is returned.
-    x
+    copy_names(x, nm)
   } else {
     # only call expensive as.IDate.character if we have to
-    as.IDate(origin, ...) + as.integer(x)
+    as.IDate(origin, ...) + copy_names(as.integer(x), names(x))
   }
 }
 
 as.IDate.Date = function(x, ...) {
+  nm = names(x)
   x = as.integer(x)                 # if already integer, x will be left unchanged as the original input
   class(x) = c("IDate", "Date")     # class()<- will copy if as.integer() did not create, and may not if it did we hope
-  x                                 # always return a new object
+  copy_names(x, nm)
 }
 
 as.IDate.POSIXct = function(x, tz = attr(x, "tzone", exact=TRUE), ...) {
-  if (is_utc(tz))
-    (setattr(as.integer(as.numeric(x) %/% 86400L), "class", c("IDate", "Date")))  # %/% returns new object so can use setattr() on it; wrap with () to return visibly
-  else
+  if (is_utc(tz)) {
+    ans = as.integer(as.numeric(x) %/% 86400L)  # %/% returns a new object, so setattr() is safe
+    setattr(ans, "class", c("IDate", "Date"))
+    copy_names(ans, names(x))
+  } else {
     as.IDate(as.Date(x, tz =  tz %||% '', ...))
+  }
 }
 
 as.IDate.IDate = function(x, ...) x
@@ -51,6 +61,10 @@ as.Date.IDate = function(x, ...) {
 }
 
 mean.IDate =
+  function(x, ...) {
+    x = unclass(x)
+    as.IDate(NextMethod())
+  }
 seq.IDate =
 c.IDate =
 cut.IDate =
@@ -90,6 +104,8 @@ round.IDate = function(x, digits=c("weeks", "months", "quarters", "years"), ...)
           quarters = ISOdate(year(x), 3L * (quarter(x)-1L) + 1L, 1L),
           years = ISOdate(year(x), 1L, 1L)))
 }
+# Dates aren't simple numbers, and round.IDate doesn't accept numeric 'digits'.
+is.numeric.IDate = function(x) FALSE
 
 chooseOpsMethod.IDate = function(x, y, mx, my, cl, reverse) inherits(y, "Date")
 
@@ -106,12 +122,23 @@ chooseOpsMethod.IDate = function(x, y, mx, my, cl, reverse) inherits(y, "Date")
   }
   if (inherits(e1, "Date") && inherits(e2, "Date"))
     stopf("binary + is not defined for \"IDate\" objects")
-  (setattr(as.integer(unclass(e1) + unclass(e2)), "class", c("IDate", "Date")))  # () wrap to return visibly
+  res = unclass(e1) + unclass(e2)
+  nm = names(res)
+  ans = as.integer(res)
+  setattr(ans, "class", c("IDate", "Date"))
+  copy_names(ans, nm)
 }
 
 `-.IDate` = function(e1, e2) {
   if (!inherits(e1, "IDate")) {
-    if (inherits(e1, 'Date')) return(base::`-.Date`(e1, e2))
+    if (inherits(e1, "Date")) {
+      if (!inherits(e2, "Date")) return(base::`-.Date`(e1, e2))
+      #7825 avoid base::`-.Date` to avoid conversion from IDate to POSIXlt/POSIXct
+      ans = unclass(e1) - unclass(e2)
+      setattr(ans, "class", "difftime")
+      setattr(ans, "units", "days")
+      return(ans)
+    }
     stopf("can only subtract from \"IDate\" objects")
   }
   if (storage.mode(e1) != "integer")
@@ -126,14 +153,16 @@ chooseOpsMethod.IDate = function(x, y, mx, my, cl, reverse) inherits(y, "Date")
     return(base::`-.Date`(as.Date(e1), e2))
     # can't call base::.Date directly (last line of base::`-.Date`) as tried in PR#3168 because ?.Date states "Internal objects in the base package most of which are only user-visible because of the special nature of the base namespace."
   }
-  ans = as.integer(unclass(e1) - unclass(e2))
+  res = unclass(e1) - unclass(e2)
+  nm = names(res)
+  ans = as.integer(res)
   if (inherits(e2, "Date")) {
     setattr(ans, "class", "difftime")
     setattr(ans, "units", "days")
   } else {
     setattr(ans, "class", c("IDate", "Date"))
   }
-  ans
+  copy_names(ans, nm)
 }
 
 
@@ -155,13 +184,18 @@ as.ITime.POSIXct = function(x, tz = attr(x, "tzone", exact=TRUE), ...) {
 }
 
 as.ITime.numeric = function(x, ms = 'truncate', ...) {
+  nm = names(x)
   secs = clip_msec(x, ms) %% 86400L # the %% here ensures a local copy is obtained; the truncate as.integer() may not copy
-  (setattr(secs, "class", "ITime"))
+  setattr(secs, "class", "ITime")
+  copy_names(secs, nm)
 }
 
 as.ITime.character = function(x, format, ...) {
+  nm = names(x)
   x = unclass(x)
-  if (!missing(format)) return(as.ITime(strptime(x, format = format, ...), ...))
+  if (!missing(format)) {
+    return(copy_names(as.ITime(strptime(x, format = format, ...), ...), nm))
+  }
   # else allow for mixed formats, such as test 1189 where seconds are caught despite varying format
   y = strptime(x, format = "%H:%M:%OS", ...)
   w = which(is.na(y))
@@ -181,18 +215,23 @@ as.ITime.character = function(x, format, ...) {
       w = w[!nna]
     }
   }
-  as.ITime(y, ...)
+  copy_names(as.ITime(y, ...), nm)
 }
 
 as.ITime.POSIXlt = function(x, ms = 'truncate', ...) {
+  nm = names(x)
   secs = clip_msec(x$sec, ms)
-  (setattr(with(x, secs + min * 60L + hour * 3600L), "class", "ITime"))  # () wrap to return visibly
+  ans = with(x, secs + min * 60L + hour * 3600L)
+  setattr(ans, "class", "ITime")
+  copy_names(ans, nm)
 }
 
 as.ITime.times = function(x, ms = 'truncate', ...) {
+  nm = names(x)
   secs = 86400L * (unclass(x) %% 1L)
   secs = clip_msec(secs, ms)
-  (setattr(secs, "class", "ITime"))  # the first line that creates sec will create a local copy so we can use setattr() to avoid potential copy of class()<-
+  setattr(secs, "class", "ITime")  # the first line that creates sec will create a local copy so we can use setattr() to avoid potential copy of class()<-
+  copy_names(secs, nm)
 }
 
 as.character.ITime = format.ITime = function(x, ...) {
@@ -248,6 +287,9 @@ round.ITime = function(x, digits = c("hours", "minutes"), ...)
            "class", "ITime"))
 }
 
+# Day times aren't simple numbers, and round.ITime doesn't accept numeric 'digits'.
+is.numeric.ITime = function(x) FALSE
+
 trunc.ITime = function(x, units = c("hours", "minutes"), ...)
 {
   (setattr(switch(match.arg(units),
@@ -272,7 +314,11 @@ unique.ITime = function(x, ...) {
 }
 
 # various methods to ensure ITime class is retained, #3628
-mean.ITime = seq.ITime = c.ITime = function(x, ...) as.ITime(NextMethod())
+mean.ITime = function(x, ...) {
+  x = unclass(x)
+  as.ITime(NextMethod())
+}
+c.ITime = seq.ITime = function(...) as.ITime(NextMethod())
 
 
 # create a data.table with IDate and ITime columns

R/data.table.R

@@ -567,7 +567,7 @@ replace_dot_alias = function(e) {
         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"))
+    else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "by", deparse1(bysub, collapse="\n"))
   }
   bynull = !missingby && is.null(by) #3530
   byjoin = !is.null(by) && is.symbol(bysub) && bysub==".EACHI"
@@ -632,7 +632,7 @@ replace_dot_alias = function(e) {
         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(jsub)) {j = substitute(); jsub=NULL} else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "j", deparse1(jsub, collapse="\n"))
     }
   }
   if (!missing(j)) {
@@ -722,7 +722,7 @@ replace_dot_alias = function(e) {
         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(isub)) {i = substitute(); isub=NULL} else if (verbose && !is.null(env)) catf("Argument '%s' after substitute: %s\n", "i", deparse1(isub, collapse="\n"))
     }
   }
   if (!missing(i)) {
@@ -2252,7 +2252,7 @@ replace_dot_alias = function(e) {
 
 # 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 ""
+root_name = function(jsub) if (is.call(jsub)) deparse1(jsub[[1L]], width.cutoff=60L) else ""
 
 DT = function(x, ...) {  #4872
   old = getOption("datatable.optimize")

R/transpose.R

@@ -51,7 +51,7 @@ tstrsplit = function(x, ..., fill=NA, type.convert=FALSE, keep, names=FALSE) {
       if(!n) stopf("The argument 'type.convert' does not support empty list.")
       is_named = nzchar(names(type.convert))
       all_is_named = length(is_named) && all(is_named)                  # because all(is_named)=TRUE if is_named=NULL <-- names(type.convert)=NULL
-      last_item = paste(deparse(substitute(type.convert)[[n + 1L]], width.cutoff=500L), collapse=" ")
+      last_item = deparse1(substitute(type.convert)[[n + 1L]])
       if (!all_is_named) {
         if (!(sum(!is_named) == 1L && !is_named[n] && is.function(type.convert[[n]])))
           stopf("When the argument 'type.convert' contains an unnamed element, it is expected to be the last element and should be a function. More than one unnamed element is not allowed unless all elements are functions with length equal to %d (the length of the transpose list or 'keep' argument if it is specified).", length(keep))