seq.Date() & seq.POSIXt(): from now optional; refactoring "in sync"

git-svn-id: https://svn.r-project.org/R/trunk@87502 00db46b3-68df-0310-9c12-caf00c1e9a41
r-devel · Jan 1, 2025 · faf9394 · faf9394
1 parent 10e4a08
commit faf9394
Show file tree

Hide file tree

Showing 6 changed files with 236 additions and 163 deletions.
diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd
@@ -143,6 +143,14 @@
 
       \item If \code{La_library()} is empty, \code{sessionInfo()} still
       reports \code{La_version()} when available.
+
+      \item \code{seq.Date(from, to, by, ....)} and \code{seq.POSIXt(..)}
+      now also work when \code{from} is missing and sufficient further
+      arguments are provided, thanks to \I{Michael Chirico}'s report, patch
+      proposal in \PR{17672} and \sQuote{\I{R Dev Day}} contributions.
+
+      The \code{Date} method also works for \code{seq(from, to)}, when
+      \code{by} is missing and now defaults to \code{"1 days"}.
     }
   }
 
@@ -492,17 +500,17 @@
       empty string as its \code{path} argument.
 
       \item Silent integer overflow could occur in the
-       \sQuote{exact} computations for \code{fisher.test()} for
-       unrealistic inputs: this is now an error.
+      \sQuote{exact} computations for \code{fisher.test()} for
+      unrealistic inputs: this is now an error.
 
-       \item Some invalid C-level memory accesses are avoided for
-       \code{loglin(, margin = NULL)}.
+      \item Some invalid C-level memory accesses are avoided for
+      \code{loglin(, margin = NULL)}.
 
-       \code{loglin(, param = TRUE)} no longer gives an error in corner
-       cases such as a one-dimensional input.
+      \code{loglin(, param = TRUE)} no longer gives an error in corner
+      cases such as a one-dimensional input.
 
-       \item \code{dev.capabilities() $ events} now reports \code{"Idle"} if
-       the device provides it, fixing \PR{18836}, thanks to \I{Trevor Davis}.
+      \item \code{dev.capabilities() $ events} now reports \code{"Idle"} if
+      the device provides it, fixing \PR{18836}, thanks to \I{Trevor Davis}.
      }
   }
 }

diff --git a/src/library/base/R/dates.R b/src/library/base/R/dates.R
@@ -1,7 +1,7 @@
 #  File src/library/base/R/dates.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2024 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
@@ -128,7 +128,7 @@ print.Date <- function(x, max = NULL, ...)
             length(x) - max, 'entries ]\n')
     } else if(length(x))
         print(format(x), max = max, ...)
-    else 
+    else
         cat(class(x)[1L], "of length 0\n")
     invisible(x)
 }
@@ -242,82 +242,60 @@ mean.Date <- function (x, ...)
 
 seq.Date <- function(from, to, by, length.out = NULL, along.with = NULL, ...)
 {
-    if (missing(from)) stop("'from' must be specified")
-    if (!inherits(from, "Date")) stop("'from' must be a \"Date\" object")
-        if(length(as.Date(from)) != 1L) stop("'from' must be of length 1")
-    if (!missing(to)) {
-        if (!inherits(to, "Date")) stop("'to' must be a \"Date\" object")
-        if (length(as.Date(to)) != 1L) stop("'to' must be of length 1")
-    }
     if (!missing(along.with)) {
         length.out <- length(along.with)
-    }  else if (!is.null(length.out)) {
-        if (length(length.out) != 1L) stop("'length.out' must be of length 1")
+    } else if(!is.null(length.out)) {
+        if (length(length.out) != 1L) stop(gettextf("'%s' must be of length 1", "length.out"), domain=NA)
         length.out <- ceiling(length.out)
     }
-    if (!missing(to) && missing(by)) {
-        from <- as.integer(as.Date(from))
-        to   <- as.integer(as.Date(to))
-        res <- seq.int(from, to, length.out = length.out)
+    if(missing(by)) {
+        if(((mTo <- missing(to)) & (mFr <- missing(from))))
+            stop("without 'by', at least one of 'to' and 'from' must be specified")
+        if((mTo || mFr) && is.null(length.out))
+            stop("without 'by', when one of 'to', 'from' is missing, 'length.out' / 'along.with' must be specified")
+        if(!mFr) from <- as.integer(as.Date(from))
+        if(!mTo) to   <- as.integer(as.Date(to))
+        res <- if(mFr) seq.int(to = to,  length.out = length.out)
+          else if(mTo) seq.int(from,     length.out = length.out)
+          else         seq.int(from, to, length.out = length.out)
         return(.Date(res))
     }
-    ## else
-    status <- c(!missing(to), !missing(by), !is.null(length.out))
-    if(sum(status) != 2L)
-        stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
-    if (length(by) != 1L) stop("'by' must be of length 1")
-    valid <- 0L
+    ## else 'by' is not missing
+    if (length(by) != 1L) stop(gettextf("'%s' must be of length 1", "by"), domain=NA)
+    missing_arg <- names(which(c(from = missing(from), to = missing(to),
+                                 length.out = is.null(length.out))))
+    if(length(missing_arg) != 1L)
+        stop("given 'by', exactly two of 'to', 'from' and 'length.out' / 'along.with' must be specified")
     if (inherits(by, "difftime")) {
-        by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
-                     hours = 1/24, days = 1, weeks = 7) * as.integer(by)
+        units(by) <- "days"
+        by <- as.vector(by)
     } else if(is.character(by)) {
         by2 <- strsplit(by, " ", fixed = TRUE)[[1L]]
         if(length(by2) > 2L || length(by2) < 1L)
             stop("invalid 'by' string")
         valid <- pmatch(by2[length(by2)],
                         c("days", "weeks", "months", "quarters", "years"))
         if(is.na(valid)) stop("invalid string for 'by'")
-        if(valid <= 2L) {
-            by <- c(1L, 7L)[valid]
-            if (length(by2) == 2L) by <- by * as.integer(by2[1L])
-        } else
-            by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
-    } else if(!is.numeric(by)) stop("invalid mode for 'by'")
-    if(is.na(by)) stop("'by' is NA")
-
-    if(valid <= 2L) { # days or weeks
-        from <- as.integer(as.Date(from))
-        res <- .Date(if(!is.null(length.out))
-                         seq.int(from, by = by, length.out = length.out)
-                     else # defeat test in seq.default
-                         seq.int(0L, as.integer(as.Date(to)) - from, by) + from)
-    } else {  # months or quarters or years
-        r1 <- as.POSIXlt(from)
-        if(valid == 5L) { # years
-            r1$year <-
-                if(missing(to))
-                    seq.int(r1$year, by = by, length.out = length.out)
-                else
-                    seq.int(r1$year, as.POSIXlt(to)$year, by)
-            res <- as.Date(r1)
-        } else { # months or quarters
-            if (valid == 4L) by <- by * 3L
-            r1$mon <-
-                if(missing(to))
-                    seq.int(r1$mon, by = by, length.out = length.out)
-                else {
-                    to0 <- as.POSIXlt(to)
-                    seq.int(r1$mon, 12L*(to0$year - r1$year) + to0$mon, by)
-                }
-            res <- as.Date(r1)
+        if(valid > 2L) { # seq.POSIXt handles the logic for non-arithmetic cases
+            res <- switch(missing_arg,
+              from       = seq(to   = as.POSIXlt(to),   by = by,             length.out = length.out),
+              to         = seq(from = as.POSIXlt(from), by = by,             length.out = length.out),
+              length.out = seq(from = as.POSIXlt(from), to = as.POSIXlt(to), by = by)
+            )
+            return(as.Date(res))
         }
+        by <- c(1L, 7L)[valid]
+        if (length(by2) == 2L) by <- by * as.integer(by2[1L])
     }
-    ## can overshoot
-    if (!missing(to)) {
-        to <- as.Date(to)
-        res <- if (by > 0) res[res <= to] else res[res >= to]
-    }
-    res
+    else if(!is.numeric(by)) stop("invalid mode for 'by'")
+    if(is.na(by)) stop("'by' is NA")
+
+    res <- switch(missing_arg,
+        from       = seq.int(to   = unclass(to),   by = by,          length.out = length.out),
+        to         = seq.int(from = unclass(from), by = by,          length.out = length.out),
+        length.out = seq.int(from = unclass(from), to = unclass(to), by = by)
+    )
+    .Date(res)
 }
 
 ## *very* similar to cut.POSIXt [ ./datetime.R ] -- keep in sync!
@@ -413,7 +391,7 @@ cut.Date <-
 
 julian.Date <- function(x, origin = as.Date("1970-01-01"), ...)
 {
-    if(length(origin) != 1L) stop("'origin' must be of length one")
+    if(length(origin) != 1L) stop(gettextf("'%s' must be of length 1", "origin"), domain=NA)
     structure(unclass(x) - unclass(origin), "origin" = origin)
 }
 

diff --git a/src/library/base/R/datetime.R b/src/library/base/R/datetime.R
@@ -1,7 +1,7 @@
 #  File src/library/base/R/datetime.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2024 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
@@ -340,7 +340,7 @@ as.POSIXct.default <- function(x, tz = "", ...)
 {
     if(inherits(x, "POSIXct"))
         return(if(missing(tz)) x else .POSIXct(x, tz))
-    if(is.null(x)) return(.POSIXct(numeric(), tz))
+    if(is.null(x)) return(.POSIXct(integer(), tz))
     if(is.character(x) || is.factor(x))
     return(as.POSIXct(as.POSIXlt(x, tz, ...), tz, ...))
     if(is.logical(x) && all(is.na(x)))
@@ -665,7 +665,7 @@ c.POSIXlt <- function(..., recursive = FALSE) {
 ISOdatetime <- function(year, month, day, hour, min, sec, tz = "")
 {
     if(min(lengths(list(year, month, day, hour, min, sec), use.names=FALSE)) == 0L)
-        .POSIXct(numeric(), tz = tz)
+        .POSIXct(integer(), tz = tz)
     else {
         x <- paste(year, month, day, hour, min, sec, sep = "-")
         as.POSIXct(strptime(x, "%Y-%m-%d-%H-%M-%OS", tz = tz), tz = tz)
@@ -736,9 +736,9 @@ as.difftime <- function(tim, format = "%X", units = "auto", tz = "UTC")
         nms <- names(tim)
         tim <- as.double(tim)
         names(tim) <- nms
-    if (units == "auto") stop("need explicit units for numeric conversion")
+        if (units == "auto") stop("need explicit units for numeric conversion")
         if (!(units %in% c("secs", "mins", "hours", "days", "weeks")))
-        stop("invalid units specified")
+            stop("invalid units specified")
         .difftime(tim, units = units)
     }
 }
@@ -945,39 +945,41 @@ function(x, value)
 seq.POSIXt <-
 function(from, to, by, length.out = NULL, along.with = NULL, ...)
 {
-    if (missing(from)) stop("'from' must be specified")
-    if (!inherits(from, "POSIXt")) stop("'from' must be a \"POSIXt\" object")
-    cfrom <- as.POSIXct(from)
-    if(length(cfrom) != 1L) stop("'from' must be of length 1")
-    tz <- attr(cfrom , "tzone")
-    if (!missing(to)) {
-        if (!inherits(to, "POSIXt")) stop("'to' must be a \"POSIXt\" object")
-        if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
-    }
     if (!missing(along.with)) {
         length.out <- length(along.with)
     }  else if (!is.null(length.out)) {
-        if (length(length.out) != 1L) stop("'length.out' must be of length 1")
+        if (length(length.out) != 1L) stop(gettextf("'%s' must be of length 1", "length.out"), domain=NA)
         length.out <- ceiling(length.out)
     }
-    status <- c(!missing(to), !missing(by), !is.null(length.out))
-    if(sum(status) != 2L)
-        stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
-    if (missing(by)) {
-        from <- unclass(cfrom)
-        to <- unclass(as.POSIXct(to))
-        ## Till (and incl.) 1.6.0 :
-        ##- incr <- (to - from)/length.out
-        ##- res <- seq.default(from, to, incr)
+    missing_arg <- names(which(c(from = missing(from), to = missing(to),
+                                 length.out = is.null(length.out), by = missing(by))))
+    if(length(missing_arg) != 1L)
+        stop("exactly three of 'to', 'from', 'by' and 'length.out' / 'along.with' must be specified")
+    # NB: process 'to' first so that 'tz' is overwritten to that from 'from' unless missing(from)
+    if (missing_arg != "to") {
+        if (!inherits(to, "POSIXt")) stop(gettextf("'%s' must be a \"%s\" object", "to", "POSIXt"), domain=NA)
+        if (length(to) != 1L) stop(gettextf("'%s' must be of length 1", "to"), domain=NA)
+        cto <- as.POSIXct(to)
+        tz <- attr(cto, "tzone")
+    }
+    if (missing_arg != "from") {
+        if (!inherits(from, "POSIXt")) stop(gettextf("'%s' must be a \"%s\" object", "from", "POSIXt"), domain=NA)
+        if (length(from) != 1L) stop(gettextf("'%s' must be of length 1", "from"), domain=NA)
+        cfrom <- as.POSIXct(from)
+        tz <- attr(cfrom, "tzone")
+    }
+    if (missing_arg == "by") {
+        from <- unclass(as.POSIXct(from))
+        to   <- unclass(as.POSIXct(to))
         res <- seq.int(from, to, length.out = length.out)
-        return(.POSIXct(res, tz))
+        return(.POSIXct(res, tz = attr(from, "tzone")))
     }
-
-    if (length(by) != 1L) stop("'by' must be of length 1")
+    ## else 'by' is not missing
+    if (length(by) != 1L) stop(gettextf("'%s' must be of length 1", "by"), domain=NA)
     valid <- 0L
     if (inherits(by, "difftime")) {
-        by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
-                     days = 86400, weeks = 7*86400) * unclass(by)
+        units(by) <- "secs"
+        by <- as.vector(by)
     } else if(is.character(by)) {
         by2 <- strsplit(by, " ", fixed = TRUE)[[1L]]
         if(length(by2) > 2L || length(by2) < 1L)
@@ -989,57 +991,50 @@ function(from, to, by, length.out = NULL, along.with = NULL, ...)
         if(valid <= 5L) {
             by <- c(1, 60, 3600, 86400, 7*86400)[valid]
             if (length(by2) == 2L) by <- by * as.integer(by2[1L])
-        } else
-            by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1
+        } else # months or longer
+            by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
     } else if(!is.numeric(by)) stop("invalid mode for 'by'")
     if(is.na(by)) stop("'by' is NA")
 
-    if(valid <= 5L) { # secs, mins, hours, days, weeks
-        from <- unclass(as.POSIXct(from))
-        if(!is.null(length.out))
-            res <- seq.int(from, by = by, length.out = length.out)
-        else {
-            to0 <- unclass(as.POSIXct(to))
-            ## defeat test in seq.default
-            res <- seq.int(0, to0 - from, by) + from
-        }
-        return(.POSIXct(res, tz))
-    } else {  # months or years or DSTdays or quarters
-        r1 <- as.POSIXlt(from)
-        if(valid == 7L) { # years
-            if(missing(to)) { # years
-                yr <- seq.int(r1$year, by = by, length.out = length.out)
-            } else {
-                to <- as.POSIXlt(to)
-                yr <- seq.int(r1$year, to$year, by)
-            }
-            r1$year <- yr
-        } else if(valid %in% c(6L, 9L)) { # months or quarters
-            if (valid == 9L) by <- by * 3
-            if(missing(to)) {
-                mon <- seq.int(r1$mon, by = by, length.out = length.out)
-            } else {
-                to0 <- as.POSIXlt(to)
-                mon <- seq.int(r1$mon, 12*(to0$year - r1$year) + to0$mon, by)
-            }
-            r1$mon <- mon
-        } else if(valid == 8L) { # DSTdays
-            if(!missing(to)) {
-                ## We might have a short day, so need to over-estimate.
-                length.out <- 2L + floor((unclass(as.POSIXct(to)) -
-                      unclass(as.POSIXct(from)))/(by * 86400))
-            }
-            r1$mday <- seq.int(r1$mday, by = by, length.out = length.out)
-        }
-    r1$isdst <- -1L
-    res <- as.POSIXct(r1)
-    ## now shorten if necessary.
-    if(!missing(to)) {
-        to <- as.POSIXct(to)
-        res <- if(by > 0) res[res <= to] else res[res >= to]
+    # if one of secs, mins, hours, days, or weeks
+    if(valid <= 5L) { # days or weeks
+       res <- switch(missing_arg,
+           from       = seq.int(to   = unclass(cto),   by = by,           length.out = length.out),
+           to         = seq.int(from = unclass(cfrom), by = by,           length.out = length.out),
+           length.out = seq.int(from = unclass(cfrom), to = unclass(cto), by = by)
+       )
+       return(.POSIXct(as.numeric(res), tz))
     }
-    res
+    lres <- as.POSIXlt(if (missing_arg != "from") from else to)
+    if (missing_arg == "length.out") lto <- as.POSIXlt(to)
+    if(valid == 7L) { # years
+        lres$year <- switch(missing_arg,
+          from       = seq.int(to   = lres$year, by = by, length.out = length.out),
+          to         = seq.int(from = lres$year, by = by, length.out = length.out),
+          length.out = seq.int(from = lres$year, to = lto$year, by = by)
+        )
+    } else if(valid %in% c(6L, 9L)) { # months or quarters
+        if (valid == 9L) by <- by * 3
+        lres$mon <- switch(missing_arg,
+          from       = seq.int(to   = lres$mon, by = by, length.out = length.out),
+          to         = seq.int(from = lres$mon, by = by, length.out = length.out),
+          length.out = seq.int(lres$mon, 12*(lto$year - lres$year) + lto$mon, by)
+        )
+    } else if(valid == 8L) { # DSTdays
+        lres$mday <- switch(missing_arg,
+          from       = seq.int(to   = lres$mday, by = by, length.out = length.out),
+          to         = seq.int(from = lres$mday, by = by, length.out = length.out),
+          ## We might have a short day, so need to over-estimate.
+          length.out = seq.int(lres$mday, by = by,
+                               length.out = 2L + floor((unclass(cto) - unclass(cfrom))/(by * 86400)))
+        )
     }
+    lres$isdst <- -1L
+    res <- as.POSIXct(lres)
+    if(missing_arg == "length.out") # shorten if necessary.
+        res[if(by > 0) res <= cto else res >= cto]
+    else
+        res
 }
 
 ## *very* similar to cut.Date [ ./dates.R ] -- keep in sync!
@@ -1139,7 +1134,7 @@ julian <- function(x, ...) UseMethod("julian")
 julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz = "GMT"), ...)
 {
     origin <- as.POSIXct(origin)
-    if(length(origin) != 1L) stop("'origin' must be of length one")
+    if(length(origin) != 1L) stop(gettextf("'%s' must be of length 1", "origin"), domain=NA)
     res <- difftime(as.POSIXct(x), origin, units = "days")
     structure(res, "origin" = origin)
 }