Closes #161 Coercion date datatype

NEWS.md

@@ -7,6 +7,8 @@
 
 * Added a check for character variable lengths up to 200 bytes in `xpt_validate()`(#91, #189).
 
+* Added xportr.character_metadata_types and xportr.numeric_metadata_types so that all R types, including dates, are handled by xportr_type. In case the R type is different from the metadata type, the variable is coerced (#161).
+
 ## Deprecation and Breaking Changes
 
 * The `label` argument from the `xportr_write()` function is deprecated in favor of the `metadata` argument. (#179)

R/type.R

@@ -5,18 +5,14 @@
 #' 'xportr.character_types' option is used to explicitly collapse the class of a
 #' column to character using `as.character`. Similarly, 'xportr.numeric_types'
 #' will collapse a column to a numeric type. If no type is passed for a
-#' variable and it isn't identifed as a timing variable, it is assumed to be numeric and coerced with `as.numeric`.
+#' variable, it is assumed to be numeric and coerced with `as.numeric`.
 #'
 #' Certain care should be taken when using timing variables. R serializes dates
 #' based on a reference date of 01/01/1970 where XPT uses 01/01/1960. This can
 #' result in dates being 10 years off when outputting from R to XPT if you're
 #' using a date class. For this reason, `xportr` will try to determine what
 #' should happen with variables that appear to be used to denote time.
 #'
-#' For variables that end in DT, DTM, or, TM, if they are not explicitly noted
-#' in 'xportr.numeric_types' or 'xportr.character_types', they are coerced to
-#' numeric results.
-#'
 #' @inheritParams xportr_length
 #'
 #' @section Messaging: `type_log()` is the primary messaging tool for
@@ -36,24 +32,20 @@
 #'   "dataset". This is the column subset by the 'domain' argument in the
 #'   function.
 #'
-#'   2) Format Name - passed as the 'xportr.format_name' option. Default:
-#'   "format". Character values to update the 'format.sas' attribute of the
-#'   column. This is passed to `haven::write` to note the format.
-#'
-#'   3) Variable Name - passed as the 'xportr.variable_name' option. Default:
+#'   2) Variable Name - passed as the 'xportr.variable_name' option. Default:
 #'   "variable". This is used to match columns in '.df' argument and the
 #'   metadata.
 #'
-#'   4) Variable Type - passed as the 'xportr.type_name'. Default: "type". This
+#'   3) Variable Type - passed as the 'xportr.type_name'. Default: "type". This
 #'   is used to note the XPT variable "type" options are numeric or character.
 #'
-#'   5) (Option only) Character Types - The list of classes that should be
+#'   4) (Option only) Character Types - The list of classes that should be
 #'   explicitly coerced to a XPT Character type. Default: c( "character",
 #'   "char", "text", "date", "posixct", "posixt", "datetime", "time",
 #'   "partialdate", "partialtime", "partialdatetime", "incompletedatetime",
 #'   "durationdatetime", "intervaldatetime")
 #'
-#'   6) (Option only) Numeric Types - The list of classes that should be
+#'   5) (Option only) Numeric Types - The list of classes that should be
 #'   explicitly coerced to a XPT numeric type. Default: c("integer", "numeric",
 #'   "num", "float")
 #'
@@ -64,8 +56,7 @@
 #' metadata <- data.frame(
 #'   dataset = "test",
 #'   variable = c("Subj", "Param", "Val", "NotUsed"),
-#'   type = c("numeric", "character", "numeric", "character"),
-#'   format = NA
+#'   type = c("numeric", "character", "numeric", "character")
 #' )
 #'
 #' .df <- data.frame(
@@ -93,8 +84,9 @@ xportr_type <- function(.df,
   variable_name <- getOption("xportr.variable_name")
   type_name <- getOption("xportr.type_name")
   characterTypes <- c(getOption("xportr.character_types"), "_character")
+  characterMetadataTypes <- c(getOption("xportr.character_metadata_types"), "_character")
+  numericMetadataTypes <- c(getOption("xportr.numeric_metadata_types"), "_numeric")
   numericTypes <- c(getOption("xportr.numeric_types"), "_numeric")
-  format_name <- getOption("xportr.format_name")
 
   ## Common section to detect domain from argument or pipes
 
@@ -119,7 +111,7 @@ xportr_type <- function(.df,
   }
 
   metacore <- metadata %>%
-    select(!!sym(variable_name), !!sym(type_name), !!sym(format_name))
+    select(!!sym(variable_name), !!sym(type_name))
 
   # Common check for multiple variables name
   check_multiple_var_specs(metadata, variable_name)
@@ -137,14 +129,14 @@ xportr_type <- function(.df,
       # _character is used here as a mask of character, in case someone doesn't
       # want 'character' coerced to character
       type.x = if_else(type.x %in% characterTypes, "_character", type.x),
-      type.x = if_else(type.x %in% numericTypes | (grepl("DT$|DTM$|TM$", variable) & !is.na(format)),
+      type.x = if_else(type.x %in% numericTypes,
         "_numeric",
         type.x
       ),
       type.y = if_else(is.na(type.y), type.x, type.y),
       type.y = tolower(type.y),
-      type.y = if_else(type.y %in% characterTypes | (grepl("DTC$", variable) & is.na(format)), "_character", type.y),
-      type.y = if_else(type.y %in% numericTypes, "_numeric", type.y)
+      type.y = if_else(type.y %in% characterMetadataTypes, "_character", type.y),
+      type.y = if_else(type.y %in% numericMetadataTypes, "_numeric", type.y)
     )
 
   # It is possible that a variable exists in the table that isn't in the metadata

R/zzz.R

@@ -13,14 +13,16 @@
     xportr.label_verbose = "none",
     xportr.length_verbose = "none",
     xportr.type_verbose = "none",
-    xportr.character_types = c(
+    xportr.character_types = c("character"),
+    xportr.character_metadata_types = c(
       "character", "char", "text", "date", "posixct",
       "posixt", "datetime", "time", "partialdate",
       "partialtime", "partialdatetime",
       "incompletedatetime", "durationdatetime",
       "intervaldatetime"
     ),
-    xportr.numeric_types = c("integer", "numeric", "num", "float"),
+    xportr.numeric_metadata_types = c("integer", "numeric", "num", "float"),
+    xportr.numeric_types = c("integer", "float", "posixct", "posixt", "time", "date"),
     xportr.order_name = "order"
   )
   toset <- !(names(op.devtools) %in% names(op))

tests/testthat/test-length.R

@@ -198,8 +198,8 @@ test_that("xportr_length: Column length of known/unkown character types is 200/8
   expect_equal(impute_length(123), 8)
   expect_equal(impute_length(123L), 8)
   expect_equal(impute_length("string"), 200)
-  expect_equal(impute_length(Sys.Date()), 200)
-  expect_equal(impute_length(Sys.time()), 200)
+  expect_equal(impute_length(Sys.Date()), 8)
+  expect_equal(impute_length(Sys.time()), 8)
 
   withr::local_options(list(xportr.character_types = c("character", "date")))
   expect_equal(impute_length(Sys.time()), 8)

tests/testthat/test-type.R

@@ -300,3 +300,38 @@ test_that("xportr_type: Drops factor levels", {
 
   expect_null(attributes(df2$Val))
 })
+
+
+df <- data.frame(
+  STUDYID = c("PILOT01", "PILOT01", "PILOT01"),
+  USUBJID = c("01-1130", "01-1133", "01-1133"),
+  TRTEDT = c("2014-08-16", "2013-04-28", "2013-01-12")
+) %>%
+  mutate(
+    TRTEDT = as.Date(TRTEDT),
+    EXSTDTC = TRTEDT
+  )
+
+metadata <- data.frame(
+  dataset = c("df", "df", "df", "df"),
+  variable = c("STUDYID", "USUBJID", "TRTEDT", "EXSTDTC"),
+  type = c("character", "character", "numeric", "date"),
+  format = c(NA, NA, "DATE9.", NA)
+)
+
+test_that("xportr_metadata: Var date types (--DTC) coerced as expected and raise messages", {
+  # Remove empty lines in cli theme
+  local_cli_theme()
+
+  (
+    df2 <- xportr_metadata(df, metadata) %>%
+      xportr_type()
+  ) %>%
+    expect_message("Variable type mismatches found.") %>%
+    expect_message("[0-9+] variables coerced")
+
+  expect_equal(purrr::map_chr(df2, class), c(
+    STUDYID = "character", USUBJID = "character",
+    TRTEDT = "Date", EXSTDTC = "character"
+  ))
+})