Don't overwrite label, width, or sas.format in xportr_type()

NEWS.md

@@ -1,3 +1,6 @@
+# xportr 0.3.0
+* Fixed an issue where xportr_type would overwrite column labels, widths, and "sas.formats"
+
 # 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.

R/type.R

@@ -51,7 +51,7 @@ xportr_type <- function(.df, metacore, domain = NULL,
   if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_")
   else if (identical(df_arg, ".")) {
     attr(.df, "_xportr.df_arg_") <- get_pipe_call()
-    df_arg <- attr(.df, "_xportr.df_arg_") 
+    df_arg <- attr(.df, "_xportr.df_arg_")
   }
 
   domain <- domain %||% df_arg
@@ -70,7 +70,7 @@ xportr_type <- function(.df, metacore, domain = NULL,
 
   # Current class of table variables
   table_cols_types <- map(.df, first_class)
-  
+
   # Produces a data.frame with Variables, Type.x(Table), and Type.y(metadata)
   meta_ordered <- left_join(
     data.frame(variable = names(.df), type = unlist(table_cols_types)),
@@ -90,15 +90,18 @@ xportr_type <- function(.df, metacore, domain = NULL,
   is_correct <- sapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE)
   # Use the original variable iff metadata is missing that variable
   correct_type <- ifelse(is.na(meta_ordered[["type.y"]]), meta_ordered[["type.x"]], meta_ordered[["type.y"]])
-  
+
   # Walk along the columns and coerce the variables. Modifying the columns
   # Directly instead of something like map_dfc to preserve any attributes.
   walk2(correct_type, seq_along(correct_type),
         function(x, i, is_correct) {
           if (!is_correct[i]) {
+            orig_attributes <- attributes(.df[[i]])
+            orig_attributes$class <- NULL
             if (correct_type[i] %in% characterTypes)
               .df[[i]] <<- as.character(.df[[i]])
             else .df[[i]] <<- as.numeric(.df[[i]])
+            attributes(.df[[i]]) <<- orig_attributes
           }
         }, is_correct)
 

tests/testthat/test-type.R

@@ -30,3 +30,36 @@ test_that("variable types are coerced as expected and can raise messages", {
   expect_equal(purrr::map_chr(df4, class), c(Subj = "numeric", Different = "character",
                                       Val = "numeric", Param = "character"))})
 
+test_that("xportr_type() retains column attributes, besides class", {
+  adsl <- dplyr::tibble(
+    USUBJID = c(1001, 1002, 1003),
+    SITEID = c(001, 002, 003),
+    ADATE = readr::parse_date(c("2023-04-11", "2023-04-12", "2023-04-13")),
+    AGE = c(63, 35, 27),
+    SEX = c("M", "F", "M")
+  )
+
+  metadata <- dplyr::tibble(
+    dataset = "adsl",
+    variable = c("USUBJID", "SITEID", "ADATE", "AGE", "SEX"),
+    label = c("Unique Subject Identifier", "Study Site Identifier", "Study Dates", "Age", "Sex"),
+    type = c("character", "character", "character", "numeric", "character"),
+    length = c(10, 10, 10, 8, 10),
+    format = c(NA, NA, "DATE9.", NA, NA)
+  )
+
+  df_type_label <- adsl %>%
+    xportr_type(metadata) %>%
+    xportr_label(metadata) %>% 
+    xportr_length(metadata) %>% 
+    xportr_format(metadata)
+
+  df_label_type <- adsl %>%
+    xportr_label(metadata) %>% 
+    xportr_length(metadata) %>% 
+    xportr_format(metadata) %>%
+    xportr_type(metadata)
+
+  expect_equal(df_type_label, df_label_type)
+})
+