#43 - Complete code for xportr_select and associated select_log.

Author: sophie-gem

R/messages.R

@@ -161,3 +161,23 @@ var_ord_msg <- function(reordered_vars, moved_vars, verbose) {
     cli_h2("All variables in dataset are ordered")
   }
 }
+
+
+#' Utility for Selecting Variables
+#'
+#' Function to output user message about variables which are listed in the
+#' metadata but not available in the dataframe.
+#'
+#' @param miss_vars Variables in the metadata but not in the dataframe.
+#' @param verbose Provides additional messaging for user.
+#'
+#' @return Output to Console
+#' @export
+select_log <- function(miss_vars, verbose) {
+
+  cli_h2("Variable(s) in metadata but not in dataframe.")
+  message <- glue("Variable(s) from `metadata` not found in `.df`: ",
+                  paste0(glue("{ encode_vars(miss_vars) }"), collapse = "", sep = " "), ".")
+  xportr_logger(message = message, type = verbose)
+}
+

R/select.R

@@ -8,7 +8,7 @@
 #' @param domain Appropriate CDISC dataset name, e.g. ADAE, DM. Used to subset the
 #'   metadata object. If none is passed, then name of the dataset passed `.df`
 #'   will be used.
-#' @param verbose The action the function takes when a variable in the `metacore`
+#' @param verbose The action the function takes when a variable in the `metadata`
 #'   is not found in the `.df`. Options are 'stop', 'warn', 'message', and 'none'.
 #'
 #' @return Data frame containing only those variables given in the metadata.
@@ -26,27 +26,27 @@
 #'   SEX_DEC = c("MALE", "FEMALE", "MALE")
 #' )
 #'
-#' metacore_adsl <- data.frame(
+#' metadata_adsl <- data.frame(
 #'   dataset = "adsl",
 #'   variable = c("USUBJID", "SITEID", "AGE", "SEX")
 #' )
 #'
-#' adsl <- xportr_select(adsl, metadata = metacore_adsl)
+#' adsl <- xportr_select(adsl, metadata = metadata_adsl)
 #'
 #' dm <- data.frame(
 #'   USUBJID = c(1001, 1002, 1003),
 #'   SITEID = c(001, 002, 003),
 #'   AGE = c(63, 35, 27)
 #' )
 #'
-#' metacore_dm <- data.frame(
-#'   dataset = "adsl",
+#' metadata_dm <- data.frame(
+#'   dataset = "dm",
 #'   variable = c("USUBJID", "SUBJID", "AGE", "SEX")
 #' )
 #'
-#' dm <- xportr_select(dm, metadata = metacore_dm, verbose = "warn")
+#' dm <- xportr_select(dm, metadata = metadata_dm, verbose = "warn")
 #'
-#' dm <- xportr_select(dm, metadata = metacore_dm, verbose = "stop")
+#' dm <- xportr_select(dm, metadata = metadata_dm, verbose = "stop")
 
 xportr_select <- function(.df,
                           metadata,
@@ -63,5 +63,39 @@ xportr_select <- function(.df,
   if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain
 
   ## End of common section
+
+  if (inherits(metadata, "Metacore")) {
+    metadata <- metadata$var_spec
+  }
+
+  if (domain_name %in% names(metadata)) {
+    metadata <- metadata %>%
+      dplyr::filter(!!sym(domain_name) == domain)
+  }
+
+  dfvars <- names(.df)
+  metavars <- metadata[[variable_name]]
+
+  if (all(metavars %in% dfvars) == FALSE) {
+    miss_vars <- metavars[which(! metavars %in% dfvars)]
+    select_log(miss_vars, verbose)
+    cat("\n")
+  }
+
+  drop_vars <- dfvars[which(! dfvars %in% metavars)]
+  if (length(drop_vars) > 0) {
+    .df <- .df %>%
+      select(-all_of(drop_vars))
+
+    cli_alert_info("The following variable(s) have been dropped from `.df`:")
+    #cat(paste0(drop_vars, collapse = "\n"))
+    cli_text("Variables: {drop_vars}.")
+    cat("\n")
+  } else {
+    cli_alert_info("No variables have been dropped from `.df`.")
+    cat("\n")
+  }
+
+  .df
 }