combine_checkboxes

DESCRIPTION

@@ -38,6 +38,7 @@ Imports:
     stats
 Suggests: 
     covr,
+    glue,
     knitr,
     labelled,
     lintr,

R/checks.R

@@ -684,6 +684,35 @@ check_fields_exist <- function(fields, expr, call = caller_env()) {
   }
 }
 
+#' @title
+#' Check metadata fields exist for checkbox combination
+#'
+#' @description
+#' Similar to [check_fields_exist()], but instead of verifying fields that exist
+#' in the data tibble this seeks to verify their existence under the metadata
+#' tibble `field_name`s.
+#'
+#' @param metadata_tbl A metadata tibble from the supertibble generated by [read_redcap()].
+#' @param cols Selected columns identified for [`combine_checkboxes()`] to be
+#' cross checked against `metadata_tibble$field_name`
+#' @param call The calling environment to use in the error message
+#'
+#' @keywords internal
+check_metadata_fields_exist <- function(metadata_tbl, cols, call = caller_env()) {
+  if (!all(cols %in% metadata_tbl$field_name)) {
+    msg <- c(
+      x = "Fields detected not present in metadata.",
+      `!` = "Column{?s} {.code {cols[!cols %in% metadata_tbl$field_name]}} detected as valid in the data tibble, but not found present in the metadata tibble.", # nolint: line_length_linter
+      `i` = "This may occur if either the names of the data tibble or the metadata tibble `field_name`s were edited."
+    )
+
+    cli_abort(
+      msg,
+      class = c("missing_metadata_checkbox_fields", "REDCapTidieR_cond")
+    )
+  }
+}
+
 
 #' @title
 #' Check fields are of checkbox field type

R/combine_checkboxes.R

@@ -6,14 +6,28 @@
 #' combining multiple binary columns into a singular and informative labelled
 #' factor column.
 #'
+#' @details
+#' [combine_checkboxes()] makes use of the output names of [read_redcap()]
+#' data tibbles and metadata tibbles. Changes to checkbox data names or
+#' metadata `field_name`s may result in errors.
+#'
+#' Checkbox fields are expanded to be a variable per checkbox option, separated
+#' by underscores. For example, `checkbox_var` with 2 options becomes
+#' `checkbox_var___1` and `checkbox_var___2`. [combine_checkboxes()] looks for
+#' these and may give a error if it cannot find them.
+#'
 #' @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]> Checkbox columns to combine to
 #' single column. 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 names_sep String to separate new column names from `names_prefix`.
+#' @param names_glue Instead of `names_sep` and `names_prefix`, you can supply
+#' a glue specification and the unique `.value` to create custom column names.
+#' @param names_repair What happens if the output has invalid column names?
+#' The default, "check_unique" is to error if the columns are duplicated.
+#' Use "minimal" to allow duplicates in the output, or "unique" to de-duplicated
+#' by adding numeric suffixes. See [vctrs::vec_as_names()] for more options.
 #' @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`.
@@ -42,17 +56,19 @@ combine_checkboxes <- function(supertbl,
                                tbl,
                                cols,
                                names_prefix = "",
-                               names_suffix = NULL,
                                names_sep = "_",
+                               names_glue = NULL,
+                               names_repair = "check_unique",
                                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(names_repair, len = 1, any.missing = FALSE)
+  check_arg_is_character(names_glue, len = 1, any.missing = FALSE, null.ok = TRUE)
   check_arg_is_character(tbl, 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)
@@ -72,26 +88,11 @@ combine_checkboxes <- function(supertbl,
 
   # Get metadata reference table, check that chosen fields are checkboxes
   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)
+  metadata_spec <- get_metadata_spec(metadata_tbl, selected_cols, names_prefix, names_sep, names_glue)
 
-  # 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
+  # Copy data_tbl to mod, data_tbl to be referenced later
   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
-        )
-      )
-  }
 
-  # Replace TRUEs/1s with raw/label values from metadata
   data_tbl_mod <- data_tbl_mod %>%
     mutate(
       across(
@@ -105,15 +106,14 @@ combine_checkboxes <- function(supertbl,
       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)
+  new_cols <- metadata_spec %>%
+    nest(.by = .data$.new_value, .key = "metadata") %>%
+    pmap(convert_checkbox_vals,
+      data_tbl = data_tbl_mod,
+      raw_or_label = raw_or_label, multi_value_label = multi_value_label, values_fill = values_fill
+    )
 
-  final_tbl <- bind_cols(
-    data_tbl,
-    data_tbl_mod %>% select(!!.new_col)
-  )
+  final_tbl <- combine_and_repair_tbls(data_tbl, data_tbl_mod, new_cols, names_repair = names_repair)
 
   # Keep or remove original multi columns
   if (!keep) {
@@ -139,17 +139,30 @@ combine_checkboxes <- function(supertbl,
 get_metadata_spec <- function(metadata_tbl,
                               selected_cols,
                               names_prefix,
-                              names_suffix,
-                              names_sep) {
+                              names_sep,
+                              names_glue) {
+  check_metadata_fields_exist(metadata_tbl, selected_cols)
+
   # Create a metadata reference table linking field name to raw and label values
-  out <- metadata_tbl %>%
-    filter(.data$field_name %in% selected_cols) %>%
-    mutate(
-      .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)
+  if (!is.null(names_glue)) {
+    check_installed("glue", reason = "to use `names_glue` in `combine_checkboxes()`")
+    # Similar to pivot_*, use of `names_glue` overrides use of names_prefix/sep
+    out <- metadata_tbl %>%
+      filter(.data$field_name %in% selected_cols) %>%
+      mutate(
+        .value = sub("___.*$", "", .data$field_name),
+        .new_value = as.character(glue::glue(names_glue))
       )
-    )
+  } else {
+    out <- metadata_tbl %>%
+      filter(.data$field_name %in% selected_cols) %>%
+      mutate(
+        .value = sub("___.*$", "", .data$field_name),
+        .new_value = case_when(names_prefix != "" ~ paste(names_prefix, .value, sep = names_sep),
+          .default = paste(names_prefix, .data$.value, sep = "")
+        )
+      )
+  }
 
   # Make sure selection is checkbox metadata field type
   check_fields_are_checkboxes(out)
@@ -192,52 +205,80 @@ replace_true <- function(col, col_name, metadata, raw_or_label) {
   return(col)
 }
 
-#' @title Use metadata_spec to convert new column values
+#' @title Convert a new checkbox column's values
 #'
-#' @description
-#' [convert_metadata_spec()] uses the `metadata_spec` table provided by [get_metadata_spec()]
-#' to automatically convert new column values to either:
+#' @description This function takes a single column of data and converts the values
+#' based on the overall data tibble cross referenced with a nested section of the
+#' metadata tibble.
 #'
-#' - 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
+#' [case_when()] logic helps determine whether the value is a coalesced singular
+#' value or a user-specified one via `multi_value_label` or `values_fill`.
 #'
-#' @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
+#' @details
+#' This function is used in conjunction with [pmap()].
 #'
 #' @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 %>%
+#'
+#' @param metadata A nested portion of the overall metadata tibble
+#' @param data_tbl The data tibble from the original supertibble
+#' @param .new_value The new column values made by [combine_checkboxes()]
+#' @inheritParams combine_checkboxes
+convert_checkbox_vals <- function(metadata, .new_value, data_tbl, raw_or_label, multi_value_label, values_fill) {
+  tibble(
+    !!.new_value := rowSums(!is.na(data_tbl[names(data_tbl) %in% metadata$field_name]))
+  ) %>%
     mutate(
-      !!.new_col_item := ifelse(!!sym(.new_col_item),
-        multi_value_label,
-        coalesce(!!!syms(.col_group))
+      !!.new_value := case_when(. > 1 ~ multi_value_label,
+        . == 1 ~ coalesce(!!!data_tbl[, names(data_tbl) %in% metadata$field_name]),
+        .default = values_fill
       ),
-      !!.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)
+      !!.new_value := factor(!!sym(.new_value),
+        levels = c(metadata[[raw_or_label]], multi_value_label, values_fill)
       )
     )
+}
+
+#' @title Combine checkbox fields with respect to repaired outputs
+#'
+#' @description
+#' This function seeks to preserve the original data columns and types from the
+#' originally supplied data_tbl and add on the new columns from data_tbl_mod.
+#'
+#' If `names_repair` presents a repair strategy, the output columns will be
+#' captured and updated here while dropping the original columns.
+#'
+#' @param data_tbl The original data table given to [combine_checkboxes()]
+#' @param data_tbl_mod A modified data table from `data_tbl`
+#' @param new_cols The new columns created for checkbox combination
+#' @inheritParams combine_checkboxes
+#'
+#' @keywords internal
+#'
+#' @returns a tibble
+combine_and_repair_tbls <- function(data_tbl, data_tbl_mod, new_cols, names_repair) {
+  # Perform initial column bind with repair strategy
+  data_tbl_mod <- bind_cols(data_tbl_mod, new_cols, .name_repair = names_repair)
+
+  # Get the column names of each table
+  cols_data_tbl <- names(data_tbl)
+  cols_data_tbl_mod <- names(data_tbl_mod)
+
+  # Identify common columns
+  common_cols <- intersect(cols_data_tbl, cols_data_tbl_mod)
+
+  # Identify unique columns in data_tbl_mod
+  unique_cols_mod <- setdiff(cols_data_tbl_mod, cols_data_tbl)
+
+  # Select common columns from data_tbl
+  common_data <- data_tbl %>%
+    select(all_of(common_cols))
+
+  # Select unique columns from data_tbl_mod
+  unique_data_mod <- data_tbl_mod %>%
+    select(all_of(unique_cols_mod))
+
+  # Combine the selected columns
+  combined_data <- bind_cols(common_data, unique_data_mod)
 
-  return(data_tbl_mod)
+  return(combined_data)
 }