diff(<matrix-alike>, lag, diff.) |-> matrix also when lag*diff. > nrow(.)

git-svn-id: https://svn.r-project.org/R/trunk@89070 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -385,6 +385,10 @@
       \item \code{all.equal(obj, simple, check.class=FALSE)} now is true, also
       when \code{simple} is a bare atomic vector and \code{obj} has a simple
       class, fixing the first part of \PR{18971} thanks to \I{Jan Gorecki}.
+
+      \item \code{diff(m, lag, dif)} for matrix \code{m} now still returns
+      matrices, also when \code{lag * dif > nrow(m)} (\PR{18972}, thanks to
+      \I{Mikael Jagan}).
     }
   }
 }

src/library/base/R/dates.R

@@ -274,7 +274,7 @@ seq.Date <- function(from, to, by, length.out = NULL, along.with = NULL, ...)
         if(nby2 > 2L || nby2 < 1L)
             stop("invalid 'by' string")
         bys <- c("days", "weeks", "months", "quarters", "years")
-        valid <- pmatch(by2[nby2], bys) 
+        valid <- pmatch(by2[nby2], bys)
         if(is.na(valid)) stop("invalid string for 'by'")
         by <- bys[valid] # had *partial* match
         if(valid > 2L) { # seq.POSIXt handles the logic for non-arithmetic cases
@@ -436,8 +436,10 @@ diff.Date <- function (x, lag = 1L, differences = 1L, ...)
     xlen <- if (ismat) dim(x)[1L] else length(x)
     if (length(lag) != 1L || length(differences) > 1L || lag < 1L || differences < 1L)
         stop("'lag' and 'differences' must be integers >= 1")
-    if (lag * differences >= xlen)
-        return(.difftime(numeric(), units="days"))
+    if (lag * differences >= xlen) {
+        x0 <- if(ismat) x[0L, , drop = FALSE] else x[0L]
+        return(x0 - x0) # '-' |->  "difftime"
+    }
     r <- x
     i1 <- -seq_len(lag)
     if (ismat)

src/library/base/R/datetime.R

@@ -1382,7 +1382,10 @@ diff.POSIXt <- function (x, lag = 1L, differences = 1L, ...)
     xlen <- if (ismat) dim(x)[1L] else length(r)
     if (length(lag) != 1L || length(differences) > 1L || lag < 1L || differences < 1L)
         stop("'lag' and 'differences' must be integers >= 1")
-    if (lag * differences >= xlen) return(.difftime(numeric(), "secs"))
+    if (lag * differences >= xlen) {
+        x0 <- if(ismat) x[0L, , drop = FALSE] else x[0L]
+        return(x0 - x0) # '-' |->  "difftime"
+    }
     i1 <- -seq_len(lag)
     if (ismat)
         for (i in seq_len(differences))

src/library/base/R/diff.R

@@ -1,7 +1,7 @@
 #  File src/library/base/R/diff.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2013 The R Core Team
+#  Copyright (C) 1995-2025 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -26,7 +26,7 @@ diff.default <- function(x, lag = 1L, differences = 1L, ...)
         lag < 1L || differences < 1L)
 	stop("'lag' and 'differences' must be integers >= 1")
     if (lag * differences >= xlen)
-	return(x[0L]) # empty, but of proper mode
+	return( if(ismat) x[0L, , drop = FALSE] else x[0L] ) # empty, but of proper mode
     r <- unclass(x)  # don't want class-specific subset methods
     i1 <- -seq_len(lag)
     if (ismat)

src/library/stats/R/ts.R

@@ -264,7 +264,8 @@ diff.ts <- function (x, lag = 1, differences = 1, ...)
 {
     if (lag < 1 || differences < 1)
         stop("bad value for 'lag' or 'differences'")
-    if (lag * differences >= NROW(x)) return(x[0L])
+    if (lag * differences >= NROW(x))
+        return(if(is.matrix(x)) x[0L, , drop = FALSE] else x[0L])
     ## <FIXME>
     ## lag() and its default method are defined in package ts, so we
     ## need to provide our own implementation.

tests/reg-tests-1e.R

@@ -2371,6 +2371,23 @@ stopifnot(exprs = {
 ## 'check.class' was not passed downstream in R <= 4.5.2
 
 
+## diff(x=<m-by-n>, l, d) dropped dimensions when l*d >= m
+m <- provideDimnames(matrix(0, 10L, 1L))
+names(dimnames(m)) <- c("row", "col")
+.difftime1 <- .difftime # diff() shouldn't hard code units="days"
+formals(.difftime1)$units <- "secs"
+##' list_(a, b, cc)  creates a *named* list  using the actual arguments' names
+list_ <- function(...) `names<-`(list(...), vapply(sys.call()[-1L], as.character, ""))
+L <- lapply(list_(identity, ts, .Date, .POSIXct, .difftime1),
+            \(fn) { fnm0 <- (fnm <- fn(m))[0L, , drop = FALSE]
+                list(f0 = fnm0, f = diff(fnm, lag = 2L, differences = 5L)) })
+str(L, give.attr=FALSE) # now  0 x 1  matrices
+  vapply(L, \(.) identical(.$f0, .$f), NA) # where all FALSE; now not all TRUE
+stopifnot( print(
+  vapply(L, \(.) identical(.$f0 - .$f0, .$f), NA) ) )
+## where all FALSE : diff(fnm, 2,5) was not a matrix
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,