Merge branch 'main' into col_select

Author: gorcha

NEWS.md

@@ -6,6 +6,11 @@
 
 * `col_select` works correctly when combined with `.name_repair` for files with
   duplicate column names (#687).
+  
+* When a string variable has a date and/or time format `read_*()` functions now
+  warn and treat the variable as a plain string instead of throwing an error
+  (#747). This should not normally occur, but has been observed in files
+  produced by 3rd party software.
 
 * `write_*()` functions now take into account the width of value labels when
   calculating string variable widths. Previously it was possible to create

R/update.R

@@ -17,6 +17,32 @@ update_readstat <- function(branch = "master") {
   fs::file_copy(fs::path(base, "LICENSE"), out_dir)
   fs::file_copy(fs::path(base, "NEWS"), out_dir)
 
+  apply_iconv_hack()
+
   invisible()
 }
+
+apply_iconv_hack <- function() {
+  path <- fs::path("src", "readstat", "readstat_iconv.h")
+  lines <- readLines(path)
+
+  # Replace the autotools ICONV_CONST fallback with platform-specific logic
+  # Also update the comment to reflect that we're manually hacking this
+  ifndef_line <- which(lines == "#ifndef ICONV_CONST")
+  comment_line <- grep("^/\\* ICONV_CONST", lines)
+
+  if (length(ifndef_line) == 1 && length(comment_line) == 1) {
+    lines <- c(
+      lines[1:(comment_line - 1)],
+      "/* ICONV_CONST defined by autotools; so we hack this in manually */",
+      "#if defined(_WIN32) || defined(__sun)",
+      "  #define ICONV_CONST const",
+      "#else",
+      "  #define ICONV_CONST",
+      "#endif",
+      lines[(ifndef_line + 3):length(lines)]
+    )
+    writeLines(lines, path)
+  }
+}
 # nocov end

src/DfReader.cpp

@@ -230,20 +230,26 @@ class DfReader {
     VarType var_type = numType(vendor_, var_format);
     // Rcout << name << ": " << var_format << " [" << var_type << "]\n";
     var_types_[var_index] = var_type;
-    switch(var_type) {
-    case HAVEN_DATE:
-      col.attr("class") = "Date";
-      break;
-    case HAVEN_TIME:
-      col.attr("class") = {"hms", "difftime"};
-      col.attr("units") = "secs";
-      break;
-    case HAVEN_DATETIME:
-      col.attr("class") = {"POSIXct", "POSIXt"};
-      col.attr("tzone") = "UTC";
-      break;
-    default:
-      break;
+    // Files have been observed in the wild with a date format applied to a string variable.
+    // This should not be possible, so we throw a warning, don't apply a class and continue.
+    if (var_type != HAVEN_DEFAULT && readstat_variable_get_type_class(variable) == READSTAT_TYPE_CLASS_STRING) {
+      Rf_warning("String variable '%s' has incompatible format '%s' and will be returned as a regular string variable.", name, var_format);
+    } else {
+      switch (var_type) {
+      case HAVEN_DATE:
+        col.attr("class") = "Date";
+        break;
+      case HAVEN_TIME:
+        col.attr("class") = {"hms", "difftime"};
+        col.attr("units") = "secs";
+        break;
+      case HAVEN_DATETIME:
+        col.attr("class") = {"POSIXct", "POSIXt"};
+        col.attr("tzone") = "UTC";
+        break;
+      default:
+        break;
+      }
     }
 
     // User defined missing values

tests/testthat/test-haven-sas.R

@@ -156,7 +156,7 @@ test_that("col_select works with .name_repair and renaming for duplicate names",
   write_xpt(df, path)
   df <- tibble::as_tibble(df, .name_repair = "universal")
 
- # This previously crashed with "attempt to set index 1/1 in SET_STRING_ELT"
+  # This previously crashed with "attempt to set index 1/1 in SET_STRING_ELT"
   res <- read_xpt(path, col_select = id...1, .name_repair = "universal")
   expect_equal(res, df[1])
 
@@ -167,6 +167,23 @@ test_that("col_select works with .name_repair and renaming for duplicate names",
   # Test renaming
   res3 <- read_xpt(path, col_select = c(a = id...3, b = id...1), .name_repair = "universal")
   expect_equal(res3, set_names(df[c(3, 1)], c("a", "b")))
+}
+
+test_that("date/times with character data throw a warning (#747)", {
+  df = data.frame(
+    id = 1:2,
+    date = structure(c("20424", "20487"), label = "Date", class = "Date")
+  ) #would not work with tibble()
+
+  path <- tempfile()
+  write_xpt(df, path)
+
+  expect_warning(
+    out <- read_xpt(path),
+    "will be returned as a regular string variable"
+  )
+
+  expect_equal(out$date, structure(c("20424", "20487"), label = "Date", format.sas = "DATE"))
 })
 
 # write_xpt ---------------------------------------------------------------