Merge branch 'r-devel:main' into r-dev-day/issue-76

Author: luciorq

doc/NEWS.Rd

@@ -368,6 +368,12 @@
       \item \code{debugonce(<S4-simple-body>, signature=*)} now works
       correctly when \dQuote{called twice}, fixing \PR{18824} thanks to
       \I{Michael Jagan}.
+
+      \item \code{format(dtime, digits=* / format=*)} is more consistent
+      when the \code{POSIXt} date-time object \code{dtime} has fractional
+      (non integer) seconds.  Fixes \PR{17350}, thanks to new contributions
+      by \I{LatinR}'s \sQuote{\I{R Dev Day}} participants, \I{Heather
+      Turner} and \I{Dirk Eddelbuettel}.
     }
   }
 }

doc/manual/Makefile.in

@@ -211,7 +211,9 @@ version.texi: Makefile $(top_srcdir)/VERSION $(SVN_REV)
 	  v="$${vv} (`sed -e 1d -e 's/^Last Changed Date: //' $(SVN_REV)`)"; \
 	  $(ECHO) "@set VERSION $${v}" >> $@; \
 	  rwv=`$(R_EXE) -f $(top_srcdir)/src/gnuwin32/fixed/rwver.R`; \
-	  $(ECHO) "@set RWVERSION $${rwv}" >> $@ )
+	  $(ECHO) "@set RWVERSION $${rwv}" >> $@; \
+	  rwtv=`$(ECHO) $${rwv} | sed -e 's/\.[^.]\+$$//'` >> $@; \
+	  $(ECHO) "@set RWTVERSION $${rwtv}" >> $@ )
 	@if test "$(R_PAPERSIZE)" = "a4"; then \
 	  $(ECHO) "@afourpaper" >> $@ ; \
 	fi

doc/manual/Makefile.win

@@ -171,7 +171,9 @@ version.texi: Makefile.win $(top_srcdir)/VERSION $(SVN_REV)
 	  v="$${vv} (`sed -e 1d -e 's/^Last Changed Date: //' $(SVN_REV)`)"; \
 	  $(ECHO) "@set VERSION $${v}" >> $@; \
 	  rwv=$(shell ../../bin$(R_ARCH)/Rscript ../../src/gnuwin32/fixed/rwver.R); \
-	  $(ECHO) "@set RWVERSION $${rwv}" >> $@ )
+	  $(ECHO) "@set RWVERSION $${rwv}" >> $@; \
+	  rwtv=`$(ECHO) $${rwv} | sed -e 's/\.[^.]\+$$//'`; \
+	  $(ECHO) "@set RWTVERSION $${rwtv}" >> $@ )
 	@if test "$(R_PAPERSIZE)" = "a4"; then \
 	  $(ECHO) "@afourpaper" >> $@ ; \
 	fi

doc/manual/R-admin.texi

@@ -1388,8 +1388,8 @@ The binary distribution of @R{} is currently built with tools
 from
 @uref{https://CRAN.R-project.org/bin/windows/Rtools/rtools44/rtools.html,Rtools44
 for Windows}. See 
-@uref{https://CRAN.R-project.org/bin/windows/base/howto-R-devel.html, Building
-R and packages} for more details on how to use it.
+@uref{https://CRAN.R-project.org/bin/windows/base/howto-@value{RWTVERSION}.html,
+Building @value{RWTVERSION} and packages on Windows} for more details on how to use it.
 
 The toolset includes compilers (currently GCC version 13.2.0 with
 selected additional patches) and runtime libraries from
@@ -2074,8 +2074,8 @@ code, and @code{install.packages(type="source")} will work for such
 packages. Those with compiled code need the tools (see @ref{The Windows
 toolset}). The tools are found automatically by @R{} when installed by
 the toolset installer. See
-@uref{https://cran.r-project.org/bin/windows/base/howto-R-devel.html,Building
-R and packages} for more details.
+@uref{https://cran.r-project.org/bin/windows/base/howto-@value{RWTVERSION}.html,
+Building @value{RWTVERSION} and packages on Windows} for more details.
 
 Occasional permission problems after unpacking source packages have been
 seen on some systems: these have been circumvented by setting the

src/library/base/R/dates.R

@@ -51,14 +51,14 @@ as.Date.character <- function(x, format,
                               optional = FALSE, ...)
 {
     charToDate <- function(x) {
-    is.na(x) <- !nzchar(x) # PR#17909
-    xx <- x[1L]
+        is.na(x) <- !nzchar(x) # PR#17909
+        xx <- x[1L]
         if(is.na(xx)) {
             j <- 1L
             while(is.na(xx) && (j <- j+1L) <= length(x)) xx <- x[j]
             if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
         }
-    if(is.na(xx))
+        if(is.na(xx))
             strptime(x, f)
         else {
             for(ff in tryFormats)
@@ -80,16 +80,16 @@ as.Date.numeric <- function(x, origin, ...)
 as.Date.default <- function(x, ...)
 {
     if(inherits(x, "Date"))
-    x
+        x
     else if(is.null(x))
         .Date(numeric())
     else if(is.logical(x) && all(is.na(x)))
-    .Date(as.numeric(x))
+        .Date(as.numeric(x))
     else
-    stop(gettextf("do not know how to convert '%s' to class %s",
-              deparse1(substitute(x)),
-              dQuote("Date")),
-         domain = NA)
+        stop(gettextf("do not know how to convert '%s' to class %s",
+                      deparse1(substitute(x)),
+                      dQuote("Date")),
+             domain = NA)
 }
 
 ## ## Moved to package date
@@ -123,13 +123,13 @@ print.Date <- function(x, max = NULL, ...)
 {
     if(is.null(max)) max <- getOption("max.print", 9999L)
     if(max < length(x)) {
-    print(format(x[seq_len(max)]), max=max+1, ...)
-    cat(" [ reached 'max' / getOption(\"max.print\") -- omitted",
-        length(x) - max, 'entries ]\n')
+        print(format(x[seq_len(max)]), max=max+1, ...)
+        cat(" [ reached 'max' / getOption(\"max.print\") -- omitted",
+            length(x) - max, 'entries ]\n')
     } else if(length(x))
-    print(format(x), max = max, ...)
-    else
-    cat(class(x)[1L], "of length 0\n")
+        print(format(x), max = max, ...)
+    else 
+        cat(class(x)[1L], "of length 0\n")
     invisible(x)
 }
 
@@ -203,7 +203,7 @@ Summary.Date <- function (..., na.rm)
     ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
     if (!ok) stop(gettextf("%s not defined for \"Date\" objects", .Generic),
                   domain = NA)
-    .Date(NextMethod(.Generic), oldClass(list(...)[[1L]]))
+    .Date(NextMethod(.Generic), oldClass(...elt(1L)))
 }
 
 `[.Date` <- function(x, ..., drop = TRUE)
@@ -329,84 +329,84 @@ cut.Date <-
     x <- as.Date(x)
 
     if (inherits(breaks, "Date")) {
-    breaks <- sort(as.Date(breaks))
+        breaks <- sort(as.Date(breaks))
     } else if(is.numeric(breaks) && length(breaks) == 1L) {
-    ## specified number of breaks
+        ## specified number of breaks
     } else if(is.character(breaks) && length(breaks) == 1L) {
-    by2 <- strsplit(breaks, " ", fixed = TRUE)[[1L]]
-    if(length(by2) > 2L || length(by2) < 1L)
-        stop("invalid specification of 'breaks'")
-    valid <-
-        pmatch(by2[length(by2)],
-           c("days", "weeks", "months", "years", "quarters"))
-    if(is.na(valid)) stop("invalid specification of 'breaks'")
-    start <- as.POSIXlt(min(x, na.rm=TRUE))
-    if(valid == 1L) incr <- 1L
-    if(valid == 2L) {       # weeks
-        start$mday <- start$mday - start$wday
-        if(start.on.monday)
-        start$mday <- start$mday + ifelse(start$wday > 0L, 1L, -6L)
+        by2 <- strsplit(breaks, " ", fixed = TRUE)[[1L]]
+        if(length(by2) > 2L || length(by2) < 1L)
+            stop("invalid specification of 'breaks'")
+        valid <-
+            pmatch(by2[length(by2)],
+                   c("days", "weeks", "months", "years", "quarters"))
+        if(is.na(valid)) stop("invalid specification of 'breaks'")
+        start <- as.POSIXlt(min(x, na.rm=TRUE))
+        if(valid == 1L) incr <- 1L
+        if(valid == 2L) {       # weeks
+            start$mday <- start$mday - start$wday
+            if(start.on.monday)
+                start$mday <- start$mday + ifelse(start$wday > 0L, 1L, -6L)
             start$isdst <- -1L
-        incr <- 7L
-    }
-    if(valid == 3L) {       # months
-        start$mday <- 1L
+            incr <- 7L
+        }
+        if(valid == 3L) {       # months
+            start$mday <- 1L
             start$isdst <- -1L
             maxx <- max(x, na.rm = TRUE)
-        end <- as.POSIXlt(maxx)
-        step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
-        end <- as.POSIXlt(end + (31 * step * 86400))
-        end$mday <- 1L
+            end <- as.POSIXlt(maxx)
+            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
+            end <- as.POSIXlt(end + (31 * step * 86400))
+            end$mday <- 1L
             end$isdst <- -1L
-        breaks <- as.Date(seq(start, end, breaks))
+            breaks <- as.Date(seq(start, end, breaks))
             ## 31 days ahead could give an empty level, so
-        lb <- length(breaks)
-        if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
-    } else if(valid == 4L) {    # years
-        start$mon <- 0L
-        start$mday <- 1L
+            lb <- length(breaks)
+            if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
+        } else if(valid == 4L) {    # years
+            start$mon <- 0L
+            start$mday <- 1L
             start$isdst <- -1L
             maxx <- max(x, na.rm = TRUE)
-        end <- as.POSIXlt(maxx)
-        step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
-        end <- as.POSIXlt(end + (366 * step * 86400))
-        end$mon <- 0L
-        end$mday <- 1L
+            end <- as.POSIXlt(maxx)
+            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
+            end <- as.POSIXlt(end + (366 * step * 86400))
+            end$mon <- 0L
+            end$mday <- 1L
             end$isdst <- -1L
-        breaks <- as.Date(seq(start, end, breaks))
+            breaks <- as.Date(seq(start, end, breaks))
             ## 366 days ahead could give an empty level, so
-        lb <- length(breaks)
-        if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
-    } else if(valid == 5L) {    # quarters
-        qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
-        start$mon <- qtr[start$mon + 1L]
-        start$mday <- 1L
+            lb <- length(breaks)
+            if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
+        } else if(valid == 5L) {    # quarters
+            qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
+            start$mon <- qtr[start$mon + 1L]
+            start$mday <- 1L
             start$isdst <- -1L
-        maxx <- max(x, na.rm = TRUE)
-        end <- as.POSIXlt(maxx)
-        step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
-        end <- as.POSIXlt(end + (93 * step * 86400))
-        end$mon <- qtr[end$mon + 1L]
-        end$mday <- 1L
+            maxx <- max(x, na.rm = TRUE)
+            end <- as.POSIXlt(maxx)
+            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
+            end <- as.POSIXlt(end + (93 * step * 86400))
+            end$mon <- qtr[end$mon + 1L]
+            end$mday <- 1L
             end$isdst <- -1L
-        breaks <- as.Date(seq(start, end, paste(step * 3L, "months")))
-        ## 93 days ahead could give an empty level, so
-        lb <- length(breaks)
-        if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
-    } else {
-        start <- as.Date(start)
-        if (length(by2) == 2L) incr <- incr * as.integer(by2[1L])
-        maxx <- max(x, na.rm = TRUE)
-        breaks <- seq(start, maxx + incr, breaks)
-        breaks <- breaks[seq_len(1L+max(which(breaks <= maxx)))]
-    }
+            breaks <- as.Date(seq(start, end, paste(step * 3L, "months")))
+            ## 93 days ahead could give an empty level, so
+            lb <- length(breaks)
+            if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
+        } else {
+            start <- as.Date(start)
+            if (length(by2) == 2L) incr <- incr * as.integer(by2[1L])
+            maxx <- max(x, na.rm = TRUE)
+            breaks <- seq(start, maxx + incr, breaks)
+            breaks <- breaks[seq_len(1L+max(which(breaks <= maxx)))]
+        }
     } else stop("invalid specification of 'breaks'")
     res <- cut(unclass(x), unclass(breaks), labels = labels,
-           right = right, ...)
+               right = right, ...)
     if(is.null(labels)) {
-    levels(res) <-
-        as.character(if (is.numeric(breaks)) x[!duplicated(res)]
-             else breaks[-length(breaks)])
+        levels(res) <-
+            as.character(if (is.numeric(breaks)) x[!duplicated(res)]
+                         else breaks[-length(breaks)])
     }
     res
 }
@@ -465,9 +465,8 @@ diff.Date <- function (x, lag = 1L, differences = 1L, ...)
             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)]
-    dots <- list(...)
-    if("units" %in% names(dots) && dots$units != "auto")
-        units(r) <- match.arg(dots$units,  choices = setdiff(eval(formals(difftime)$units), "auto"))
+    if("units" %in% ...names() && (dunits <- list(...)$units) != "auto")
+        units(r) <- match.arg(dunits, choices = setdiff(eval(formals(difftime)$units), "auto"))
     r
 }
 

src/library/base/R/datetime.R

@@ -382,18 +382,20 @@ format.POSIXlt <- function(x, format = "", usetz = FALSE,
                            digits = getOption("digits.secs"), ...)
 {
     if(!inherits(x, "POSIXlt")) stop("wrong class")
-    if(any(f0 <- format == "")) {
-        ## need list [ method here.
-    times <- unlist(unclass(x)[1L:3L])[f0]
-    secs <- x$sec[f0]; secs <- secs[is.finite(secs)]
-        np <- if(is.null(digits)) 0L else min(6L, digits)
-        if(np >= 1L) # no unnecessary trailing '0' :
-            for (i in seq_len(np)- 1L)
-                if(all( abs(secs - round(secs, i)) < 1e-6 )) {
+    if(any(f0 <- format == "" | grepl("%OS$", format))) {
+        if(!is.null(digits)) {
+            secs <- x$sec[f0]; secs <- secs[is.finite(secs)]
+            np <- min(6L, digits)
+            ## no unnecessary trailing '0' ; use trunc() as .Internal() code:
+            for(i in seq_len(np)- 1L)
+                if(all( abs(secs - trunc(secs*(ti <- 10^i))/ti) < 1e-6 )) {
                     np <- i
                     break
                 }
-    format[f0] <-
+        } else np <- 0L
+        ## need list `[` method here to get 1:3 ~ {sec, min, hour}:
+        times <- unlist(`names<-`(unclass(x)[1L:3L], NULL))[f0]
+       format[f0] <-
         if(all(times[is.finite(times)] == 0)) "%Y-%m-%d"
         else if(np == 0L) "%Y-%m-%d %H:%M:%S"
         else paste0("%Y-%m-%d %H:%M:%OS", np)

src/library/base/man/strptime.Rd

@@ -39,8 +39,11 @@ strptime(x, format, tz = "")
     methods is
     \code{"\%Y-\%m-\%d \%H:\%M:\%S"} if any element has a time
     component which is not midnight, and \code{"\%Y-\%m-\%d"}
-    otherwise.  If \code{\link{options}("digits.secs")} is set, up to
-    the specified number of digits will be printed for seconds.}
+    otherwise.  In the first case and if \code{digits} is not \code{NULL},
+    i.e., by default when \code{\link{options}("digits.secs")} is set, up to
+    the specified number of digits will be printed for seconds, using
+    \code{"\%OS<n>"} instead of \code{"\%S"} in the format, see also
+    \sQuote{Details}.}
   \item{\dots}{further arguments to be passed from or to other methods.}
   \item{usetz}{logical.  Should the time zone abbreviation be appended
     to the output?  This is used in printing times, and more reliable
@@ -235,11 +238,12 @@ strptime(x, format, tz = "")
 
   Specific to \R is \code{\%OSn}, which for output gives the seconds
   truncated to \code{0 <= n <= 6} decimal places (and if \code{\%OS} is
-  not followed by a digit, it uses the setting of
-  \code{\link{getOption}("digits.secs")}, or if that is unset, \code{n =
-  0}).  Further, for \code{strptime} \code{\%OS} will input seconds
-  including fractional seconds.  Note that \code{\%S} does not read
-  fractional parts on output.
+  not followed by a digit, it uses \code{digits} unless that is
+  \code{NULL}, when \code{n = 0}).  Note that the precedence is
+  \code{format="...\%OSn"} \eqn{\ll}{>>} \code{digits = n} \eqn{\ll}{>>}
+  \code{getOption("digits.prec")}.  Further, for \code{strptime}
+  \code{\%OS} will input seconds including fractional seconds.  Note that
+  \code{\%S} does not read fractional parts on output.
 
   The behaviour of other conversion specifications (and even if other
   character sequences commencing with \code{\%} \emph{are} conversion
@@ -307,7 +311,7 @@ strptime(x, format, tz = "")
   year.  (On some platforms this works better after conversion to
   \code{"POSIXct"}.  Some platforms only recognize hour or half-hour
   offsets for output.)%% strftime in macOS 13.
-  
+
   Using \code{\%z} for input makes most sense with \code{tz = "UTC"}.
 }
 
@@ -424,13 +428,17 @@ z2 <- strptime(x, "\%m/\%d/\%y \%H:\%M:\%S")
 ## *here* (but not in general), the same as format():
 stopifnot(identical(format(z2), as.character(z2)))
 
-## time with fractional seconds
-z3 <- strptime("20/2/06 11:16:16.683", "\%d/\%m/\%y \%H:\%M:\%OS") \donttest{
-z3 # prints without fractional seconds by default, digits.sec = NULL ("= 0")}
-op <- options(digits.secs = 3)
-\donttest{z3 # shows the 3 extra digits}
-as.character(z3) # ditto
+## time with fractional seconds (setting `tz = ..` for reproducible output)
+z3 <- strptime("20/2/06 11:16:16.683", "\%d/\%m/\%y \%H:\%M:\%OS", tz = "UTC")
+z3 # prints without fractional seconds by default, digits.sec = NULL ("= 0")
+format(z3, digits = 3) # shows extra digits
+format(z3, digits = 6) # still 3 digits: *not* showing trailing zeros
+format(z3, format = "\%Y-\%m-\%d \%H:\%M:\%OS6") #  *does* keep trailing zeros
+op <- options(digits.secs = 3) # global option, the default for `digits`
+z3 # shows the 3 extra digits
 options(op)
+as.character(z3) # ditto
+
 
 ## time zone names are not portable, but 'EST5EDT' comes pretty close.
 ## (but its interpretation may not be universal: see ?timezones)