Merge pull request #199 from atorus-research/151_metadata_verbose

Closes #151 - Metadata includes `verbose` option

NEWS.md

@@ -2,6 +2,12 @@
 
 ## New Features and Bug Fixes
 
+* `xportr_metadata()` can set `verbose` for a whole pipeline, i.e. setting `verbose` in `xportr_metadata()` will populate to all `xportr` functions.  (#151)
+
+* All `xportr` functions now have `verbose = NULL` as the default (#151)
+
+## Documentation
+
 * `xportr_write()` now accepts `metadata` argument which can be used to set the dataset label to stay consistent with the other `xportr_*` functions. It is noteworthy that the dataset label set using the `xportr_df_label()` function will be retained during the `xportr_write()`.
 * Exporting a new dataset `dataset_spec` that contains the Dataset Specification for ADSL. (#179)
 * Added a check for character variable lengths up to 200 bytes in `xpt_validate()`(#91, #189).

R/label.R

@@ -59,7 +59,7 @@
 xportr_label <- function(.df,
                          metadata = NULL,
                          domain = NULL,
-                         verbose = getOption("xportr.label_verbose", "none"),
+                         verbose = NULL,
                          metacore = deprecated()) {
   if (!missing(metacore)) {
     lifecycle::deprecate_stop(
@@ -76,6 +76,12 @@ xportr_label <- function(.df,
 
   metadata <- metadata %||% attr(.df, "_xportr.df_metadata_")
 
+  # Verbose should use an explicit verbose option first, then the value set in
+  # metadata, and finally fall back to the option value
+  verbose <- verbose %||%
+    attr(.df, "_xportr.df_verbose_") %||%
+    getOption("xportr.label_verbose", "none")
+
   ## End of common section
 
   assert_data_frame(.df)

R/length.R

@@ -66,7 +66,7 @@
 xportr_length <- function(.df,
                           metadata = NULL,
                           domain = NULL,
-                          verbose = getOption("xportr.length_verbose", "none"),
+                          verbose = NULL,
                           metacore = deprecated()) {
   if (!missing(metacore)) {
     lifecycle::deprecate_stop(
@@ -83,6 +83,12 @@ xportr_length <- function(.df,
 
   metadata <- metadata %||% attr(.df, "_xportr.df_metadata_")
 
+  # Verbose should use an explicit verbose option first, then the value set in
+  # metadata, and finally fall back to the option value
+  verbose <- verbose %||%
+    attr(.df, "_xportr.df_verbose_") %||%
+    getOption("xportr.length_verbose", "none")
+
   ## End of common section
 
   assert_data_frame(.df)

R/metadata.R

@@ -40,7 +40,10 @@
 #'     xportr_type() %>%
 #'     xportr_order()
 #' }
-xportr_metadata <- function(.df, metadata = NULL, domain = NULL) {
+xportr_metadata <- function(.df,
+                            metadata = NULL,
+                            domain = NULL,
+                            verbose = NULL) {
   if (is.null(metadata) && is.null(domain)) {
     stop("Assertion failed on `metadata` and `domain`: Must provide either `metadata` or `domain` argument")
   }
@@ -55,6 +58,10 @@ xportr_metadata <- function(.df, metadata = NULL, domain = NULL) {
   assert_data_frame(.df)
   assert_metadata(metadata, include_fun_message = FALSE, null.ok = TRUE)
   assert_string(domain, null.ok = TRUE)
+  assert_choice(verbose, choices = .internal_verbose_choices, null.ok = TRUE)
 
-  structure(.df, `_xportr.df_metadata_` = metadata)
+  structure(.df,
+    `_xportr.df_metadata_` = metadata,
+    `_xportr.df_verbose_` = verbose
+  )
 }

R/order.R

@@ -62,7 +62,7 @@
 xportr_order <- function(.df,
                          metadata = NULL,
                          domain = NULL,
-                         verbose = getOption("xportr.order_verbose", "none"),
+                         verbose = NULL,
                          metacore = deprecated()) {
   if (!missing(metacore)) {
     lifecycle::deprecate_stop(
@@ -79,6 +79,12 @@ xportr_order <- function(.df,
 
   metadata <- metadata %||% attr(.df, "_xportr.df_metadata_")
 
+  # Verbose should use an explicit verbose option first, then the value set in
+  # metadata, and finally fall back to the option value
+  verbose <- verbose %||%
+    attr(.df, "_xportr.df_verbose_") %||%
+    getOption("xportr.order_verbose", "none")
+
   ## End of common section
 
   assert_data_frame(.df)

R/type.R

@@ -80,7 +80,7 @@
 xportr_type <- function(.df,
                         metadata = NULL,
                         domain = NULL,
-                        verbose = getOption("xportr.type_verbose", "none"),
+                        verbose = NULL,
                         metacore = deprecated()) {
   if (!missing(metacore)) {
     lifecycle::deprecate_stop(
@@ -97,6 +97,12 @@ xportr_type <- function(.df,
 
   metadata <- metadata %||% attr(.df, "_xportr.df_metadata_")
 
+  # Verbose should use an explicit verbose option first, then the value set in
+  # metadata, and finally fall back to the option value
+  verbose <- verbose %||%
+    attr(.df, "_xportr.df_verbose_") %||%
+    getOption("xportr.type_verbose", "none")
+
   ## End of common section
 
   assert_data_frame(.df)

README.Rmd

@@ -145,7 +145,7 @@ The `xportr_metadata()` function can reduce duplication by setting the variable
 
 ```{r, message=FALSE, eval=FALSE}
 adsl %>%
-  xportr_metadata(var_spec, "ADSL") %>%
+  xportr_metadata(var_spec, "ADSL", verbose = "warn") %>%
   xportr_type() %>%
   xportr_length() %>%
   xportr_label() %>%

tests/testthat/test-metadata.R

@@ -544,6 +544,96 @@ test_that("xportr_length: Expect error if domain is not a character", {
   )
 })
 
+test_that("xportr_metadata: Impute character lengths based on class", {
+  adsl <- minimal_table(30, cols = c("x", "b"))
+  metadata <- minimal_metadata(
+    dataset = TRUE, length = TRUE, var_names = colnames(adsl)
+  ) %>%
+    mutate(length = length - 1)
+
+  adsl <- adsl %>%
+    mutate(
+      new_date = as.Date(.data$x, origin = "1970-01-01"),
+      new_char = as.character(.data$b),
+      new_num = as.numeric(.data$x)
+    )
+
+  adsl %>%
+    xportr_metadata(metadata, verbose = "none") %>%
+    xportr_length() %>%
+    expect_message("Variable lengths missing from metadata") %>%
+    expect_message("lengths resolved") %>%
+    expect_attr_width(c(7, 199, 200, 200, 8))
+})
+
+test_that("xportr_metadata: Throws message when variables not present in metadata", {
+  adsl <- minimal_table(30, cols = c("x", "y"))
+  metadata <- minimal_metadata(dataset = TRUE, length = TRUE, var_names = c("x"))
+
+  # Test that message is given which indicates that variable is not present
+  xportr_metadata(adsl, metadata, verbose = "message") %>%
+    xportr_length() %>%
+    expect_message("Variable lengths missing from metadata") %>%
+    expect_message("lengths resolved") %>%
+    expect_message(regexp = "Problem with `y`")
+})
+
+test_that("xportr_metadata: Variable ordering messaging is correct", {
+  skip_if_not_installed("haven")
+  skip_if_not_installed("readxl")
+
+  require(haven, quietly = TRUE)
+  require(readxl, quietly = TRUE)
+
+  df <- data.frame(c = 1:5, a = "a", d = 5:1, b = LETTERS[1:5])
+  df2 <- data.frame(a = "a", z = "z")
+  df_meta <- data.frame(
+    dataset = "df",
+    variable = letters[1:4],
+    order = 1:4
+  )
+
+  # Metadata versions
+  xportr_metadata(df, df_meta, verbose = "message") %>%
+    xportr_order() %>%
+    expect_message("All variables in specification file are in dataset") %>%
+    expect_condition("4 reordered in dataset") %>%
+    expect_message("Variable reordered in `.df`: `a`, `b`, `c`, and `d`")
+
+  xportr_metadata(df2, df_meta, domain = "df2", verbose = "message") %>%
+    xportr_order() %>%
+    expect_message("2 variables not in spec and moved to end") %>%
+    expect_message("Variable moved to end in `.df`: `a` and `z`") %>%
+    expect_message("All variables in dataset are ordered")
+})
+
+test_that("xportr_type: Variable types are coerced as expected and can raise messages", {
+  df <- data.frame(
+    Subj = as.character(c(123, 456, 789, "", NA, NA_integer_)),
+    Different = c("a", "b", "c", "", NA, NA_character_),
+    Val = c("1", "2", "3", "", NA, NA_character_),
+    Param = c("param1", "param2", "param3", "", NA, NA_character_)
+  )
+  meta_example <- data.frame(
+    dataset = "df",
+    variable = c("Subj", "Param", "Val", "NotUsed"),
+    type = c("numeric", "character", "numeric", "character"),
+    format = NA
+  )
+
+  # Metadata version of the last statement
+  df %>%
+    xportr_metadata(meta_example, verbose = "warn") %>%
+    xportr_type() %>%
+    expect_warning()
+
+  # Metadata version
+  df %>%
+    xportr_metadata(meta_example, verbose = "message") %>%
+    xportr_type() %>%
+    expect_message("Variable type\\(s\\) in dataframe don't match metadata")
+})
+
 # many tests here are more like qualification/domain testing - this section adds
 # tests for `xportr_metadata()` basic functionality
 # start
@@ -651,3 +741,51 @@ test_that("xportr_*: Domain is kept in between calls", {
   expect_equal(attr(df5, "_xportr.df_arg_"), "adsl")
 })
 # end
+
+test_that("`xportr_metadata()` results match traditional results", {
+  if (require(magrittr, quietly = TRUE)) {
+    test_dir <- tempdir()
+
+    trad_path <- file.path(test_dir, "adsltrad.xpt")
+    metadata_path <- file.path(test_dir, "adslmeta.xpt")
+
+    dataset_spec_low <- setNames(dataset_spec, tolower(names(dataset_spec)))
+    names(dataset_spec_low)[[2]] <- "label"
+
+    var_spec_low <- setNames(var_spec, tolower(names(var_spec)))
+    names(var_spec_low)[[5]] <- "type"
+
+    metadata_df <- adsl %>%
+      xportr_metadata(var_spec_low, "ADSL", verbose = "none") %>%
+      xportr_type() %>%
+      xportr_length() %>%
+      xportr_label() %>%
+      xportr_order() %>%
+      xportr_format() %>%
+      xportr_df_label(dataset_spec_low) %>%
+      xportr_write(metadata_path)
+
+    trad_df <- adsl %>%
+      xportr_type(var_spec_low, "ADSL", verbose = "none") %>%
+      xportr_length(var_spec_low, "ADSL", verbose = "none") %>%
+      xportr_label(var_spec_low, "ADSL", verbose = "none") %>%
+      xportr_order(var_spec_low, "ADSL", verbose = "none") %>%
+      xportr_format(var_spec_low, "ADSL") %>%
+      xportr_df_label(dataset_spec_low, "ADSL") %>%
+      xportr_write(trad_path)
+
+    expect_identical(
+      metadata_df,
+      structure(
+        trad_df,
+        `_xportr.df_metadata_` = var_spec_low,
+        `_xportr.df_verbose_` = "none"
+      )
+    )
+
+    expect_identical(
+      haven::read_xpt(metadata_path),
+      haven::read_xpt(trad_path)
+    )
+  }
+})