Merge branch 'main' into 207-length-DTC-varaible

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: xportr
 Title: Utilities to Output CDISC SDTM/ADaM XPT Files
-Version: 0.3.1.9018
+Version: 0.3.1.9019
 Authors@R: c(
     person("Eli", "Miller", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-2127-9456")),

NAMESPACE

@@ -34,6 +34,7 @@ importFrom(cli,cli_h2)
 importFrom(cli,cli_text)
 importFrom(dplyr,across)
 importFrom(dplyr,arrange)
+importFrom(dplyr,as_tibble)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,case_when)
 importFrom(dplyr,distinct)

NEWS.md

@@ -34,7 +34,6 @@ determined by the name of the data frame passed as the .df argument. This was
 done to make the use of xportr functions more explicit. (#182)
 
 * The `label` argument from the `xportr_write()` function is deprecated in favor of the `metadata` argument. (#179)
-
 * The `metacore` argument, which was renamed to `metadata` in the following six xportr functions: (`xportr_df_label()`, `xportr_format()`, `xportr_label()`, `xportr_length()`, `xportr_order()`, and `xportr_type()`) in version `0.3.0` with a soft deprecation warning, has now been hard deprecated. Please update your code to use the new `metadata` argument in place of `metacore`.
 
 * `SASlength` and `SAStype` were removed since they did not have an impact on `xpt_validate` or any other functions (#132)
@@ -47,6 +46,10 @@ done to make the use of xportr functions more explicit. (#182)
 
 * Removed non-user facing function documentation (#192)
 
+## Miscellaneous
+
+* Tests use `{withr}` to create temporary files that are automatically deleted (#219)
+
 # xportr 0.3.1
 
 ## New Features and Bug Fixes

R/support-test.R

@@ -46,9 +46,11 @@ minimal_table <- function(n_rows = 3, cols = c("x", "y")) {
       size = n_rows,
       replace = TRUE
     ),
-    d = sample(Sys.Date() + c(1, -1, 10, -10), size = n_rows, replace = TRUE)
+    d = sample(Sys.Date() + c(1, -1, 10, -10), size = n_rows, replace = TRUE),
+    e = sample(c(1, 2), replace = TRUE, size = n_rows)
   ) %>%
-    select(all_of(cols))
+    mutate(e = if_else(seq_along(e) %% 2 == 0, NA, e)) %>%
+    select(all_of(tolower(cols)))
 }
 
 #' Minimal metadata data frame mock for a ADaM dataset
@@ -122,10 +124,14 @@ local_cli_theme <- function(.local_envir = parent.frame()) {
     `.alert-success` = list(before = NULL)
   )
 
-  withr::local_options(list(cli.user_theme = cli_theme_tests), .local_envir = .local_envir)
-  withr::local_envvar(list(NO_COLOR = "yes"), .local_envir = .local_envir)
-  app <- cli::start_app(output = "message", .auto_close = FALSE)
-  withr::defer(cli::stop_app(app), envir = .local_envir)
+  # Use rlang::local_options instead of withr (Suggest package)
+  local_options(cli.user_theme = cli_theme_tests, .frame = .local_envir)
+  app <- cli::start_app(output = "message", .auto_close = FALSE, .envir = .local_envir)
+
+  if (requireNamespace("withr", quietly = TRUE)) {
+    withr::local_envvar(NO_COLOR = "yes", .frame = .local_envir)
+    withr::defer(cli::stop_app(app), envir = .local_envir)
+  }
 }
 
 #' Test if multiple vars in spec will result in warning message
@@ -147,7 +153,7 @@ multiple_vars_in_spec_helper <- function(FUN) {
     dplyr::bind_rows(metadata) %>%
     dplyr::rename(Dataset = "dataset")
 
-  withr::local_options(list(xportr.length_verbose = "message"))
+  local_options(xportr.length_verbose = "message")
   # Setup temporary options with active verbose and Remove empty lines in cli theme
   local_cli_theme()
 
@@ -175,7 +181,7 @@ multiple_vars_in_spec_helper2 <- function(FUN) {
     dplyr::bind_rows(metadata) %>%
     dplyr::rename(Dataset = "dataset")
 
-  withr::local_options(list(xportr.length_verbose = "message", xportr.domain_name = "Dataset"))
+  local_options(xportr.length_verbose = "message", xportr.domain_name = "Dataset")
   # Setup temporary options with active verbose and Remove empty lines in cli theme
   local_cli_theme()
 

R/xportr-package.R

@@ -104,7 +104,7 @@
 #' @import rlang haven
 #' @importFrom dplyr left_join bind_cols filter select rename rename_with n
 #'   everything arrange group_by summarize mutate ungroup case_when distinct
-#'   tribble if_else across
+#'   tribble if_else across as_tibble
 #' @importFrom glue glue glue_collapse
 #' @importFrom cli cli_alert_info cli_h2 cli_alert_success cli_div cli_text
 #'   cli_alert_danger

tests/testthat/test-depreciation.R

@@ -1,13 +1,13 @@
 test_that("xportr_df_label: deprecated metacore gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
   df <- data.frame(x = "a", y = "b")
   df_meta <- data.frame(dataset = "df", label = "Label")
 
   expect_error(xportr_df_label(df, metacore = df_meta))
 })
 
 test_that("xportr_format: deprecated metacore gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
   df <- data.frame(x = 1, y = 2)
   df_meta <- data.frame(
     dataset = "df",
@@ -19,7 +19,7 @@ test_that("xportr_format: deprecated metacore gives an error", {
 })
 
 test_that("xportr_label: using the deprecated metacore argument gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
 
   df <- data.frame(x = "a", y = "b")
   df_meta <- data.frame(dataset = "df", variable = "x", label = "foo")
@@ -28,7 +28,7 @@ test_that("xportr_label: using the deprecated metacore argument gives an error",
 })
 
 test_that("xportr_length: using the deprecated metacore argument gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
   df <- data.frame(x = "a", y = "b")
   df_meta <- data.frame(
     dataset = "df",
@@ -41,7 +41,7 @@ test_that("xportr_length: using the deprecated metacore argument gives an error"
 })
 
 test_that("xportr_order: using the deprecated metacore argument gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
 
   df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5])
   df_meta <- data.frame(
@@ -54,7 +54,7 @@ test_that("xportr_order: using the deprecated metacore argument gives an error",
 })
 
 test_that("xportr_type: using the deprecated metacore argument gives an error", {
-  withr::local_options(lifecycle_verbosity = "quiet")
+  local_options(lifecycle_verbosity = "quiet")
   df <- data.frame(
     Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)),
     Different = c("a", "b", "c", "", NA, NA_character_),

tests/testthat/test-df_label.R

@@ -1,11 +1,5 @@
 test_that("xportr_df_label: error when metadata is not set", {
-  adsl <- data.frame(
-    USUBJID = c(1001, 1002, 1003),
-    SITEID = c(001, 002, 003),
-    AGE = c(63, 35, 27),
-    SEX = c("M", "F", "M")
-  )
-
+  adsl <- minimal_table()
 
   expect_error(
     xportr_df_label(adsl),

tests/testthat/test-length.R

@@ -10,7 +10,7 @@ test_that("xportr_length: Accepts valid domain names in metadata object", {
   metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = colnames(adsl))
 
   # Setup temporary options with active verbose
-  withr::local_options(list(xportr.length_verbose = "message"))
+  local_options(xportr.length_verbose = "message")
 
   # Test minimal call with valid data and without domain
   adsl %>%
@@ -50,7 +50,7 @@ test_that("xportr_length: CDISC data frame is being piped after another xportr f
   )
 
   # Setup temporary options with active verbose
-  withr::local_options(list(xportr.length_verbose = "message"))
+  local_options(xportr.length_verbose = "message")
 
   adsl %>%
     xportr_type(metadata, domain = "adsl", verbose = "message") %>%
@@ -69,9 +69,9 @@ test_that("xportr_length: Impute character lengths based on class", {
     mutate(length = length - 1)
 
   # Setup temporary options with `verbose = "none"`
-  withr::local_options(list(xportr.length_verbose = "none"))
+  local_options(xportr.length_verbose = "none")
   # Define controlled `character_types` for this test
-  withr::local_options(list(xportr.character_types = c("character", "date")))
+  local_options(xportr.character_types = c("character", "date"))
 
   # Remove empty lines in cli theme
   local_cli_theme()
@@ -104,7 +104,7 @@ test_that("xportr_length: Throws message when variables not present in metadata"
   metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = c("x"))
 
   # Setup temporary options with `verbose = "message"`
-  withr::local_options(list(xportr.length_verbose = "message"))
+  local_options(xportr.length_verbose = "message")
   # Remove empty lines in cli theme
   local_cli_theme()
 
@@ -163,6 +163,17 @@ test_that("xportr_length: Domain not in character format", {
   )
 })
 
+test_that("xportr_length: Column length of known/unkown character types is 200/8 ", {
+  expect_equal(impute_length(123), 8)
+  expect_equal(impute_length(123L), 8)
+  expect_equal(impute_length("string"), 200)
+  expect_equal(impute_length(Sys.Date()), 8)
+  expect_equal(impute_length(Sys.time()), 8)
+
+  local_options(xportr.character_types = c("character", "date"))
+  expect_equal(impute_length(Sys.time()), 8)
+})
+
 test_that("xportr_length: error when metadata is not set", {
   adsl <- minimal_table(30)
 

tests/testthat/test-metadata.R

@@ -722,7 +722,9 @@ test_that("xportr_*: Domain is kept in between calls", {
   # Divert all messages to tempfile, instead of printing them
   #  note: be aware as this should only be used in tests that don't track
   #        messages
-  withr::local_message_sink(tempfile())
+  if (requireNamespace("withr", quietly = TRUE)) {
+    withr::local_message_sink(withr::local_tempfile())
+  }
 
   adsl <- minimal_table(30)
 

tests/testthat/test-pkg-load.R

@@ -1,21 +1,21 @@
 test_that(".onLoad: Unset options get initialised on package load with defaults", {
   skip_if(getOption("testthat_interactive"))
-  withr::with_options(
-    list(xportr.df_domain_name = NULL),
+  with_options(
     {
       expect_no_error(.onLoad())
       expect_equal(getOption("xportr.df_domain_name"), "dataset")
-    }
+    },
+    xportr.df_domain_name = NULL
   )
 })
 
 test_that(".onLoad: Initialised options are retained and not overwritten", {
   skip_if(getOption("testthat_interactive"))
-  withr::with_options(
-    list(xportr.df_domain_name = "custom_domain"),
+  with_options(
     {
       expect_no_error(.onLoad())
       expect_equal(getOption("xportr.df_domain_name"), "custom_domain")
-    }
+    },
+    xportr.df_domain_name = "custom_domain"
   )
 })

tests/testthat/test-type.R

@@ -107,7 +107,9 @@ test_that("xportr_type: Variables retain column attributes, besides class", {
   # Divert all messages to tempfile, instead of printing them
   #  note: be aware as this should only be used in tests that don't track
   #        messages
-  withr::local_message_sink(tempfile())
+  if (requireNamespace("withr", quietly = TRUE)) {
+    withr::local_message_sink(withr::local_tempfile())
+  }
 
   df_type_label <- adsl %>%
     xportr_metadata(domain = "adsl") %>%