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")),
@@ -38,6 +38,7 @@ Imports:
     stats
 Suggests: 
     covr,
+    glue,
     knitr,
     labelled,
     lintr,
@@ -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,30 @@ 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,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 +75,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 +91,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 +107,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 +116,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 +137,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
 #' @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,85 @@ 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")
+    )
+  }
+}