Closes #142 issue_142_updated to account for DT, DTM, TM variables

R/metadata.R

@@ -21,6 +21,7 @@
 #'   dataset = "test",
 #'   variable = c("Subj", "Param", "Val", "NotUsed"),
 #'   type = c("numeric", "character", "numeric", "character"),
+#'   format = NA,
 #'   order = c(1, 3, 4, 2)
 #' )
 #'

R/type.R

@@ -21,7 +21,8 @@
 #' metadata <- data.frame(
 #'   dataset = "test",
 #'   variable = c("Subj", "Param", "Val", "NotUsed"),
-#'   type = c("numeric", "character", "numeric", "character")
+#'   type = c("numeric", "character", "numeric", "character"),
+#'   format = NA
 #' )
 #'
 #' .df <- data.frame(
@@ -51,6 +52,7 @@ xportr_type <- function(.df,
   type_name <- getOption("xportr.type_name")
   characterTypes <- c(getOption("xportr.character_types"), "_character")
   numericTypes <- c(getOption("xportr.numeric_types"), "_numeric")
+  format_name <- getOption("xportr.format_name")
 
   ## Common section to detect domain from argument or pipes
 
@@ -73,8 +75,9 @@ xportr_type <- function(.df,
     metadata <- metadata %>%
       filter(!!sym(domain_name) == domain)
   }
-  metadata <- metadata %>%
-    select(!!sym(variable_name), !!sym(type_name))
+
+  metacore <- metadata %>%
+    select(!!sym(variable_name), !!sym(type_name), !!sym(format_name))
 
   # Current class of table variables
   table_cols_types <- map(.df, first_class)
@@ -89,9 +92,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, "_numeric", type.x),
+      type.x = if_else(type.x %in% numericTypes | (grepl("DT$|DTM$|TM$", variable) & !is.na(format)),
+        "_numeric",
+        type.x
+      ),
+      type.x = if_else(grepl("DTC$", variable) & type.x == "_character", "Date", 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, "_character", 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)
     )
 
@@ -102,7 +110,6 @@ xportr_type <- function(.df,
   type_mismatch_ind <- which(meta_ordered$type.x != meta_ordered$type.y)
   type_log(meta_ordered, type_mismatch_ind, verbose)
 
-
   # Check if variable types match
   is_correct <- sapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE)
   # Use the original variable iff metadata is missing that variable
@@ -125,6 +132,5 @@ xportr_type <- function(.df,
       }
     }, is_correct
   )
-
   .df
 }

R/xportr-package.R

@@ -26,7 +26,8 @@
 globalVariables(c(
   "abbr_parsed", "abbr_stem", "adj_orig", "adj_parsed", "col_pos", "dict_varname",
   "lower_original_varname", "my_minlength", "num_st_ind", "original_varname",
-  "renamed_n", "renamed_var", "use_bundle", "viable_start", "type.x", "type.y"
+  "renamed_n", "renamed_var", "use_bundle", "viable_start", "type.x", "type.y",
+  "variable"
 ))
 
 # The following block is used by usethis to automatically manage

tests/testthat/test-depreciation.R

@@ -92,7 +92,8 @@ test_that("xportr_type: deprecated metacore argument still works and gives warni
   df_meta <- data.frame(
     dataset = "df",
     variable = c("Subj", "Param", "Val", "NotUsed"),
-    type = c("numeric", "character", "numeric", "character")
+    type = c("numeric", "character", "numeric", "character"),
+    format = NA
   )
 
   df2 <- xportr_type(df, metacore = df_meta)

tests/testthat/test-length.R

@@ -45,7 +45,7 @@ test_that("xportr_length: Accepts valid domain names in metadata object", {
 test_that("xportr_length: CDISC data frame is being piped after another xportr function", {
   adsl <- minimal_table(30)
   metadata <- minimal_metadata(
-    dataset = TRUE, length = TRUE, type = TRUE, var_names = colnames(adsl)
+    dataset = TRUE, length = TRUE, type = TRUE, format = TRUE, var_names = colnames(adsl)
   )
 
   # Setup temporary options with active verbose

tests/testthat/test-type.R

@@ -1,7 +1,8 @@
 meta_example <- data.frame(
   dataset = "df",
   variable = c("Subj", "Param", "Val", "NotUsed"),
-  type = c("numeric", "character", "numeric", "character")
+  type = c("numeric", "character", "numeric", "character"),
+  format = NA
 )
 
 df <- data.frame(
@@ -23,7 +24,8 @@ test_that("xportr_type: NAs are handled as expected", {
   meta_example <- data.frame(
     dataset = "df",
     variable = c("Subj", "Param", "Val", "NotUsed"),
-    type = c("numeric", "character", "numeric", "character")
+    type = c("numeric", "character", "numeric", "character"),
+    format = NA
   )
 
   df2 <- xportr_type(df, meta_example)
@@ -175,3 +177,31 @@ test_that("xportr_type: error when metadata is not set", {
     regexp = "Metadata must be set with `metadata` or `xportr_metadata\\(\\)`"
   )
 })
+
+test_that("xportr_type: date variables are not converted to numeric", {
+  df <- data.frame(RFICDT = as.Date("2017-03-30"), RFICDTM = as.POSIXct("2017-03-30"))
+  metacore_meta <- suppressWarnings(
+    metacore::metacore(
+      var_spec = data.frame(
+        variable = c("RFICDT", "RFICDTM"),
+        type = "integer",
+        label = c("RFICDT Label", "RFICDTM Label"),
+        length = c(1, 2),
+        common = NA_character_,
+        format = c("date9.", "datetime20.")
+      )
+    )
+  )
+  processed_df <- xportr_type(df, metacore_meta)
+  expect_equal(lapply(df, class), lapply(processed_df, class))
+  expect_equal(df$RFICDT, processed_df$RFICDT)
+  expect_equal(df$RFICDTM, processed_df$RFICDTM)
+
+  xportr_write(processed_df, file.path(system.file("extdata", package="xportr"), "dfdates.xpt"))
+  df_xpt <- read_xpt(file.path(system.file("extdata", package="xportr"), "dfdates.xpt"))
+
+  expect_equal(lapply(df, class), lapply(df_xpt, class))
+  expect_equal(df$RFICDT, df_xpt$RFICDT, ignore_attr = TRUE)
+  expect_equal(df$RFICDTM, df_xpt$RFICDTM, ignore_attr = TRUE)
+
+})