diff --git a/NEWS.md b/NEWS.md index effd281d..1525ffa5 100644 --- 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 index c2ee7551..89941701 100644 --- 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 } \ No newline at end of file diff --git a/R/utils-xportr.R b/R/utils-xportr.R index dbdfa145..2c39698b 100644 --- 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 index b2541120..35eca269 100644 --- 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 index eae69f54..264cc657 100644 --- 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)