Update API, clean up, new methods, new docs

CHOP-CGTInformatics · Jul 29, 2024 · 7789a22 · 7789a22
1 parent c0b3885
commit 7789a22
Show file tree

Hide file tree

Showing 13 changed files with 276 additions and 177 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -81,6 +81,7 @@ importFrom(purrr,map_lgl)
 importFrom(purrr,pluck)
 importFrom(purrr,pmap)
 importFrom(purrr,pmap_chr)
+importFrom(purrr,reduce)
 importFrom(purrr,some)
 importFrom(readr,parse_character)
 importFrom(readr,parse_date)

diff --git a/R/REDCapTidieR-package.R b/R/REDCapTidieR-package.R
@@ -11,7 +11,7 @@
 #' @importFrom lobstr obj_size
 #' @importFrom lubridate is.difftime is.period is.POSIXt is.Date
 #' @importFrom purrr compose map map2 map_int map_lgl pluck pmap_chr some pmap
-#' discard flatten_chr map2_chr
+#' discard flatten_chr map2_chr reduce
 #' @importFrom REDCapR redcap_arm_export redcap_event_instruments redcap_instruments
 #' redcap_metadata_read redcap_read_oneshot sanitize_token
 #' @importFrom rlang .data !!! abort as_closure caller_arg caller_env catch_cnd

diff --git a/R/checks.R b/R/checks.R
@@ -664,7 +664,7 @@ check_extra_field_values_message <- function(extra_field_values, call = caller_e
 #' Check fields exist for checkbox combination
 #'
 #' @param fields Vector of character strings to check the length of
-#' @param expr A quosure expression
+#' @param expr An expression
 #' @param call The calling environment to use in the error message
 #'
 #' @keywords internal
@@ -712,32 +712,3 @@ check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()) {
     )
   }
 }
-
-#' @title
-#' Check values_to length against detected number of checkbox fields
-#'
-#' @param col_groups a list of column groups identified by checkbox field detection
-#' @param values_to a user defined character vector passed from [combine_checkboxes()]
-#' @param call The calling environment to use in the error message
-#'
-#' @keywords internal
-check_values_to_length <- function(col_groups, values_to, call = caller_env()) {
-  if (length(values_to) < length(names(col_groups))) {
-    cli_warn(
-      message = c(
-        `!` = "Detected fewer {.code values_to} arguments than the number of checkbox fields. Only the first {length(values_to)} will be used." # nolint line_length_linter
-      ),
-      class = c("checkbox_value_to_length", "REDCapTidieR_cond")
-    )
-  }
-
-  if (length(values_to) > length(names(col_groups))) {
-    cli_abort(
-      message = c(
-        `x` = "The number of {.code values_to} arguments supplied is greater than the number of checkbox fields detected.", # nolint line_length_linter
-        `i` = "{length(values_to)} {.code values_to} supplied, {length(names(col_groups))} checkbox fields detected."
-      ),
-      class = c("checkbox_value_to_length", "REDCapTidieR_cond")
-    )
-  }
-}
diff --git a/R/combine_checkboxes.R b/R/combine_checkboxes.R
@@ -8,10 +8,12 @@
 #'
 #' @param supertbl A supertibble generated by [read_redcap()]. Required.
 #' @param tbl The `redcap_form_name` of the data tibble to extract. Required.
-#' @param cols <[`tidy-select`][tidyr_tidy_select]> Checbox columns to combine to
+#' @param cols <[`tidy-select`][tidyr_tidy_select]> Checkbox columns to combine to
 #' single column. Required.
-#' @param values_to A string specifying the name of the column to combine checkbox
-#' values under. Required.
+#' @param names_prefix String added to the start of every variable name.
+#' @param names_suffix String added to the end of every variable name.
+#' @param names_sep String to separate new column names from `names_prefix` and/or
+#' `names_suffix`.
 #' @param multi_value_label A string specifying the value to be used when multiple
 #' checkbox fields are selected. Default "Multiple".
 #' @param values_fill Value to use when no checkboxes are selected. Default `NA`.
@@ -25,11 +27,10 @@
 #' @examples
 #' \dontrun{
 #' supertbl <- read_redcap(redcap_uri, token)
-#' combined_tbl <- combine_checkboxes(
+#' combine_checkboxes(
 #'   supertbl = supertbl,
 #'   tbl = "demographics",
 #'   cols = starts_with("race"),
-#'   values_to = "race_combined",
 #'   multi_value_label = "Multiple",
 #'   values_fill = NA
 #' )
@@ -40,15 +41,19 @@
 combine_checkboxes <- function(supertbl,
                                tbl,
                                cols,
-                               values_to,
+                               names_prefix = "",
+                               names_suffix = NULL,
+                               names_sep = "_",
                                multi_value_label = "Multiple",
                                values_fill = NA,
                                raw_or_label = "label",
                                keep = TRUE) {
   # Check args ---
   check_arg_is_supertbl(supertbl, req_cols = c("redcap_data", "redcap_metadata"))
+  check_arg_is_character(names_prefix, len = 1)
+  check_arg_is_character(names_suffix, len = 1, null.ok = TRUE)
+  check_arg_is_character(names_sep, len = 1, any.missing = TRUE)
   check_arg_is_character(tbl, len = 1, any.missing = FALSE)
-  check_arg_is_character(values_to, any.missing = FALSE)
   check_arg_is_character(multi_value_label, len = 1, any.missing = TRUE)
   check_arg_is_character(values_fill, len = 1, any.missing = TRUE)
   check_arg_choices(raw_or_label, choices = c("label", "raw"))
@@ -58,33 +63,29 @@ combine_checkboxes <- function(supertbl,
   data_tbl <- supertbl %>%
     extract_tibble(tbl)
 
-  # Save user cols to quosure
+  # Save user cols to quo
   cols_exp <- enquo(cols)
 
   # Evaluate the cols expression to get the selected column names
   selected_cols <- names(eval_select(cols_exp, data = data_tbl))
   check_fields_exist(fields = selected_cols, expr = cols_exp) # Check supplied fields exist
 
-  # Extract the prefix of each selected column
-  prefixes <- sub("___.*", "", selected_cols)
-
-  # Split the selected columns based on their prefixes
-  col_groups <- split(selected_cols, prefixes)
-  check_values_to_length(col_groups, values_to) # Check values_to columns match length of fields
-
   # Get metadata reference table, check that chosen fields are checkboxes
   metadata_tbl <- supertbl$redcap_metadata[supertbl$redcap_form_name == tbl][[1]]
-  metadata_ref <- get_metadata_ref(metadata_tbl, selected_cols)
+  metadata_spec <- get_metadata_spec(metadata_tbl, selected_cols, names_prefix, names_suffix, names_sep)
 
-  # Define values_to as the count of TRUEs/1s for the given checkbox field
+  # Define .new_col as the count of TRUEs/1s for the given checkbox field
   # Assign TRUE if multiple selections made, and FALSE if one or zero made
   data_tbl_mod <- data_tbl
+  .new_col <- unique(metadata_spec$.new_value)
+
+  for (i in seq_along(.new_col)) {
+    cols_to_sum <- metadata_spec$field_name[metadata_spec$.new_value == .new_col[i]] # nolint: object_usage_linter
 
-  for (i in seq_along(values_to)) {
     data_tbl_mod <- data_tbl_mod %>%
       mutate(
-        !!values_to[i] := case_when(
-          rowSums(select(., col_groups[[i]])) > 1 ~ TRUE,
+        !!.new_col[i] := case_when(
+          rowSums(select(., cols_to_sum)) > 1 ~ TRUE,
           .default = FALSE
         )
       )
@@ -97,39 +98,21 @@ combine_checkboxes <- function(supertbl,
         selected_cols,
         ~ replace_true(.x,
           cur_column(),
-          metadata = metadata_ref,
+          metadata = metadata_spec,
           raw_or_label = raw_or_label
         )
       ),
       across(selected_cols, as.character) # enforce to character strings
     )
 
-  for (i in seq_along(values_to)) {
-    metadata_overwrite <- metadata_ref %>%
-      filter(.data$field_name %in% col_groups[[i]]) %>%
-      pull(raw_or_label)
-
-    data_tbl_mod <- data_tbl_mod %>%
-      mutate(
-        !!values_to[i] := ifelse(!!sym(values_to[i]),
-          multi_value_label,
-          coalesce(!!!syms(col_groups[[i]]))
-        ),
-        !!values_to[i] := ifelse(is.na(!!sym(values_to[i])),
-          values_fill,
-          !!sym(values_to[i])
-        )
-      ) %>%
-      mutate(
-        !!values_to[i] := factor(!!sym(values_to[i]),
-          levels = c(metadata_overwrite, multi_value_label, values_fill)
-        )
-      )
-  }
+  # Use the metadata_spec table to fill values in .new_col
+  data_tbl_mod <- reduce(.new_col, function(tbl, col_item) {
+    convert_metadata_spec(col_item, metadata_spec, tbl, raw_or_label, multi_value_label, values_fill)
+  }, .init = data_tbl_mod)
 
   final_tbl <- bind_cols(
     data_tbl,
-    data_tbl_mod %>% select(!!values_to)
+    data_tbl_mod %>% select(!!.new_col)
   )
 
   # Keep or remove original multi columns
@@ -144,21 +127,28 @@ combine_checkboxes <- function(supertbl,
   supertbl
 }
 
-#' @title Utility function for getting metadata raw and label values for checkboxes
+#' @title Get metadata specification table
 #'
+#' @inheritParams combine_checkboxes
 #' @param metadata_tbl A metadata tibble from the supertibble generated by [read_redcap()].
 #' @param selected_cols Character string vector of field names for checkbox combination
 #'
 #' @returns a tibble
 #'
 #' @keywords internal
-get_metadata_ref <- function(metadata_tbl,
-                             selected_cols) {
+get_metadata_spec <- function(metadata_tbl,
+                              selected_cols,
+                              names_prefix,
+                              names_suffix,
+                              names_sep) {
   # Create a metadata reference table linking field name to raw and label values
   out <- metadata_tbl %>%
     filter(.data$field_name %in% selected_cols) %>%
     mutate(
-      original_field = sub("___.*$", "", .data$field_name)
+      .value = sub("___.*$", "", .data$field_name),
+      .new_value = case_when(!is.null(names_suffix) ~ paste(names_prefix, .value, names_suffix, sep = names_sep),
+        .default = paste(names_prefix, .data$.value, sep = names_sep)
+      )
     )
 
   # Make sure selection is checkbox metadata field type
@@ -167,19 +157,30 @@ get_metadata_ref <- function(metadata_tbl,
   # Bind raw/label values per original field grouping
   parsed_vals <- tibble()
 
-  for (i in seq_along(unique(out$original_field))) {
-    index <- unique(out$original_field)[i]
-    out_filtered <- out %>% filter(.data$original_field == index)
+  for (i in seq_along(unique(out$.value))) {
+    index <- unique(out$.value)[i]
+    out_filtered <- out %>% filter(.data$.value == index)
 
     parsed_vals <- rbind(parsed_vals, parse_labels(first(out_filtered$select_choices_or_calculations)))
   }
 
   bind_cols(out, parsed_vals) %>%
-    select(.data$field_name, .data$raw, .data$label, .data$original_field) %>%
-    relocate(.data$original_field, .after = .data$field_name)
+    select(.data$field_name, .data$raw, .data$label, .data$.value, .data$.new_value) %>%
+    relocate(c(.data$.value, .data$.new_value), .after = .data$field_name)
 }
 
-#' @noRd
+#' @title Replace checkbox TRUEs with raw_or_label values
+#'
+#' @inheritParams combine_checkboxes
+#' @param col A vector
+#' @param col_name A string
+#' @param metadata A metadata tibble from the original supertibble
+#'
+#' @description
+#' Simple utility function for replacing checkbox field values.
+#'
+#' @returns A character string
+#'
 #' @keywords internal
 replace_true <- function(col, col_name, metadata, raw_or_label) {
   # Replace TRUEs/1s with the appropriate raw or label value from the metadata
@@ -190,3 +191,53 @@ replace_true <- function(col, col_name, metadata, raw_or_label) {
   # Convert non-TRUEs to NA, since values can be either "FALSE" or "0" for unchecked values
   return(col)
 }
+
+#' @title Use metadata_spec to convert new column values
+#'
+#' @description
+#' [convert_metadata_spec()] uses the `metadata_spec` table provided by [get_metadata_spec()]
+#' to automatically convert new column values to either:
+#'
+#' - A `raw_or_label` checkbox value when only a single value is detected
+#' - `mult_value_label` when multiple values are detected
+#' - `values_fill` when `NA` is detected
+#'
+#' @inheritParams combine_checkboxes
+#' @param .new_col_item A character string
+#' @param metadata_spec A tibble output from [convert_metadata_spec()]
+#' @param data_tbl_mod A modified data tibble
+#'
+#' @returns a tibble
+#'
+#' @keywords internal
+convert_metadata_spec <- function(.new_col_item,
+                                  metadata_spec,
+                                  data_tbl_mod,
+                                  raw_or_label,
+                                  multi_value_label,
+                                  values_fill) {
+  .col_group <- metadata_spec$field_name[metadata_spec$.new_value == .new_col_item]
+
+  metadata_overwrite <- metadata_spec %>%
+    filter(.data$field_name %in% .col_group) %>%
+    pull(raw_or_label)
+
+  data_tbl_mod <- data_tbl_mod %>%
+    mutate(
+      !!.new_col_item := ifelse(!!sym(.new_col_item),
+        multi_value_label,
+        coalesce(!!!syms(.col_group))
+      ),
+      !!.new_col_item := ifelse(is.na(!!sym(.new_col_item)),
+        values_fill,
+        !!sym(.new_col_item)
+      )
+    ) %>%
+    mutate(
+      !!.new_col_item := factor(!!sym(.new_col_item),
+        levels = c(metadata_overwrite, multi_value_label, values_fill)
+      )
+    )
+
+  return(data_tbl_mod)
+}
diff --git a/man/check_fields_exist.Rd b/man/check_fields_exist.Rd
diff --git a/man/check_values_to_length.Rd b/man/check_values_to_length.Rd
diff --git a/man/combine_checkboxes.Rd b/man/combine_checkboxes.Rd