Merge pull request #16 from ropensci/factors_as_formats

Add factors_as_strings argument to sas_from_r()

Author: ryanzomorrodi

NEWS.md

@@ -1,3 +1,5 @@
+# sasquatch (development version)
+
 # sasquatch 0.1.0
 
 ## Features

R/from-r.R

@@ -8,6 +8,8 @@
 #' @param x `data.frame`; R table.
 #' @param table_name string; Name of table to be created in SAS.
 #' @param libref string; Name of libref to store SAS table within.
+#' @param factors_as_strings logical; If `TRUE`, factors will become SAS strings.
+#' Else, factors will become formatted numerics.
 #'
 #' @details
 #' SAS only has two data types (numeric and character). Data types are converted
@@ -31,43 +33,57 @@
 #' sas_connect()
 #' sas_from_r(mtcars, "mtcars")
 #' }
-sas_from_r <- function(x, table_name, libref = "WORK") {
+sas_from_r <- function(
+  x,
+  table_name,
+  libref = "WORK",
+  factors_as_strings = TRUE
+) {
   check_session()
   check_data_frame(x)
   check_has_sas_valid_datatypes(x)
   check_has_sas_valid_colnames(x)
   check_has_rownames(x)
   check_string(table_name)
   check_string(libref)
+  check_logical(factors_as_strings)
 
-  x_data <- from_r_data(x)
-  x_datetypes <- from_r_datetypes(x)
-  date_dict <- do.call(what = reticulate::dict, x_datetypes)
+  x_data <- from_r_data(x, factors_as_strings)
+  date_dict <- from_r_datedict(x)
+  factor_dict <- reticulate::dict()
+  if (!factors_as_strings) {
+    factor_dict <- from_r_factordict(x, libref)
+  }
 
   execute_if_connection_active(
     reticulate::py_capture_output(
-      .sas_from_r(x_data, table_name, libref, date_dict)
+      .sas_from_r(x_data, table_name, libref, date_dict, factor_dict)
     )
   )
 
   invisible(x)
 }
 
-.sas_from_r <- function(x, table_name, libref, date_dict) {
+.sas_from_r <- function(x, table_name, libref, date_dict, factor_dict) {
   .pkgenv$session$dataframe2sasdata(
     x,
     table_name,
     libref,
-    datetimes = date_dict
+    datetimes = date_dict,
+    outfmts = factor_dict
   )
 }
 
-from_r_data <- function(x) {
+from_r_data <- function(x, factors_as_strings) {
   numeric_cols <- vapply(x, is.integer, FUN.VALUE = logical(1)) |
     vapply(x, is.logical, FUN.VALUE = logical(1))
   x[numeric_cols] <- lapply(x[numeric_cols], as.double)
   factor_cols <- vapply(x, is.factor, FUN.VALUE = logical(1))
-  x[factor_cols] <- lapply(x[factor_cols], as.character)
+  if (factors_as_strings) {
+    x[factor_cols] <- lapply(x[factor_cols], as.character)
+  } else {
+    x[factor_cols] <- lapply(x[factor_cols], as.numeric)
+  }
   date_cols <- vapply(
     x,
     \(col) identical(class(col), "Date"),
@@ -86,7 +102,7 @@ from_r_data <- function(x) {
   x
 }
 
-from_r_datetypes <- function(x) {
+from_r_datedict <- function(x) {
   date_cols <- vapply(
     x,
     \(col) identical(class(col), "Date"),
@@ -97,7 +113,68 @@ from_r_datetypes <- function(x) {
   date_list <- as.list(rep("date", length(date_colnames)))
   names(date_list) <- date_colnames
 
-  date_list
+  do.call(reticulate::dict, date_list)
+}
+
+from_r_factordict <- function(x, libref) {
+  is_factor_col <- vapply(x, is.factor, logical(1))
+  factor_col_names <- names(x)[is_factor_col]
+
+  format_dataframe <- lapply(
+    factor_col_names,
+    function(col_name) {
+      generate_format_string(x, col_name, libref)
+    }
+  ) |>
+    do.call(what = rbind.data.frame)
+
+  format_statements <- paste0(format_dataframe$statement, collapse = "\n\n")
+
+  execute_if_connection_active(
+    reticulate::py_capture_output(
+      .sas_run_string(format_statements)
+    )
+  )
+
+  reticulate::py_dict(
+    factor_col_names,
+    paste0(format_dataframe$name, ".")
+  )
+}
+
+generate_format_string <- function(x, colname, libref) {
+  col <- x[[colname]]
+
+  proc_statement <- paste0("proc format library = ", libref, ";")
+
+  rand_string <- paste(sample(c(LETTERS, 0:9), 6), collapse = "")
+  format_name <- paste0(colname, "_", rand_string)
+  values_start <- paste0("value ", format_name)
+
+  col_levels <- levels(col)
+  format_values <- vapply(
+    seq_along(col_levels),
+    function(i) {
+      paste(i, "=", sas_quote(col_levels[i]))
+    },
+    character(1)
+  )
+
+  list(
+    name = format_name,
+    statement = paste(
+      proc_statement,
+      values_start,
+      paste(format_values, collapse = "\n"),
+      ";",
+      "run;",
+      sep = "\n"
+    )
+  )
+}
+
+sas_quote <- function(x) {
+  paste0("'", gsub("'", "''", x), "'")
 }
 
 check_has_sas_valid_datatypes <- function(x, call = rlang::caller_env()) {

man/sas_from_r.Rd

@@ -2,54 +2,54 @@
 test_that("double should not be altered", {
   x <- data.frame(a = runif(1000, min = -1, max = 1))
 
-  expect_equal(x, from_r_data(x))
+  expect_equal(x, from_r_data(x, factors_as_strings = FALSE))
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
 
-  expect_equal(from_r_data(x), x)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x)
 })
 
 test_that("integer should become a double", {
   x <- data.frame(a = sample(-1000:1000, 1000, replace = TRUE))
   x_expected <- x
   x_expected$a <- as.double(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
   x_expected <- x
   x_expected$a <- as.double(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 })
 
 test_that("logical should become a double", {
   x <- data.frame(a = sample(c(TRUE, FALSE), 1000, replace = TRUE))
   x_expected <- x
   x_expected$a <- as.double(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
   x_expected <- x
   x_expected$a <- as.double(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 })
 
 test_that("character should not be altered", {
   x <- data.frame(
     a = sample(c("apple", "pear", "orange", "cherry"), 1000, replace = TRUE)
   )
 
-  expect_equal(from_r_data(x), x)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
 
-  expect_equal(from_r_data(x), x)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x)
 })
 
-test_that("factor should become a character", {
+test_that("factor as character", {
   x <- data.frame(
     a = as.factor(sample(
       c("apple", "pear", "orange", "cherry"),
@@ -60,13 +60,33 @@ test_that("factor should become a character", {
   x_expected <- x
   x_expected$a <- as.character(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = TRUE), x_expected)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
   x_expected <- x
   x_expected$a <- as.character(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = TRUE), x_expected)
+})
+
+test_that("factor as format (numeric)", {
+  x <- data.frame(
+    a = as.factor(sample(
+      c("apple", "pear", "orange", "cherry"),
+      1000,
+      replace = TRUE
+    ))
+  )
+  x_expected <- x
+  x_expected$a <- as.numeric(x_expected$a)
+
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
+
+  x$a[sample(seq_len(nrow(x)), 100)] <- NA
+  x_expected <- x
+  x_expected$a <- as.numeric(x_expected$a)
+
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 })
 
 test_that("POSIXct should be converted to UTC", {
@@ -78,13 +98,13 @@ test_that("POSIXct should be converted to UTC", {
   x_expected <- x
   x_expected$a <- as.POSIXct(format(x_expected$a), tz = "UTC")
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
   x_expected <- x
   x_expected$a <- as.POSIXct(format(x_expected$a), tz = "UTC")
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 })
 
 test_that("date should become a POSIXct", {
@@ -94,13 +114,13 @@ test_that("date should become a POSIXct", {
   x_expected <- x
   x_expected$a <- as.POSIXct(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 
   x$a[sample(seq_len(nrow(x)), 100)] <- NA
   x_expected <- x
   x_expected$a <- as.POSIXct(x_expected$a)
 
-  expect_equal(from_r_data(x), x_expected)
+  expect_equal(from_r_data(x, factors_as_strings = FALSE), x_expected)
 })
 
 test_that("date should be added to date dict", {
@@ -114,7 +134,7 @@ test_that("date should be added to date dict", {
   )
 
   expect_equal(
-    from_r_datetypes(x),
+    reticulate::py_to_r(from_r_datedict(x)),
     date_dict_expected
   )
 })