Merge pull request #71 from atorus-research/devel

Hotfixes for Hackathon
atorus-research · Feb 23, 2023 · cd4da91 · cd4da91
2 parents d1b33be + 5bd830d
commit cd4da91
Show file tree

Hide file tree

Showing 5 changed files with 46 additions and 12 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,6 @@
 # xportr 0.2.0
 * Added a new validation test that errors when users pass invalid formats (#60 #64). Thanks to @zdz2101!
+* Fixed an issue where xportr_format could pass invalid formats to haven::write_xpt.
 
 # xportr 0.1.0
 

diff --git a/R/format.R b/R/format.R
@@ -61,18 +61,27 @@ xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xpo
   } else {
     metadata <- metacore
   }
+
+  filtered_metadata <- metadata %>%
+    filter(!!sym(variable_name) %in% names(.df))
 
-    
-  format <- metadata %>%
+
+  format <- filtered_metadata %>%
     select(!!sym(format_name))  %>%
     unlist() %>%
     toupper()
-  
-  names(format) <- metadata[[variable_name]]
+
+  names(format) <- filtered_metadata[[variable_name]]
 
   for (i in names(format)) {
     attr(.df[[i]], "format.sas")  <- format[[i]]
   }
 
+  # Convert NA formats to "" for haven
+  for (i in seq_len(ncol(.df))) {
+    if (is.na(attr(.df[[i]], "format.sas")) || is.null(attr(.df[[i]], "format.sas"))) 
+      attr(.df[[i]], "format.sas") <- ""
+  }
+
   .df
 }
diff --git a/R/utils-xportr.R b/R/utils-xportr.R
@@ -221,6 +221,7 @@ xpt_validate <- function(data) {
                         '',
                         paste("$", 1:200, ".", sep = ""),
                         paste("date", 5:11, ".", sep = ""), 
+                        paste("time", 2:20, ".", sep = ""),
                         paste("datetime", 7:40, ".", sep = ""),
                         paste("yymmdd", 2:10, ".", sep = ""),
                         paste("mmddyy", 2:10, ".", sep = ""),
@@ -257,7 +258,7 @@ get_pipe_call <- function() {
 #' @noRd
 first_class <- function(x) {
   characterTypes <- getOption("xportr.character_types")
-  class_ <- class(x)[1]
+  class_ <- tolower(class(x)[1])
   if (class_ %in% characterTypes) "character"
   else class_
 }
diff --git a/R/zzz.R b/R/zzz.R
@@ -14,7 +14,7 @@
     xportr.label_verbose = "none",
     xportr.length_verbose = "none",
     xportr.type_verbose = "none",
-    xportr.character_types = c("character", "Char", "text"),
+    xportr.character_types = c("character", "char", "text", "date", "posixct", "posixt"),
     xportr.order_name = "order"
   )
   toset <- !(names(op.devtools) %in% names(op))

diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R
@@ -1,3 +1,12 @@
+
+extract_format <- function(.x) {
+  format_ <- character(length(.x))
+  for (i in 1:length(.x)) {
+    format_[i] <- attr(.x[[i]], "format.sas")
+  }
+  format_
+}
+
 test_that("Variable label", {
   df <- data.frame(x = "a", y = "b")
   varmeta <- data.frame(dataset  = rep("df", 2), 
@@ -53,15 +62,13 @@ test_that("Expect error if any label exceeds 40 character", {
                "dataset label must be 40 characters or less")
 })
 
-test_that("SAS format", {
+test_that("xportr_format will set formats as expected", {
   df <- data.frame(x = 1, y = 2)
   varmeta <- data.frame(dataset  = rep("df", 2), 
-                    variable = c("x", "y"), 
-                    format = c("date9.", "datetime20."))
+                        variable = c("x", "y"), 
+                        format = c("date9.", "datetime20."))
 
-  extract_format <- function(.x) {
-    vapply(.x, function(.x) attr(.x, "format.sas"), character(1), USE.NAMES = FALSE) 
-  }
+
 
   out <- xportr_format(df, varmeta)
 
@@ -71,6 +78,22 @@ test_that("SAS format", {
                                     row.names = c(NA, -1L), class = "data.frame"))
 })
 
+test_that("xportr_format will handle NA values and won't error", {
+  df <- data.frame(x = 1, y = 2, z = 3, a = 4)
+  varmeta <- data.frame(dataset  = rep("df", 4), 
+                    variable = c("x", "y", "z", "abc"), 
+                    format = c("date9.", "datetime20.", NA, "text"))
+
+  out <- xportr_format(df, varmeta)
+
+  expect_equal(extract_format(out), c("DATE9.", "DATETIME20.", "", ""))
+  expect_equal(dput(out), structure(list(x = structure(1, format.sas = "DATE9."),
+                                         y = structure(2, format.sas = "DATETIME20."),
+                                         z = structure(3, format.sas = ""),
+                                         a = structure(4, format.sas = "")),
+                                    row.names = c(NA, -1L), class = "data.frame"))
+})
+
 test_that("Error ", {
   df1 <- data.frame(x = 1, y = 2)
   df2 <- data.frame(x = 3, y = 4)