Merge pull request #196 from CHOP-CGTInformatics/reduce_multi_to_single

combine_checkboxes

.github/workflows/recheck.yml

@@ -0,0 +1,18 @@
+on:
+  workflow_dispatch:
+    inputs:
+      which:
+        type: choice
+        description: Which dependents to check
+        options:
+        - strong
+        - most
+
+name: Reverse dependency check
+
+jobs:
+  revdep_check:
+    name: Reverse check ${{ inputs.which }} dependents
+    uses: r-devel/recheck/.github/workflows/recheck.yml@v1
+    with:
+      which: ${{ inputs.which }}

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: REDCapTidieR
 Type: Package
 Title: Extract 'REDCap' Databases into Tidy 'Tibble's
-Version: 1.1.1
+Version: 1.2.0
 Authors@R: c(
     person("Richard", "Hanna", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0009-0005-6496-8154")),
@@ -21,6 +21,7 @@ Imports:
     checkmate,
     cli,
     dplyr,
+    glue,
     lobstr,
     lubridate,
     purrr,
@@ -52,5 +53,5 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 Language: en-US
 LazyData: true
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -4,6 +4,7 @@ S3method(tbl_sum,redcap_supertbl)
 S3method(vec_ptype_abbr,redcap_supertbl)
 export(add_skimr_metadata)
 export(bind_tibbles)
+export(combine_checkboxes)
 export(extract_tibble)
 export(extract_tibbles)
 export(fmt_strip_field_embedding)
@@ -38,22 +39,31 @@ importFrom(cli,cli_warn)
 importFrom(cli,qty)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,across)
+importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,case_when)
+importFrom(dplyr,coalesce)
+importFrom(dplyr,cur_column)
 importFrom(dplyr,filter)
+importFrom(dplyr,first)
 importFrom(dplyr,group_by)
 importFrom(dplyr,if_any)
 importFrom(dplyr,if_else)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
+importFrom(dplyr,n_distinct)
+importFrom(dplyr,nth)
 importFrom(dplyr,pull)
 importFrom(dplyr,recode)
 importFrom(dplyr,relocate)
 importFrom(dplyr,rename)
+importFrom(dplyr,right_join)
 importFrom(dplyr,row_number)
+importFrom(dplyr,rowwise)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)
 importFrom(dplyr,summarise)
+importFrom(dplyr,ungroup)
 importFrom(formattable,percent)
 importFrom(lobstr,obj_size)
 importFrom(lubridate,is.Date)
@@ -66,11 +76,13 @@ importFrom(purrr,discard)
 importFrom(purrr,flatten_chr)
 importFrom(purrr,map)
 importFrom(purrr,map2)
+importFrom(purrr,map2_chr)
 importFrom(purrr,map_int)
 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)
@@ -80,6 +92,7 @@ importFrom(readr,parse_integer)
 importFrom(readr,parse_logical)
 importFrom(readr,parse_time)
 importFrom(rlang,"!!!")
+importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(rlang,abort)
 importFrom(rlang,as_closure)
@@ -95,6 +108,7 @@ importFrom(rlang,enexpr)
 importFrom(rlang,enquo)
 importFrom(rlang,env_poke)
 importFrom(rlang,eval_tidy)
+importFrom(rlang,expr)
 importFrom(rlang,get_env)
 importFrom(rlang,global_env)
 importFrom(rlang,is_atomic)
@@ -103,6 +117,9 @@ importFrom(rlang,is_bare_list)
 importFrom(rlang,is_installed)
 importFrom(rlang,new_environment)
 importFrom(rlang,quo_get_expr)
+importFrom(rlang,quo_name)
+importFrom(rlang,sym)
+importFrom(rlang,syms)
 importFrom(rlang,try_fetch)
 importFrom(rlang,zap)
 importFrom(stats,na.omit)
@@ -121,6 +138,7 @@ importFrom(tidyr,complete)
 importFrom(tidyr,fill)
 importFrom(tidyr,nest)
 importFrom(tidyr,pivot_wider)
+importFrom(tidyr,separate_wider_delim)
 importFrom(tidyr,unnest)
 importFrom(tidyr,unnest_wider)
 importFrom(tidyselect,all_of)

NEWS.md

@@ -1,3 +1,5 @@
+# REDCapTidieR 1.2.0
+
 # REDCapTidieR 1.1.1 (development version)
 
 Version 1.1.1

R/REDCapTidieR-package.R

@@ -5,22 +5,26 @@
 #' expect_factor expect_logical
 #' @importFrom cli cli_abort cli_fmt cli_text cli_vec cli_warn qty
 #' @importFrom dplyr %>% across bind_rows case_when filter group_by if_any if_else
-#' left_join mutate pull recode relocate rename row_number select slice summarise
+#' left_join mutate pull recode relocate rename right_join row_number rowwise
+#' select slice summarise ungroup coalesce cur_column bind_cols first nth n_distinct
 #' @importFrom formattable percent
 #' @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
+#' @importFrom purrr compose map map2 map_int map_lgl pluck pmap_chr some pmap
+#' 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
 #' check_installed cnd_muffle current_call current_env enexpr enquo env_poke
-#' eval_tidy get_env global_env is_atomic is_bare_formula is_bare_list
-#' is_installed new_environment quo_get_expr try_fetch zap as_label
+#' eval_tidy get_env global_env is_atomic is_bare_formula is_bare_list quo_name
+#' is_installed new_environment quo_get_expr try_fetch zap as_label sym syms expr
+#' :=
 #' @importFrom stringi stri_split_fixed
 #' @importFrom stringr str_detect str_replace str_replace_all str_squish str_trunc
 #' str_trim str_ends
 #' @importFrom tibble as_tibble is_tibble tibble
-#' @importFrom tidyr complete fill pivot_wider nest unnest unnest_wider
+#' @importFrom tidyr complete fill pivot_wider nest separate_wider_delim unnest
+#' unnest_wider
 #' @importFrom tidyselect all_of any_of ends_with eval_select everything
 #' starts_with where
 #' @importFrom vctrs vec_ptype_abbr vec_ptype

R/checks.R

@@ -659,3 +659,128 @@ check_extra_field_values_message <- function(extra_field_values, call = caller_e
     values = values
   )
 }
+
+#' @title
+#' Check fields exist for checkbox combination
+#'
+#' @param fields Vector of character strings to check the length of
+#' @param expr An expression
+#' @param call The calling environment to use in the error message
+#'
+#' @keywords internal
+check_fields_exist <- function(fields, expr, call = caller_env()) {
+  expr <- quo_name(expr)
+
+  if (length(fields) == 0) {
+    msg <- c(
+      x = "No fields detected using `{expr}`.",
+      i = "Ensure that the column names specified in {.arg cols} match the columns in your data. Check for typos or use {.pkg tidyselect} helpers like {.code starts_with()}, `contains()`, etc." # nolint: line_length_linter
+    )
+
+    cli_abort(
+      msg,
+      class = c("missing_checkbox_fields", "REDCapTidieR_cond")
+    )
+  }
+}
+
+#' @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
+#'
+#' @param metadata_tbl A metadata tibble from a supertibble
+#' @param call The calling environment to use in the error message
+#'
+#' @keywords internal
+
+check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()) {
+  non_checkboxes <- metadata_tbl %>%
+    filter(.data$field_type != "checkbox")
+
+  if (nrow(non_checkboxes) > 0) {
+    non_checkboxes <- non_checkboxes %>%
+      pull(.data$field_name)
+
+    msg <- c(
+      x = "Non-checkbox fields selected for {.code form_name}",
+      `!` = "The following fields returned as non-checkbox field types: {.code {non_checkboxes}}"
+    )
+
+    cli_abort(
+      msg,
+      class = c("non_checkbox_fields", "REDCapTidieR_cond")
+    )
+  }
+}
+
+#' @title Check equal distinct values between two columns
+#'
+#' @description
+#' Takes a dataframe and two columns and checks if [n_distinct()] of the second
+#' column is all unique based on grouping of the first column.
+#'
+#' @param data a dataframe
+#' @param col1 a column to group by
+#' @param col2 a column to check for uniqueness
+#'
+#' @keywords internal
+
+check_equal_col_summaries <- function(data, col1, col2, call = caller_env()) {
+  summary <- data %>%
+    summarise(
+      .by = {{ col1 }},
+      n = n_distinct({{ col2 }})
+    )
+
+  total_n <- summary %>%
+    pull(.data$n)
+
+  if (!all(total_n == 1)) {
+    col1_n_vals <- summary %>%
+      filter(.data$n > 1) %>%
+      pull(col1)
+
+    col2_n_vals <- data %>% # nolint: object_usage_linter
+      filter(col1 %in% col1_n_vals) %>%
+      pull(col2)
+
+    msg <- c(
+      x = "{.code {col1_n_vals}} checkbox field{?s} resulted in multiple output columns: {.code {col2_n_vals}}.",
+      `!` = "Check that {.code names_glue} defines only 1 output column for each checkbox field." # nolint: line_length_linter
+    )
+
+    cli_abort(
+      msg,
+      class = c("names_glue_multi_checkbox", "REDCapTidieR_cond")
+    )
+  }
+}