merge main into branch

Author: jeffreyad

R/build.R

@@ -41,7 +41,12 @@
 #'                            VS.VSTESTCD == 'Heart Rate'" contains both
 #'                            VS.VSTESTCD and VS.VSSTRESN as prerequisites, and
 #'                            these columns will be kept through to the ADaM.
-#'
+#' @param verbose Character string controlling message verbosity. One of:
+#'   \describe{
+#'     \item{`"message"`}{Show both warnings and messages (default)}
+#'     \item{`"warn"`}{Show warnings but suppress messages}
+#'     \item{`"silent"`}{Suppress all warnings and messages}
+#'   }
 #'
 #' @return dataset
 #' @export
@@ -55,7 +60,8 @@
 #' ds_list <- list(DM = read_xpt(metatools_example("dm.xpt")))
 #' build_from_derived(spec, ds_list, predecessor_only = FALSE)
 build_from_derived <- function(metacore, ds_list, dataset_name = deprecated(),
-                               predecessor_only = TRUE, keep = FALSE) {
+                               predecessor_only = TRUE, keep = FALSE,
+                               verbose = c("message", "warn", "silent")) {
   if (is_present(dataset_name)) {
     lifecycle::deprecate_warn(
       when = "0.2.0",
@@ -68,6 +74,8 @@ build_from_derived <- function(metacore, ds_list, dataset_name = deprecated(),
   }
   verify_DatasetMeta(metacore)
 
+  verbose <- validate_verbose(verbose)
+
   # Deprecate KEEP = TRUE
   keep <- match.arg(as.character(keep), c("TRUE", "FALSE", "ALL", "PREREQUISITE"))
   if (keep == "TRUE") {
@@ -114,7 +122,7 @@ build_from_derived <- function(metacore, ds_list, dataset_name = deprecated(),
     str_to_lower()
   if (!all(ds_names %in% names(ds_list))) {
     unknown <- keep(names(ds_list), ~ !. %in% ds_names)
-    if (length(unknown) > 0) {
+    if (length(unknown) > 0 && check_warn(verbose)) {
       warning(paste0("The following dataset(s) have no predecessors and will be ignored:\n"),
         paste0(unknown, collapse = ", "),
         call. = FALSE
@@ -124,11 +132,13 @@ build_from_derived <- function(metacore, ds_list, dataset_name = deprecated(),
       str_to_upper() %>%
       paste0(collapse = ", ")
 
-    message(paste0(
-      "Not all datasets provided. Only variables from ",
-      ds_using,
-      " will be gathered."
-    ))
+    if (check_message(verbose)) {
+      message(paste0(
+        "Not all datasets provided. Only variables from ",
+        ds_using,
+        " will be gathered."
+      ))
+    }
 
     # Filter out any variable that come from datasets that aren't present
     vars_w_ds <- vars_w_ds %>%
@@ -162,7 +172,7 @@ build_from_derived <- function(metacore, ds_list, dataset_name = deprecated(),
     group_by(ds) %>%
     group_split() %>%
     map(get_variables, ds_list, keep, derirvations) %>%
-    prepare_join(join_by, names(ds_list)) %>%
+    prepare_join(join_by, names(ds_list), verbose) %>%
     reduce(full_join, by = join_by)
 }
 
@@ -232,10 +242,12 @@ get_variables <- function(x, ds_list, keep, derivations) {
 #'
 #' @param x List of datasets with all columns added
 #' @param keys List of key values to join on
+#' @param ds_names Names of datasets
+#' @param verbose Verbosity level
 #'
 #' @return datasets
 #' @noRd
-prepare_join <- function(x, keys, ds_names) {
+prepare_join <- function(x, keys, ds_names, verbose = "message") {
   out <- list(x[[1]])
 
   if (length(x) > 1) {
@@ -248,8 +260,8 @@ prepare_join <- function(x, keys, ds_names) {
           intersect(colnames(x[[i]]))
         drop_cols <- c(drop_cols, conflicting_cols)
 
-        if (length(conflicting_cols) > 0) {
-          cli_inform(c("i" = "Dropping column(s) from {ds_names[[i]]} due to \\
+        if (length(conflicting_cols) > 0 && check_message(verbose)) {
+          cli_inform(c("i" = "Dropping column(s) from {ds_names[[i]]} due to \
                             conflict with {ds_names[[j]]}: {conflicting_cols}."))
         }
       }
@@ -273,6 +285,12 @@ prepare_join <- function(x, keys, ds_names) {
 #' Note: Deprecated in version 0.2.0. The `dataset_name` argument will be removed
 #' in a future release. Please use `metacore::select_dataset` to subset the
 #' `metacore` object to obtain metadata for a single dataset.
+#' @param verbose Character string controlling message verbosity. One of:
+#'   \describe{
+#'     \item{`"message"`}{Show both warnings and messages (default)}
+#'     \item{`"warn"`}{Show warnings but suppress messages}
+#'     \item{`"silent"`}{Suppress all warnings and messages}
+#'   }
 #'
 #' @return Dataset with only specified columns
 #' @export
@@ -287,7 +305,8 @@ prepare_join <- function(x, keys, ds_names) {
 #'   select(USUBJID, SITEID) %>%
 #'   mutate(foo = "Hello")
 #' drop_unspec_vars(data, spec)
-drop_unspec_vars <- function(dataset, metacore, dataset_name = deprecated()) {
+drop_unspec_vars <- function(dataset, metacore, dataset_name = deprecated(),
+                             verbose = c("message", "warn", "silent")) {
   if (is_present(dataset_name)) {
     lifecycle::deprecate_warn(
       when = "0.2.0",
@@ -299,6 +318,8 @@ drop_unspec_vars <- function(dataset, metacore, dataset_name = deprecated()) {
     metacore <- make_lone_dataset(metacore, dataset_name)
   }
 
+  verbose <- validate_verbose(verbose)
+
   verify_DatasetMeta(metacore)
   var_list <- metacore$ds_vars %>%
     filter(is.na(supp_flag) | !(supp_flag)) %>%
@@ -308,10 +329,12 @@ drop_unspec_vars <- function(dataset, metacore, dataset_name = deprecated()) {
   if (length(to_drop) > 0) {
     out <- dataset %>%
       select(-all_of(to_drop))
-    message(paste0(
-      "The following variable(s) were dropped:\n  ",
-      paste0(to_drop, collapse = "\n  ")
-    ))
+    if (check_message(verbose)) {
+      message(paste0(
+        "The following variable(s) were dropped:\n  ",
+        paste0(to_drop, collapse = "\n  ")
+      ))
+    }
   } else {
     out <- dataset
   }

R/labels.R

@@ -75,6 +75,12 @@ remove_labels <- function(data) {
 #'   Note: Deprecated in version 0.2.0. The `dataset_name` argument will be removed
 #'   in a future release. Please use `metacore::select_dataset` to subset the
 #'   `metacore` object to obtain metadata for a single dataset.
+#' @param verbose Character string controlling message verbosity. One of:
+#'   \describe{
+#'     \item{`"message"`}{Show both warnings and messages (default)}
+#'     \item{`"warn"`}{Show warnings but suppress messages}
+#'     \item{`"silent"`}{Suppress all warnings and messages}
+#'   }
 #'
 #' @return Dataframe with labels applied
 #' @export
@@ -87,7 +93,8 @@ remove_labels <- function(data) {
 #' )
 #' dm <- haven::read_xpt(metatools_example("dm.xpt"))
 #' set_variable_labels(dm, mc, dataset_name = "DM")
-set_variable_labels <- function(data, metacore, dataset_name = deprecated()) {
+set_variable_labels <- function(data, metacore, dataset_name = deprecated(),
+                                verbose = c("message", "warn", "silent")) {
   if (is_present(dataset_name)) {
     lifecycle::deprecate_warn(
       when = "0.2.0",
@@ -100,6 +107,8 @@ set_variable_labels <- function(data, metacore, dataset_name = deprecated()) {
   }
   verify_DatasetMeta(metacore)
 
+  verbose <- validate_verbose(verbose)
+
   # Grab out the var names and labels
   var_spec <- metacore$var_spec %>%
     select(variable, label)
@@ -110,16 +119,15 @@ set_variable_labels <- function(data, metacore, dataset_name = deprecated()) {
   dns <- names(data)
 
   # Are there any variables in data not in the metadata
-  mismatch <- setdiff(dns, ns)
-  in_meta <- ns[which(ns %in% mismatch)]
-  in_data <- dns[which(dns %in% mismatch)]
+  in_meta <- setdiff(ns, dns) # Variables in metadata not in data
+  in_data <- setdiff(dns, ns) # Variables in data not in metadata
 
-  if (length(in_meta) > 0) {
+  if (length(in_meta) > 0 && check_warn(verbose)) {
     wrn <- paste0("Variables in metadata not in data:\n\t", paste0(in_meta, collapse = "\n\t"))
     warning(wrn, call. = FALSE)
   }
 
-  if (length(in_data) > 0) {
+  if (length(in_data) > 0 && check_warn(verbose)) {
     wrn <- paste0("Variables in data not in metadata:\n\t", paste0(in_data, collapse = "\n\t"))
     warning(wrn, call. = FALSE)
   }

R/supp.R

@@ -6,12 +6,21 @@
 #' @param idvar IDVAR variable name (provided as a string)
 #' @param qeval QEVAL value to be populated for this QNAM
 #' @param qorig QORIG value to be populated for this QNAM
+#' @param verbose Character string controlling message verbosity. One of:
+#'   \describe{
+#'     \item{`"message"`}{Show both warnings and messages (default)}
+#'     \item{`"warn"`}{Show warnings but suppress messages}
+#'     \item{`"silent"`}{Suppress all warnings and messages}
+#'   }
 #'
 #' @return Observations structured in SUPP format
 #' @export
 #'
 #'
-build_qnam <- function(dataset, qnam, qlabel, idvar, qeval, qorig) {
+build_qnam <- function(dataset, qnam, qlabel, idvar, qeval, qorig,
+                       verbose = c("message", "warn", "silent")) {
+  verbose <- validate_verbose(verbose)
+
   # Need QNAM as a variable
   qval <- as.symbol(qnam)
 
@@ -58,7 +67,9 @@ build_qnam <- function(dataset, qnam, qlabel, idvar, qeval, qorig) {
   blank_test <- out %>%
     pull(QVAL)
   if (any(blank_test == "")) {
-    message(paste0("Empty QVAL rows removed for QNAM = ", unique(out$QNAM)))
+    if (check_message(verbose)) {
+      message(paste0("Empty QVAL rows removed for QNAM = ", unique(out$QNAM)))
+    }
     out <- out %>%
       filter(QVAL != "")
   }

R/utils.R

@@ -44,3 +44,32 @@ make_lone_dataset <- function(metacore, dataset_name) {
   }
   metacore
 }
+
+#' Check if messages should be displayed
+#' @param verbose Verbosity level
+#' @noRd
+check_message <- function(verbose) {
+  verbose == "message"
+}
+
+#' Check if warnings should be displayed
+#' @param verbose Verbosity level
+#' @noRd
+check_warn <- function(verbose) {
+  verbose %in% c("message", "warn")
+}
+
+#' Validate verbose parameter
+#' @param verbose Verbosity level to validate
+#' @noRd
+validate_verbose <- function(verbose, arg = rlang::caller_arg(verbose), call = rlang::caller_env()) {
+  choices <- c("message", "warn", "silent")
+  tryCatch(
+    match.arg(verbose, choices),
+    error = function(e) {
+      cli_abort(c(
+        "x" = "{.arg {arg}} should be one of: {cli::ansi_collapse(choices, last = ', ')}"
+      ), call = call)
+    }
+  )
+}