diff(<matrix>, lag, diff.) simplification -> nicer fix - amending 89070

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

Author: maechler

doc/NEWS.Rd

@@ -406,7 +406,7 @@
 
       \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}).
+      \I{Mikael Jagan} and \I{Suharto Anggono}).
       \code{diff(<ts-matrix>)} remains matrix, even when it has length zero.
 
       \item \code{str(x, give.attr=FALSE)} no longer shows attributes when

src/library/base/R/dates.R

@@ -433,23 +433,20 @@ rep.Date <- function(x, ...)
 diff.Date <- function (x, lag = 1L, differences = 1L, ...)
 {
     ismat <- is.matrix(x)
-    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) {
-        x0 <- if(ismat) x[0L, , drop = FALSE] else x[0L]
-        return(x0 - x0) # '-' |->  "difftime"
-    }
-    r <- x
     i1 <- -seq_len(lag)
+    i0 <- integer()
     if (ismat)
-        for (i in seq_len(differences)) r <- r[i1, , drop = FALSE] -
-            r[-nrow(r):-(nrow(r) - lag + 1L), , drop = FALSE]
-    else for (i in seq_len(differences))
-        r <- r[i1] - r[-length(r):-(length(r) - lag + 1L)]
+        for (i in seq_len(differences))
+            x <- x[i1, , drop = FALSE] -
+                x[if(lag < (len <- nrow(x))) -len:-(len - lag + 1L) else i0, , drop = FALSE]
+    else
+        for(i in seq_len(differences))
+            x <- x[i1] - x[if(lag < (len <- length(x))) -len:-(len - lag + 1L) else i0]
     if("units" %in% ...names() && (dunits <- list(...)$units) != "auto")
-        units(r) <- match.arg(dunits, choices = setdiff(eval(formals(difftime)$units), "auto"))
-    r
+        units(x) <- match.arg(dunits, choices = setdiff(eval(formals(difftime)$units), "auto"))
+    x
 }
 
 ## ---- additions in 2.6.0 -----

src/library/base/R/datetime.R

@@ -1379,20 +1379,17 @@ diff.POSIXt <- function (x, lag = 1L, differences = 1L, ...)
 {
     ismat <- is.matrix(x)
     r <- if(inherits(x, "POSIXlt")) as.POSIXct(x) else x
-    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) {
-        x0 <- if(ismat) x[0L, , drop = FALSE] else x[0L]
-        return(x0 - x0) # '-' |->  "difftime"
-    }
     i1 <- -seq_len(lag)
+    i0 <- integer()
     if (ismat)
         for (i in seq_len(differences))
-            r <- r[i1, , drop = FALSE] - r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
+            r <- r[i1, , drop = FALSE] -
+                r[if(lag < (len <- nrow(r))) -len:-(len - lag + 1L) else i0, , drop = FALSE]
     else
         for (i in seq_len(differences))
-             r <- r[i1] -  r[-length(r):-(length(r) - lag + 1L)]
+            r <- r[i1] -  r[if(lag < (len <- length(r))) -len:-(len - lag + 1L) else i0]
     dots <- list(...)
     if("units" %in% names(dots) && dots$units != "auto")
         units(r) <- match.arg(dots$units,  choices = setdiff(eval(formals(difftime)$units), "auto"))

src/library/base/R/diff.R

@@ -21,21 +21,19 @@ diff <- function(x, ...) UseMethod("diff")
 diff.default <- function(x, lag = 1L, differences = 1L, ...)
 {
     ismat <- is.matrix(x)
-    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( 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)
+    i0 <- integer()
     if (ismat)
 	for (i in seq_len(differences))
 	    r <- r[i1, , drop = FALSE] -
-                r[-nrow(r):-(nrow(r)-lag+1L), , drop = FALSE]
+                r[if(lag < (len <- nrow(r))) -len:-(len-lag+1L) else i0, , drop = FALSE]
     else
         for (i in seq_len(differences))
-            r <- r[i1] - r[-length(r):-(length(r)-lag+1L)]
+            r <- r[i1] - r[if(lag < (len <- length(r))) -len:-(len-lag+1L) else i0]
     class(r) <- oldClass(x)
     r
 }