more thorough fixing format.POSIXlt() for fractional secs

git-svn-id: https://svn.r-project.org/R/trunk@87419 00db46b3-68df-0310-9c12-caf00c1e9a41
r-devel · Dec 4, 2024 · 2bdd816 · 2bdd816
1 parent 76b51d9
commit 2bdd816
Show file tree

Hide file tree

Showing 4 changed files with 181 additions and 20 deletions.
diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd
@@ -398,17 +398,15 @@
       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}.
+      Turner} and \I{Dirk Eddelbuettel}; also fixes more cases, notably
+      when \code{format} contains "%OS<nodigit>".
 
       \item \code{options(scipen = NULL)} and other invalid values now
       signal an error instead of invalidating ops relying on a finite
       integer value.  Newly values outside the range -9 .. 9999 are warned
       about and set to a respective boundary or to the default \code{0},
       e.g., in case of an \code{NA}.
 
-      \item \code{isGeneric(fdef = print)} now works, fixing \PR{18369}
-      thanks to \I{Mikael Jagan}.
-
       \item \code{cbind()} could segfault with \code{NULL} inputs.
       (Seen when \R was built with \command{gcc14}, \abbr{LTO} and C99 inlining
       semantics.)
@@ -464,6 +462,9 @@
       \item \code{isGeneric(<primitive>, fdef=*, getName=TRUE)} now also
       returns the name instead of just \code{TRUE}, fixing \PR{18829}
       reported by \I{Mikael Jagan}.
+
+      \item \code{isGeneric(fdef = print)} now works, fixing \PR{18369}
+      thanks to \I{Mikael Jagan}.
     }
   }
 }

diff --git a/src/library/base/R/datetime.R b/src/library/base/R/datetime.R
@@ -382,24 +382,35 @@ format.POSIXlt <- function(x, format = "", usetz = FALSE,
                            digits = getOption("digits.secs"), ...)
 {
     if(!inherits(x, "POSIXlt")) stop("wrong class")
-    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)
+    nf <- length(format)
+    useDig <- function(secs, digits) {
+        secs <- secs[is.finite(secs)]
+        np <- min(6L, digits)
+        if(np >= 1L) # 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
                 }
-        } else np <- 0L
-        ## need list `[` method here to get 1:3 ~ {sec, min, hour}:
-        times <- unlist(unclass(x)[1L:3L], use.names=FALSE)[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)
+        np
     }
+    if(any(f0 <- format == "")) {
+        x_ <- if(nf == 1L) x else x[f0]  # any(f0) & nf = 1  ==>  x[f0] = x
+        np <- if(!is.null(digits)) useDig(x_$sec, digits) else 0L
+        ## need list `[` method here to get 1:3 ~ {sec, min, hour} :
+        times <- unlist(unclass(x_)[1L:3L], use.names = FALSE)
+        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)
+    }
+    if(!missing(digits) && !is.null(digits) && digits != getOption("digits.secs", 0L) &&
+       any(OS. <- grepl("%OS[^0-9]", format))) { ## use digits to find n to use for "%OS<n>"
+        x_ <- if(nf == 1L) x else x[OS.]
+        np <- useDig(x_$sec, digits)
+        format[OS.] <- gsub("%OS([^0-9])", paste0("%OS", np, "\\1"), format[OS.])
+    }
+    ## C code in do_formatPOSIXlt()  *does*  recycle  {x, format}  as needed:
     .Internal(format.POSIXlt(x, format, usetz))
 }
 

diff --git a/tests/datetime5.R b/tests/datetime5.R
@@ -1,4 +1,4 @@
-### tests of strftime (formatting POSIXlt objects).
+### tests of strftime (formatting POSIXlt objects via format.POSIXlt)
 
 Sys.setenv(TZ = "Europe/Rome")
 
@@ -27,3 +27,15 @@ for (f in c("P", "k", "l", "s")) {
 ## week numbers
 dt2 <- as.POSIXlt(sprintf("%d-01-01 09:03;04", 2015:2018))
 cat(format(dt2, "%Y: %U %V %W"), sep = "\n")
+
+## recycling *both* {x, format} "heavily"; digits = <n> must influence %OS<empty>; PR#17350
+(fmt <- c("", paste0("%H:%M:%OS", c("", 2), " in %Y"),                  # || nasty (but "correct")
+          paste0("%Y-%m-%d", c("", paste0(" %H:%M:%OS", c("", 0, 1, 6, 9, 11))))))
+weekD <- seq(as.Date("2020-04-01"), by = "weeks", length.out = 5 * length(fmt)) ; joff <- (0:4)*length(fmt)
+weekPlt <- as.POSIXlt(weekD, tz = "UTC")
+(Lf1 <- split(f1 <- format(weekPlt,        format = fmt),             fmt))
+(Lf. <- split(f. <- format(weekPlt + 0.25, format = fmt),             fmt))
+(Lf3 <- split(f3 <- format(weekPlt + 0.25, format = fmt, digits = 3), fmt))
+stopifnot(f3[2L+joff] == f3[3L+joff],
+          grepl("^00:00:00.25 in 202[01]", f3[2L+joff]))
+## digits = 3 had no effect on "%OS "
diff --git a/tests/datetime5.Rout.save b/tests/datetime5.Rout.save
@@ -1,5 +1,5 @@
 
-R Under development (unstable) (2024-03-19 r86151) -- "Unsuffered Consequences"
+R Under development (unstable) (2024-12-03 r87418) -- "Unsuffered Consequences"
 Copyright (C) 2024 The R Foundation for Statistical Computing
 Platform: x86_64-pc-linux-gnu
 
@@ -15,7 +15,7 @@ Type 'demo()' for some demos, 'help()' for on-line help, or
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-> ### tests of strftime (formatting POSIXlt objects).
+> ### tests of strftime (formatting POSIXlt objects via format.POSIXlt)
 > 
 > Sys.setenv(TZ = "Europe/Rome")
 > 
@@ -89,4 +89,141 @@ Type 'q()' to quit R.
 2017: 01 52 00
 2018: 00 01 01
 > 
+> ## recycling *both* {x, format} "heavily"; digits = <n> must influence %OS<empty>; PR#17350
+> (fmt <- c("", paste0("%H:%M:%OS", c("", 2), " in %Y"),                  # || nasty (but "correct")
++           paste0("%Y-%m-%d", c("", paste0(" %H:%M:%OS", c("", 0, 1, 6, 9, 11))))))
+ [1] ""                     "%H:%M:%OS in %Y"      "%H:%M:%OS2 in %Y"    
+ [4] "%Y-%m-%d"             "%Y-%m-%d %H:%M:%OS"   "%Y-%m-%d %H:%M:%OS0" 
+ [7] "%Y-%m-%d %H:%M:%OS1"  "%Y-%m-%d %H:%M:%OS6"  "%Y-%m-%d %H:%M:%OS9" 
+[10] "%Y-%m-%d %H:%M:%OS11"
+> weekD <- seq(as.Date("2020-04-01"), by = "weeks", length.out = 5 * length(fmt)) ; joff <- (0:4)*length(fmt)
+> weekPlt <- as.POSIXlt(weekD, tz = "UTC")
+> (Lf1 <- split(f1 <- format(weekPlt,        format = fmt),             fmt))
+[[1]]
+[1] "2020-04-01" "2020-06-10" "2020-08-19" "2020-10-28" "2021-01-06"
+
+$`%H:%M:%OS in %Y`
+[1] "00:00:00 in 2020" "00:00:00 in 2020" "00:00:00 in 2020" "00:00:00 in 2020"
+[5] "00:00:00 in 2021"
+
+$`%H:%M:%OS2 in %Y`
+[1] "00:00:00.00 in 2020" "00:00:00.00 in 2020" "00:00:00.00 in 2020"
+[4] "00:00:00.00 in 2020" "00:00:00.00 in 2021"
+
+$`%Y-%m-%d`
+[1] "2020-04-22" "2020-07-01" "2020-09-09" "2020-11-18" "2021-01-27"
+
+$`%Y-%m-%d %H:%M:%OS`
+[1] "2020-04-29 00:00:00" "2020-07-08 00:00:00" "2020-09-16 00:00:00"
+[4] "2020-11-25 00:00:00" "2021-02-03 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS0`
+[1] "2020-05-06 00:00:00" "2020-07-15 00:00:00" "2020-09-23 00:00:00"
+[4] "2020-12-02 00:00:00" "2021-02-10 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS1`
+[1] "2020-05-13 00:00:00.0" "2020-07-22 00:00:00.0" "2020-09-30 00:00:00.0"
+[4] "2020-12-09 00:00:00.0" "2021-02-17 00:00:00.0"
+
+$`%Y-%m-%d %H:%M:%OS11`
+[1] "2020-06-03 00:00:00.01" "2020-08-12 00:00:00.01" "2020-10-21 00:00:00.01"
+[4] "2020-12-30 00:00:00.01" "2021-03-10 00:00:00.01"
+
+$`%Y-%m-%d %H:%M:%OS6`
+[1] "2020-05-20 00:00:00.000000" "2020-07-29 00:00:00.000000"
+[3] "2020-10-07 00:00:00.000000" "2020-12-16 00:00:00.000000"
+[5] "2021-02-24 00:00:00.000000"
+
+$`%Y-%m-%d %H:%M:%OS9`
+[1] "2020-05-27 00:00:00.000000" "2020-08-05 00:00:00.000000"
+[3] "2020-10-14 00:00:00.000000" "2020-12-23 00:00:00.000000"
+[5] "2021-03-03 00:00:00.000000"
+
+> (Lf. <- split(f. <- format(weekPlt + 0.25, format = fmt),             fmt))
+[[1]]
+[1] "2020-04-01 00:00:00" "2020-06-10 00:00:00" "2020-08-19 00:00:00"
+[4] "2020-10-28 00:00:00" "2021-01-06 00:00:00"
+
+$`%H:%M:%OS in %Y`
+[1] "00:00:00 in 2020" "00:00:00 in 2020" "00:00:00 in 2020" "00:00:00 in 2020"
+[5] "00:00:00 in 2021"
+
+$`%H:%M:%OS2 in %Y`
+[1] "00:00:00.25 in 2020" "00:00:00.25 in 2020" "00:00:00.25 in 2020"
+[4] "00:00:00.25 in 2020" "00:00:00.25 in 2021"
+
+$`%Y-%m-%d`
+[1] "2020-04-22" "2020-07-01" "2020-09-09" "2020-11-18" "2021-01-27"
+
+$`%Y-%m-%d %H:%M:%OS`
+[1] "2020-04-29 00:00:00" "2020-07-08 00:00:00" "2020-09-16 00:00:00"
+[4] "2020-11-25 00:00:00" "2021-02-03 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS0`
+[1] "2020-05-06 00:00:00" "2020-07-15 00:00:00" "2020-09-23 00:00:00"
+[4] "2020-12-02 00:00:00" "2021-02-10 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS1`
+[1] "2020-05-13 00:00:00.2" "2020-07-22 00:00:00.2" "2020-09-30 00:00:00.2"
+[4] "2020-12-09 00:00:00.2" "2021-02-17 00:00:00.2"
+
+$`%Y-%m-%d %H:%M:%OS11`
+[1] "2020-06-03 00:00:00.21" "2020-08-12 00:00:00.21" "2020-10-21 00:00:00.21"
+[4] "2020-12-30 00:00:00.21" "2021-03-10 00:00:00.21"
+
+$`%Y-%m-%d %H:%M:%OS6`
+[1] "2020-05-20 00:00:00.250000" "2020-07-29 00:00:00.250000"
+[3] "2020-10-07 00:00:00.250000" "2020-12-16 00:00:00.250000"
+[5] "2021-02-24 00:00:00.250000"
+
+$`%Y-%m-%d %H:%M:%OS9`
+[1] "2020-05-27 00:00:00.250000" "2020-08-05 00:00:00.250000"
+[3] "2020-10-14 00:00:00.250000" "2020-12-23 00:00:00.250000"
+[5] "2021-03-03 00:00:00.250000"
+
+> (Lf3 <- split(f3 <- format(weekPlt + 0.25, format = fmt, digits = 3), fmt))
+[[1]]
+[1] "2020-04-01 00:00:00.25" "2020-06-10 00:00:00.25" "2020-08-19 00:00:00.25"
+[4] "2020-10-28 00:00:00.25" "2021-01-06 00:00:00.25"
+
+$`%H:%M:%OS in %Y`
+[1] "00:00:00.25 in 2020" "00:00:00.25 in 2020" "00:00:00.25 in 2020"
+[4] "00:00:00.25 in 2020" "00:00:00.25 in 2021"
+
+$`%H:%M:%OS2 in %Y`
+[1] "00:00:00.25 in 2020" "00:00:00.25 in 2020" "00:00:00.25 in 2020"
+[4] "00:00:00.25 in 2020" "00:00:00.25 in 2021"
+
+$`%Y-%m-%d`
+[1] "2020-04-22" "2020-07-01" "2020-09-09" "2020-11-18" "2021-01-27"
+
+$`%Y-%m-%d %H:%M:%OS`
+[1] "2020-04-29 00:00:00" "2020-07-08 00:00:00" "2020-09-16 00:00:00"
+[4] "2020-11-25 00:00:00" "2021-02-03 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS0`
+[1] "2020-05-06 00:00:00" "2020-07-15 00:00:00" "2020-09-23 00:00:00"
+[4] "2020-12-02 00:00:00" "2021-02-10 00:00:00"
+
+$`%Y-%m-%d %H:%M:%OS1`
+[1] "2020-05-13 00:00:00.2" "2020-07-22 00:00:00.2" "2020-09-30 00:00:00.2"
+[4] "2020-12-09 00:00:00.2" "2021-02-17 00:00:00.2"
+
+$`%Y-%m-%d %H:%M:%OS11`
+[1] "2020-06-03 00:00:00.21" "2020-08-12 00:00:00.21" "2020-10-21 00:00:00.21"
+[4] "2020-12-30 00:00:00.21" "2021-03-10 00:00:00.21"
+
+$`%Y-%m-%d %H:%M:%OS6`
+[1] "2020-05-20 00:00:00.250000" "2020-07-29 00:00:00.250000"
+[3] "2020-10-07 00:00:00.250000" "2020-12-16 00:00:00.250000"
+[5] "2021-02-24 00:00:00.250000"
+
+$`%Y-%m-%d %H:%M:%OS9`
+[1] "2020-05-27 00:00:00.250000" "2020-08-05 00:00:00.250000"
+[3] "2020-10-14 00:00:00.250000" "2020-12-23 00:00:00.250000"
+[5] "2021-03-03 00:00:00.250000"
+
+> stopifnot(f3[2L+joff] == f3[3L+joff],
++           grepl("^00:00:00.25 in 202[01]", f3[2L+joff]))
+> ## digits = 3 had no effect on "%OS "
 >