combine_checkboxes

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)

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

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

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,87 +41,84 @@
 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, len = 1, 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"))
   check_arg_is_logical(keep, len = 1, any.missing = FALSE)
 
-  # Save user cols to enquosure
-  cols_exp <- enquo(cols)
-
   # Extract tbl from supertbl
   data_tbl <- supertbl %>%
     extract_tibble(tbl)
 
-  # Get field names from cols_exp, check that fields exist
-  field_names <- names(eval_select(cols_exp, data = data_tbl))
-  check_fields_exist(fields = field_names, expr = cols_exp)
+  # Save user cols to quo
+  cols_exp <- enquo(cols)
 
-  # Define values_to 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 %>%
-    mutate(
-      !!values_to := case_when(
-        rowSums(select(., eval_tidy(cols_exp))) > 1 ~ TRUE,
-        TRUE ~ FALSE
-      )
-    )
+  # 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
 
   # Get metadata reference table, check that chosen fields are checkboxes
-  metadata <- get_metadata_ref(data_tbl_mod, supertbl, tbl, field_names)
+  metadata_tbl <- supertbl$redcap_metadata[supertbl$redcap_form_name == tbl][[1]]
+  metadata_spec <- get_metadata_spec(metadata_tbl, selected_cols, names_prefix, names_suffix, names_sep)
 
-  # Replace TRUEs/1s with raw/label values from metadata
-  data_tbl_mod <- data_tbl_mod %>%
-    mutate(across(
-      field_names,
-      ~ replace_true(.x,
-        cur_column(),
-        metadata = metadata,
-        raw_or_label = raw_or_label
+  # 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
+
+    data_tbl_mod <- data_tbl_mod %>%
+      mutate(
+        !!.new_col[i] := case_when(
+          rowSums(select(., cols_to_sum)) > 1 ~ TRUE,
+          .default = FALSE
+        )
       )
-    ))
-
+  }
 
-  # Convert values_to from TRUE/FALSE to multi_value_label or identified single val
+  # Replace TRUEs/1s with raw/label values from metadata
   data_tbl_mod <- data_tbl_mod %>%
     mutate(
-      across(field_names, as.character), # enforce to character strings
-      across(!!values_to, ~ as.character(.))
-    ) %>%
-    mutate(
-      !!values_to := ifelse(!!sym(values_to) == "TRUE",
-        multi_value_label,
-        coalesce(!!!syms(field_names))
+      across(
+        selected_cols,
+        ~ replace_true(.x,
+          cur_column(),
+          metadata = metadata_spec,
+          raw_or_label = raw_or_label
+        )
       ),
-      !!values_to := ifelse(is.na(!!sym(values_to)),
-        values_fill,
-        !!sym(values_to)
-      )
-    ) %>%
-    mutate(
-      !!values_to := factor(!!sym(values_to),
-        levels = c(metadata[[raw_or_label]], multi_value_label, values_fill)
-      )
+      across(selected_cols, as.character) # enforce to character strings
     )
 
+  # 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
   if (!keep) {
     final_tbl <- final_tbl %>%
-      select(-field_names)
+      select(-selected_cols)
   }
 
   # Update the supertbl data tibble
@@ -129,40 +127,60 @@ combine_checkboxes <- function(supertbl,
   supertbl
 }
 
-#' @title Utility function for getting metadata raw and label values for checkboxes
+#' @title Get metadata specification table
 #'
-#' @param data a data tibble
-#' @param supertbl A supertibble generated by [read_redcap()].
-#' @param tbl The name of the REDCap form (instrument) containing the checkbox
-#' fields.
-#' @param field_names Character string vector of field names for checkbox combination
+#' @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(data,
-                             supertbl,
-                             tbl,
-                             field_names) {
+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 <- supertbl$redcap_metadata[supertbl$redcap_form_name == tbl][[1]] %>%
-    filter(.data$field_name %in% field_names) %>%
-    # TODO: original_field a temporary placeholder for future multi-field and mapping dev
+  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
   check_fields_are_checkboxes(out)
 
-  # TODO: Make more robust for multi-field and mapping, using original_field above
-  parsed_vals <- parse_labels(first(out$select_choices_or_calculations))
+  # Bind raw/label values per original field grouping
+  parsed_vals <- tibble()
+
+  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)
+    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
@@ -173,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)
+}

R/utils.R

@@ -954,3 +954,23 @@ safe_set_variable_labels <- function(data, labs) {
   labs_to_keep <- intersect(names(labs), colnames(data))
   labelled::set_variable_labels(data, !!!labs[labs_to_keep])
 }
+
+#' @title
+#' Extract a specific metadata tibble from a supertibble
+#'
+#' @description
+#' Utility function to extract a specific metadata tibble from a supertibble
+#' given a `redcap_form_name`
+#'
+#' @param supertbl A supertibble generated by [read_redcap()].
+#' @param redcap_form_name A character string identifying the `redcap_form_name`
+#' the metadata tibble is associated with.
+#'
+#' @return
+#' A tibble
+#'
+#' @keywords internal
+
+extract_metadata_tibble <- function(supertbl, redcap_form_name) {
+  supertbl$redcap_metadata[supertbl$redcap_form_name == redcap_form_name][[1]]
+}