[read] reduce date/datetime differences to releases prior 1.15 (#1336)

* [write] treat difftime as vector

* [read] reduce differences to releases < 1.15

if a date is detected in a mixed type column, return the date as character and not the unix time stamp

* [read] guard date conversions

Author: JanMarvin

R/dates.R

@@ -29,15 +29,19 @@
 #' x <- 0.50918982
 #' convert_hms(x)
 convert_date <- function(x, origin = "1900-01-01", ...) {
-  out <- date_to_unix(x, origin = origin, datetime = FALSE)
+  sel <- is_charnum(x)
+  out <- x
+  out[sel] <- date_to_unix(x[sel], origin = origin, datetime = FALSE)
   out <- as.double(out)
   .Date(out)
 }
 
 #' @rdname convert_date
 #' @export
 convert_datetime <- function(x, origin = "1900-01-01", ...) {
-  out <- date_to_unix(x, origin = origin, datetime = TRUE)
+  sel <- is_charnum(x)
+  out <- x
+  out[sel] <- date_to_unix(x[sel], origin = origin, datetime = TRUE)
   out <- as.double(out)
   tz <- ifelse(!is.null(tz <- list(...)$tz), tz, "UTC")
   .POSIXct(out, tz)

R/read.R

@@ -21,13 +21,13 @@ convert_df <- function(z, types, date_conv, datetime_conv, hms_conv, as_characte
       if (length(dtes)) z[dtes] <- lapply(z[dtes], date_conv_c)
       if (length(poxs)) z[poxs] <- lapply(z[poxs], datetime_conv_c)
       if (length(logs)) z[logs] <- lapply(z[logs], function(i) as.character(as.logical(i)))
-      if (isNamespaceLoaded("hms")) z[difs] <- lapply(z[difs], hms_conv_c)
+      if (length(difs)) z[difs] <- lapply(z[difs], hms_conv_c)
     } else {
       if (length(nums)) z[nums] <- lapply(z[nums], function(i) as.numeric(replace(i, i == "#NUM!", "NaN")))
       if (length(dtes)) z[dtes] <- lapply(z[dtes], date_conv)
       if (length(poxs)) z[poxs] <- lapply(z[poxs], datetime_conv)
       if (length(logs)) z[logs] <- lapply(z[logs], as.logical)
-      if (isNamespaceLoaded("hms")) z[difs] <- lapply(z[difs], hms_conv)
+      if (length(difs)) z[difs] <- lapply(z[difs], hms_conv)
     }
 
     for (i in seq_along(z)) { # convert df to class formula
@@ -477,11 +477,11 @@ wb_to_df <- function(
 
       if (any(uccs %in% xlsx_hms_style)) {
         sel <- cc$c_s %in% xlsx_hms_style & !cc$is_string & cc$v != ""
-        if (isNamespaceLoaded("hms")) {
+        if (convert) {
           # if hms is loaded, we have to avoid applying convert_hms() twice
           cc$val[sel] <- cc$v[sel]
         } else {
-          cc$val[sel] <- suppressWarnings(as.character(convert_hms(cc$v[sel])))
+          cc$val[sel] <- as.character(convert_hms(cc$v[sel]))
         }
         cc$typ[sel]  <- "h"
       }
@@ -713,6 +713,36 @@ wb_to_df <- function(
   # could make it optional or explicit
   if (convert) {
     z <- convert_df(z, types, date_conv, datetime_conv, hms_conv)
+
+    ## this reduces the difference to releases < 1.15. If in mixed columns
+    ## conversion to date fails and a character frame is returned, we return
+    ## a character instead of the unix time stamp as character.
+    if (detect_dates) {
+      date_conv_c     <- function(...) as.character(date_conv(...))
+      datetime_conv_c <- function(...) as.character(datetime_conv(...))
+      hms_conv_c      <- function(...) as.character(hms_conv(...))
+
+      sel <- !is.na(names(types))
+      # update only if types is character
+      chrs <- names(which(types[sel] == 0))
+
+      for (chr in chrs) {
+        sel <- tt[[chr]] == "d" & !is.na(z[[chr]])
+        if (length(sel)) {
+          z[[chr]][sel] <- vapply(z[[chr]][sel], date_conv_c, NA_character_)
+        }
+
+        sel <- tt[[chr]] == "p" & !is.na(z[[chr]])
+        if (length(sel)) {
+          z[[chr]][sel] <- vapply(z[[chr]][sel], datetime_conv_c, NA_character_)
+        }
+
+        sel <- tt[[chr]] == "h" & !is.na(z[[chr]])
+        if (length(sel)) {
+          z[[chr]][sel] <- vapply(z[[chr]][sel], hms_conv_c, NA_character_)
+        }
+      }
+    }
   }
 
   # column names were picked earlier

R/write.R

@@ -1016,7 +1016,7 @@ write_data_table <- function(
     if (transpose) x <- transpose_df(x)
   }
 
-  if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt") || inherits(x, "character")) {
+  if (is.vector(x) || is.factor(x) || inherits(x, "Date") || inherits(x, "POSIXt") || inherits(x, "difftime") || inherits(x, "character")) {
     colNames <- FALSE
   } ## this will go to coerce.default and rowNames will be ignored
 

tests/testthat/test-date_time_conversion.R

@@ -194,3 +194,59 @@ test_that("date conversion works", {
   got <- rownames(df)
   expect_equal(exp, got)
 })
+
+test_that("conversion works", {
+
+  wb <- wb_workbook()$add_worksheet()
+  # row 1 column name
+  wb$add_data(dims = "A1", x = "Var1")
+  wb$add_data(dims = "B1", x = "Var2")
+  wb$add_data(dims = "C1", x = "Var3")
+  # row 2 character
+  wb$add_data(dims = "A2", x = "2024-01-31")
+  wb$add_data(dims = "B2", x = "2024-01-31")
+  wb$add_data(dims = "C2", x = "2024-01-31")
+  # various dates
+  wb$add_data(dims = "A3", x = as.Date("2024-02-01"))
+  wb$add_data(dims = "B3", x = structure(1234, units = "secs", class = c("hms", "difftime")))
+  wb$add_data(dims = "C3", x = as.POSIXct("2024-04-25 08:47:03", tz = "UTC"))
+
+  exp <- structure(
+    list(
+      Var1 = c("2024-01-31", "2024-02-01"),
+      Var2 = c("2024-01-31", "00:20:34"),
+      Var3 = c("2024-01-31", "2024-04-25 08:47:03")
+    ), row.names = 2:3, class = "data.frame")
+  got <- wb$to_df()
+  expect_equal(exp, got)
+
+  got <- wb$to_df(convert = FALSE)
+  expect_equal(exp, got)
+
+  exp <- structure(
+    list(
+      `2024-01-31` = structure(19754, class = "Date"),
+      `2024-01-31` = "00:20:34",
+      `2024-01-31` = structure(1714034823, class = c("POSIXct", "POSIXt"), tzone = "UTC")
+    ), row.names = 3L, class = "data.frame")
+
+  got <- wb$to_df(start_row = 2)
+  expect_equal(exp, got)
+
+  exp <- structure(
+    list(
+      `2024-01-31` = "2024-02-01",
+      `2024-01-31` = "00:20:34",
+      `2024-01-31` = "2024-04-25 08:47:03"
+    ), row.names = 3L, class = "data.frame")
+  got <- wb$to_df(start_row = 2, convert = FALSE)
+  expect_equal(exp, got)
+
+  exp <- structure(c(NA, 19838), class = "Date")
+  expect_warning(got <- wb$to_df(types = c(Var3 = "Date")), "coercion")
+  expect_equal(exp, got$Var3)
+
+  exp <- structure(c(NA, 1706745600), class = c("POSIXct", "POSIXt"), tzone = "UTC")
+  expect_warning(got <- wb$to_df(types = c(Var1 = "POSIXct")), "coercion")
+  expect_equal(exp, got$Var1)
+})