From 9352b1601951238f623f85d4f391887bb5818051 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Wed, 14 Dec 2022 15:39:19 -0500 Subject: [PATCH 01/14] bind_tibbles() arg checking --- NAMESPACE | 4 ++ R/bind_tibbles.R | 4 ++ R/checks.R | 96 ++++++++++++++++++++++++++++++ tests/testthat/test-bind_tibbles.R | 6 ++ tests/testthat/test-checks.R | 16 +++++ 5 files changed, 126 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 5585d7c0..4b447faf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,9 @@ importFrom(REDCapR,redcap_metadata_read) importFrom(REDCapR,redcap_read_oneshot) importFrom(checkmate,assert_character) importFrom(checkmate,assert_data_frame) +importFrom(checkmate,check_character) +importFrom(checkmate,check_data_frame) +importFrom(checkmate,check_environment) importFrom(checkmate,expect_character) importFrom(checkmate,expect_double) importFrom(checkmate,expect_factor) @@ -54,6 +57,7 @@ importFrom(purrr,pluck) importFrom(rlang,"!!!") importFrom(rlang,.data) importFrom(rlang,as_closure) +importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,check_installed) importFrom(rlang,current_env) diff --git a/R/bind_tibbles.R b/R/bind_tibbles.R index ff43f233..4fb96f7b 100644 --- a/R/bind_tibbles.R +++ b/R/bind_tibbles.R @@ -43,6 +43,10 @@ bind_tibbles <- function(supertbl, environment = global_env(), tbls = NULL) { + check_arg_is_dataframe(supertbl) + check_arg_is_env(environment) + check_arg_is_character(tbls, null.ok = TRUE) + # Name variables my_supertbl <- supertbl diff --git a/R/checks.R b/R/checks.R index d183fb88..db02b142 100644 --- a/R/checks.R +++ b/R/checks.R @@ -272,3 +272,99 @@ check_req_labelled_metadata_fields <- function(supertbl) { ) } } + +#' @title +#' Check that an argument is a dataframe (or tibble) +#' +#' @importFrom checkmate check_data_frame +#' @importFrom cli cli_abort +#' @importFrom rlang caller_arg +#' +#' @param x An object to check +#' @param arg The name of the argument to include in an error message. Captured +#' by `rlang::caller_arg()` by default +#' @param ... additional arguments passed on to checkmate +#' +#' @return +#' `TRUE` if `x` is a dataframe. An error message otherwise +#' +#' @keywords internal +check_arg_is_dataframe <- function(x, ..., arg = caller_arg(x)) { + out <- check_data_frame(x, ...) + + if (isTRUE(out)) { + return(TRUE) + } + + cli_abort( + message = c( + "!" = "{.arg {arg}} must be a {.cls {c('tbl', 'data.frame')}}", + "x" = "{.arg {arg}} is {.cls {class(x)}}" + ), + class = c("arg_not_df", "REDCapTidieR_cond") + ) +} + +#' @title +#' Check that an argument is an environment +#' +#' @importFrom checkmate check_environment +#' @importFrom cli cli_abort +#' @importFrom rlang caller_arg +#' +#' @param x An object to check +#' @param arg The name of the argument to include in an error message. Captured +#' by `rlang::caller_arg()` by default +#' @param ... additional arguments passed on to checkmate +#' +#' @return +#' `TRUE` if `x` is an environment. An error message otherwise +#' +#' @keywords internal +check_arg_is_env <- function(x, ..., arg = caller_arg(x)) { + out <- check_environment(x, ...) + + if (isTRUE(out)) { + return(TRUE) + } + + cli_abort( + message = c( + "!" = "{.arg {arg}} must be an {.cls environment}", + "x" = "{.arg {arg}} is {.cls {class(x)}}" + ), + class = c("arg_not_env", "REDCapTidieR_cond") + ) +} + +#' @title +#' Check that an argument is character +#' +#' @importFrom checkmate check_character +#' @importFrom cli cli_abort +#' @importFrom rlang caller_arg +#' +#' @param x An object to check +#' @param arg The name of the argument to include in an error message. Captured +#' by `rlang::caller_arg()` by default +#' @param ... additional arguments passed on to checkmate +#' +#' @return +#' `TRUE` if `x` is a character vector. An error message otherwise +#' +#' @keywords internal +check_arg_is_character <- function(x, ..., arg = caller_arg(x)) { + out <- check_character(x, ...) + + if (isTRUE(out)) { + return(TRUE) + } + + cli_abort( + message = c( + "!" = "{.arg {arg}} must be {.cls character}", + "x" = "{.arg {arg}} is {.cls {class(x)}}" + ), + class = c("arg_not_character", "REDCapTidieR_cond") + ) +} diff --git a/tests/testthat/test-bind_tibbles.R b/tests/testthat/test-bind_tibbles.R index c9318dfe..cff5abb7 100644 --- a/tests/testthat/test-bind_tibbles.R +++ b/tests/testthat/test-bind_tibbles.R @@ -42,3 +42,9 @@ test_that("bind_tibbles works with forms specification", { expect_true(exists("repeated", envir = global_env())) rm(list = c("nonrepeated", "repeated"), envir = global_env()) }) + +test_that("bind_tibbles errors with bad inputs", { + expect_error(bind_tibbles(123), class = "arg_not_df") + expect_error(bind_tibbles(tibble(), environment = "abc"), class = "arg_not_env") + expect_error(bind_tibbles(tibble(), tbls = 123), class = "arg_not_character") +}) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index 407c3aac..3dee08b0 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -104,3 +104,19 @@ test_that("check_req_labelled_metadata_fields works", { check_req_labelled_metadata_fields(supertbl_no_field_label) %>% expect_error(class = "missing_req_labelled_metadata_fields") }) + +test_that("checkmate wrappers work", { + # df/tibble + expect_error(check_arg_is_dataframe(123), class = "arg_not_df") + expect_true(check_arg_is_dataframe(data.frame())) + expect_true(check_arg_is_dataframe(tibble())) + + # environment + expect_error(check_arg_is_env(123), class = "arg_not_env") + expect_true(check_arg_is_env(new.env())) + + # character + expect_error(check_arg_is_character(123), class = "arg_not_character") + expect_true(check_arg_is_character("abc")) + +}) From 1d85fd6b09ba4c75c8ad04544634f08095985b41 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Wed, 14 Dec 2022 16:30:34 -0500 Subject: [PATCH 02/14] extract_tibble/s() arg checking --- R/extract_tibble.R | 7 +++++-- tests/testthat/test-extract_tibble.R | 5 +++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/R/extract_tibble.R b/R/extract_tibble.R index 50ad5700..d131ea68 100644 --- a/R/extract_tibble.R +++ b/R/extract_tibble.R @@ -32,8 +32,9 @@ extract_tibble <- function(supertbl, tbl) { - # Check tbl is valid ---- - assert_character(tbl) + # Check args ---- + check_arg_is_dataframe(supertbl) + check_arg_is_character(tbl) if (length(tbl) > 1) { cli_abort("Only one table may be supplied.") @@ -88,6 +89,8 @@ extract_tibble <- function(supertbl, extract_tibbles <- function(supertbl, tbls = everything()) { + check_arg_is_dataframe(supertbl) + # Extract specified table ---- # Pass tbls as an expression for enquosure tbls <- enquo(tbls) diff --git a/tests/testthat/test-extract_tibble.R b/tests/testthat/test-extract_tibble.R index 76aadd1c..1e5ba8f2 100644 --- a/tests/testthat/test-extract_tibble.R +++ b/tests/testthat/test-extract_tibble.R @@ -43,10 +43,15 @@ test_that("extract_tibbles works with a vector and tidyselect selectors", { ) expect_error(redcaptidier_longitudintal_db %>% extract_tibbles(tbls = c("repeated", "fake_instrument_name"))) + + expect_error(extract_tibbles(123), class = "arg_not_df") + }) test_that("extract_tibble works", { expect_error(extract_tibble(redcaptidier_longitudintal_db, "fake_instrument_name")) + expect_error(extract_tibble(123, "my_tibble"), class = "arg_not_df") + expect_error(extract_tibble(tibble(), tbl = 123), class = "arg_not_character") expected_out <- redcaptidier_longitudintal_db$redcap_data[[1]] expect_equal( From 2a5204094ca73da3a0d673a7d9a11ba1493b2f4b Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Thu, 15 Dec 2022 10:19:55 -0500 Subject: [PATCH 03/14] read_redcap/make_labelled arg checking --- NAMESPACE | 2 + R/checks.R | 64 +++++++++++++++++++++++++++++++ R/labelled.R | 2 +- R/read_redcap.R | 8 ++++ man/check_arg_is_logical.Rd | 23 +++++++++++ tests/testthat/test-checks.R | 8 ++++ tests/testthat/test-labelled.R | 8 ++++ tests/testthat/test-read_redcap.R | 9 +++++ 8 files changed, 123 insertions(+), 1 deletion(-) create mode 100644 man/check_arg_is_logical.Rd diff --git a/NAMESPACE b/NAMESPACE index 4b447faf..d9989905 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,8 +23,10 @@ importFrom(REDCapR,redcap_read_oneshot) importFrom(checkmate,assert_character) importFrom(checkmate,assert_data_frame) importFrom(checkmate,check_character) +importFrom(checkmate,check_choice) importFrom(checkmate,check_data_frame) importFrom(checkmate,check_environment) +importFrom(checkmate,check_logical) importFrom(checkmate,expect_character) importFrom(checkmate,expect_double) importFrom(checkmate,expect_factor) diff --git a/R/checks.R b/R/checks.R index db02b142..3fb1d6b0 100644 --- a/R/checks.R +++ b/R/checks.R @@ -368,3 +368,67 @@ check_arg_is_character <- function(x, ..., arg = caller_arg(x)) { class = c("arg_not_character", "REDCapTidieR_cond") ) } + +#' @title +#' Check that an argument is logical +#' +#' @importFrom checkmate check_logical +#' @importFrom cli cli_abort +#' @importFrom rlang caller_arg +#' +#' @param x An object to check +#' @param arg The name of the argument to include in an error message. Captured +#' by `rlang::caller_arg()` by default +#' @param ... additional arguments passed on to checkmate +#' +#' @return +#' `TRUE` if `x` is a logical vector. An error message otherwise +#' +#' @keywords internal +check_arg_is_logical <- function(x, ..., arg = caller_arg(x)) { + out <- check_logical(x, ...) + + if (isTRUE(out)) { + return(TRUE) + } + + cli_abort( + message = c( + "!" = "{.arg {arg}} must be {.cls logical}", + "x" = "{.arg {arg}} is {.cls {class(x)}}" + ), + class = c("arg_not_logical", "REDCapTidieR_cond") + ) +} + +#' @title +#' Check that an argument is XXXXXX +#' +#' @importFrom checkmate check_choice +#' @importFrom cli cli_abort +#' @importFrom rlang caller_arg +#' +#' @param x An object to check +#' @param arg The name of the argument to include in an error message. Captured +#' by `rlang::caller_arg()` by default +#' @param ... additional arguments passed on to checkmate +#' +#' @return +#' `TRUE` if `x` is XXXXX vector. An error message otherwise +#' +#' @keywords internal +check_arg_choices <- function(x, ..., arg = caller_arg(x)) { + out <- check_choice(x, ...) + + if (isTRUE(out)) { + return(TRUE) + } + + cli_abort( + message = c( + "!" = "{.arg {arg}} must be {.cls logical}", + "x" = "{.arg {arg}} is {.cls {class(x)}}" + ), + class = c("arg_choices", "REDCapTidieR_cond") + ) +} diff --git a/R/labelled.R b/R/labelled.R index 38efaf7c..078a2f76 100644 --- a/R/labelled.R +++ b/R/labelled.R @@ -54,7 +54,7 @@ make_labelled <- function(supertbl, format_labels = NULL) { formatter <- resolve_formatter(format_labels) # nolint: object_usage_linter - assert_data_frame(supertbl) + check_arg_is_dataframe(supertbl) check_req_labelled_fields(supertbl) check_req_labelled_metadata_fields(supertbl) diff --git a/R/read_redcap.R b/R/read_redcap.R index cfa7d2ca..b1caf50c 100644 --- a/R/read_redcap.R +++ b/R/read_redcap.R @@ -72,6 +72,14 @@ read_redcap <- function(redcap_uri, forms = NULL, export_survey_fields = TRUE, suppress_redcapr_messages = TRUE) { + + check_arg_is_character(redcap_uri, len = 1) + check_arg_is_character(token, len = 1) + check_arg_choices(raw_or_label, choices = c("label", "raw")) + check_arg_is_character(forms, null.ok = TRUE) + check_arg_is_logical(export_survey_fields, len = 1) + check_arg_is_logical(suppress_redcapr_messages, len = 1) + # Load REDCap Metadata ---- db_metadata <- redcap_metadata_read( redcap_uri = redcap_uri, diff --git a/man/check_arg_is_logical.Rd b/man/check_arg_is_logical.Rd new file mode 100644 index 00000000..8e4739ba --- /dev/null +++ b/man/check_arg_is_logical.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checks.R +\name{check_arg_is_logical} +\alias{check_arg_is_logical} +\title{Check that an argument is logical} +\usage{ +check_arg_is_logical(x, ..., arg = caller_arg(x)) +} +\arguments{ +\item{x}{An object to check} + +\item{...}{additional arguments passed on to checkmate} + +\item{arg}{The name of the argument to include in an error message. Captured +by \code{rlang::caller_arg()} by default} +} +\value{ +\code{TRUE} if \code{x} is a logical vector. An error message otherwise +} +\description{ +Check that an argument is logical +} +\keyword{internal} diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index 3dee08b0..6e0fa875 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -119,4 +119,12 @@ test_that("checkmate wrappers work", { expect_error(check_arg_is_character(123), class = "arg_not_character") expect_true(check_arg_is_character("abc")) + # logical + expect_error(check_arg_is_logical(123), class = "arg_not_logical") + expect_true(check_arg_is_logical(TRUE)) + + # choices + expect_error(check_arg_choices(123, choices = letters[1:3]), class = "arg_choices") + expect_true(check_arg_choices("a", choices = letters[1:3])) + }) diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index 31145816..537f910b 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -286,3 +286,11 @@ test_that("make_labelled accepts all valid input types to format_labels", { make_labelled(supertbl, format_labels = 1) %>% expect_error(class = "unresolved_formatter") }) + +test_that("make_labelled errors with bad inputs", { + # Input to format_labels is tested above + + expect_error(make_labelled(123), class = "arg_not_df") +}) + + diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index a3e71b5e..2a40fe30 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -387,3 +387,12 @@ test_that("read_redcap returns expected survey fields", { checkmate::expect_class(survey_data$redcap_survey_timestamp, c("POSIXct", "POSIXt")) }) + +test_that("read_redcap errors with bad inputs", { + expect_error(read_redcap(123, redcap_uri), class = "arg_not_character") + expect_error(read_redcap(classic_token, 123), class = "arg_not_character") + expect_error(read_redcap(classic_token, redcap_uri, raw_or_label = "bad option"), class = "arg_choices") + expect_error(read_redcap(classic_token, redcap_uri, forms = 123), class = "arg_not_character") + expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = 123), class = "arg_not_logical") + expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = 123), class = "arg_not_logical") +}) From 28708c26b29d4837e0af6c7402f0cb50bf2ecc61 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Thu, 15 Dec 2022 11:22:38 -0500 Subject: [PATCH 04/14] refactor checkmate checks --- R/checks.R | 170 ++++++--------------------- R/extract_tibble.R | 6 +- man/check_arg_is_logical.Rd | 23 ---- man/checkmate.Rd | 37 ++++++ tests/testthat/test-bind_tibbles.R | 6 +- tests/testthat/test-checks.R | 10 +- tests/testthat/test-extract_tibble.R | 7 +- tests/testthat/test-labelled.R | 2 +- tests/testthat/test-read_redcap.R | 29 ++++- 9 files changed, 110 insertions(+), 180 deletions(-) delete mode 100644 man/check_arg_is_logical.Rd create mode 100644 man/checkmate.Rd diff --git a/R/checks.R b/R/checks.R index 3fb1d6b0..eac5a116 100644 --- a/R/checks.R +++ b/R/checks.R @@ -273,10 +273,10 @@ check_req_labelled_metadata_fields <- function(supertbl) { } } + #' @title -#' Check that an argument is a dataframe (or tibble) +#' Check an argument with checkmate #' -#' @importFrom checkmate check_data_frame #' @importFrom cli cli_abort #' @importFrom rlang caller_arg #' @@ -286,149 +286,51 @@ check_req_labelled_metadata_fields <- function(supertbl) { #' @param ... additional arguments passed on to checkmate #' #' @return -#' `TRUE` if `x` is a dataframe. An error message otherwise +#' `TRUE` if `x` passes the checkmate check. An error otherwise with the name of +#' the checkmate function as a `class` #' +#' @name checkmate #' @keywords internal -check_arg_is_dataframe <- function(x, ..., arg = caller_arg(x)) { - out <- check_data_frame(x, ...) - - if (isTRUE(out)) { - return(TRUE) - } - - cli_abort( - message = c( - "!" = "{.arg {arg}} must be a {.cls {c('tbl', 'data.frame')}}", - "x" = "{.arg {arg}} is {.cls {class(x)}}" - ), - class = c("arg_not_df", "REDCapTidieR_cond") - ) -} +NULL -#' @title -#' Check that an argument is an environment -#' -#' @importFrom checkmate check_environment -#' @importFrom cli cli_abort +# Function factory to wrap checkmate functions #' @importFrom rlang caller_arg -#' -#' @param x An object to check -#' @param arg The name of the argument to include in an error message. Captured -#' by `rlang::caller_arg()` by default -#' @param ... additional arguments passed on to checkmate -#' -#' @return -#' `TRUE` if `x` is an environment. An error message otherwise -#' -#' @keywords internal -check_arg_is_env <- function(x, ..., arg = caller_arg(x)) { - out <- check_environment(x, ...) +#' @importFrom cli cli_abort +#' @noRd +wrap_checkmate <- function(f, f_name = caller_arg(f)) { + function(x, ..., arg = caller_arg(x)) { + out <- f(x, ...) - if (isTRUE(out)) { - return(TRUE) - } + if (isTRUE(out)) { + return(TRUE) + } - cli_abort( - message = c( - "!" = "{.arg {arg}} must be an {.cls environment}", - "x" = "{.arg {arg}} is {.cls {class(x)}}" - ), - class = c("arg_not_env", "REDCapTidieR_cond") - ) + cli_abort( + message = c( + "x" = "{.arg {arg}} is invalid", + "!" = "{out}" + ), + class = c(f_name, "REDCapTidieR_cond") + ) + } } -#' @title -#' Check that an argument is character -#' -#' @importFrom checkmate check_character -#' @importFrom cli cli_abort -#' @importFrom rlang caller_arg -#' -#' @param x An object to check -#' @param arg The name of the argument to include in an error message. Captured -#' by `rlang::caller_arg()` by default -#' @param ... additional arguments passed on to checkmate -#' -#' @return -#' `TRUE` if `x` is a character vector. An error message otherwise -#' -#' @keywords internal -check_arg_is_character <- function(x, ..., arg = caller_arg(x)) { - out <- check_character(x, ...) +#' @rdname checkmate +#' @importFrom checkmate check_data_frame +check_arg_is_dataframe <- wrap_checkmate(check_data_frame) - if (isTRUE(out)) { - return(TRUE) - } +#' @rdname checkmate +#' @importFrom checkmate check_environment +check_arg_is_env <- wrap_checkmate(check_environment) - cli_abort( - message = c( - "!" = "{.arg {arg}} must be {.cls character}", - "x" = "{.arg {arg}} is {.cls {class(x)}}" - ), - class = c("arg_not_character", "REDCapTidieR_cond") - ) -} +#' @rdname checkmate +#' @importFrom checkmate check_character +check_arg_is_character <- wrap_checkmate(check_character) -#' @title -#' Check that an argument is logical -#' +#' @rdname checkmate #' @importFrom checkmate check_logical -#' @importFrom cli cli_abort -#' @importFrom rlang caller_arg -#' -#' @param x An object to check -#' @param arg The name of the argument to include in an error message. Captured -#' by `rlang::caller_arg()` by default -#' @param ... additional arguments passed on to checkmate -#' -#' @return -#' `TRUE` if `x` is a logical vector. An error message otherwise -#' -#' @keywords internal -check_arg_is_logical <- function(x, ..., arg = caller_arg(x)) { - out <- check_logical(x, ...) - - if (isTRUE(out)) { - return(TRUE) - } - - cli_abort( - message = c( - "!" = "{.arg {arg}} must be {.cls logical}", - "x" = "{.arg {arg}} is {.cls {class(x)}}" - ), - class = c("arg_not_logical", "REDCapTidieR_cond") - ) -} +check_arg_is_logical <- wrap_checkmate(check_logical) -#' @title -#' Check that an argument is XXXXXX -#' +#' @rdname checkmate #' @importFrom checkmate check_choice -#' @importFrom cli cli_abort -#' @importFrom rlang caller_arg -#' -#' @param x An object to check -#' @param arg The name of the argument to include in an error message. Captured -#' by `rlang::caller_arg()` by default -#' @param ... additional arguments passed on to checkmate -#' -#' @return -#' `TRUE` if `x` is XXXXX vector. An error message otherwise -#' -#' @keywords internal -check_arg_choices <- function(x, ..., arg = caller_arg(x)) { - out <- check_choice(x, ...) - - if (isTRUE(out)) { - return(TRUE) - } - - cli_abort( - message = c( - "!" = "{.arg {arg}} must be {.cls logical}", - "x" = "{.arg {arg}} is {.cls {class(x)}}" - ), - class = c("arg_choices", "REDCapTidieR_cond") - ) -} +check_arg_choices <- wrap_checkmate(check_choice) diff --git a/R/extract_tibble.R b/R/extract_tibble.R index d131ea68..c2477af9 100644 --- a/R/extract_tibble.R +++ b/R/extract_tibble.R @@ -34,11 +34,7 @@ extract_tibble <- function(supertbl, tbl) { # Check args ---- check_arg_is_dataframe(supertbl) - check_arg_is_character(tbl) - - if (length(tbl) > 1) { - cli_abort("Only one table may be supplied.") - } + check_arg_is_character(tbl, len = 1) # Extract specified table ---- out <- extract_tibbles(supertbl, tbls = all_of(tbl))[[1]] diff --git a/man/check_arg_is_logical.Rd b/man/check_arg_is_logical.Rd deleted file mode 100644 index 8e4739ba..00000000 --- a/man/check_arg_is_logical.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/checks.R -\name{check_arg_is_logical} -\alias{check_arg_is_logical} -\title{Check that an argument is logical} -\usage{ -check_arg_is_logical(x, ..., arg = caller_arg(x)) -} -\arguments{ -\item{x}{An object to check} - -\item{...}{additional arguments passed on to checkmate} - -\item{arg}{The name of the argument to include in an error message. Captured -by \code{rlang::caller_arg()} by default} -} -\value{ -\code{TRUE} if \code{x} is a logical vector. An error message otherwise -} -\description{ -Check that an argument is logical -} -\keyword{internal} diff --git a/man/checkmate.Rd b/man/checkmate.Rd new file mode 100644 index 00000000..53ada609 --- /dev/null +++ b/man/checkmate.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checks.R +\name{checkmate} +\alias{checkmate} +\alias{check_arg_is_dataframe} +\alias{check_arg_is_env} +\alias{check_arg_is_character} +\alias{check_arg_is_logical} +\alias{check_arg_choices} +\title{Check an argument with checkmate} +\usage{ +check_arg_is_dataframe(x, ..., arg = caller_arg(x)) + +check_arg_is_env(x, ..., arg = caller_arg(x)) + +check_arg_is_character(x, ..., arg = caller_arg(x)) + +check_arg_is_logical(x, ..., arg = caller_arg(x)) + +check_arg_choices(x, ..., arg = caller_arg(x)) +} +\arguments{ +\item{x}{An object to check} + +\item{...}{additional arguments passed on to checkmate} + +\item{arg}{The name of the argument to include in an error message. Captured +by \code{rlang::caller_arg()} by default} +} +\value{ +\code{TRUE} if \code{x} passes the checkmate check. An error otherwise with the name of +the checkmate function as a \code{class} +} +\description{ +Check an argument with checkmate +} +\keyword{internal} diff --git a/tests/testthat/test-bind_tibbles.R b/tests/testthat/test-bind_tibbles.R index cff5abb7..dcd54595 100644 --- a/tests/testthat/test-bind_tibbles.R +++ b/tests/testthat/test-bind_tibbles.R @@ -44,7 +44,7 @@ test_that("bind_tibbles works with forms specification", { }) test_that("bind_tibbles errors with bad inputs", { - expect_error(bind_tibbles(123), class = "arg_not_df") - expect_error(bind_tibbles(tibble(), environment = "abc"), class = "arg_not_env") - expect_error(bind_tibbles(tibble(), tbls = 123), class = "arg_not_character") + expect_error(bind_tibbles(123), class = "check_data_frame") + expect_error(bind_tibbles(tibble(), environment = "abc"), class = "check_environment") + expect_error(bind_tibbles(tibble(), tbls = 123), class = "check_character") }) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index 6e0fa875..c21a922e 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -107,24 +107,24 @@ test_that("check_req_labelled_metadata_fields works", { test_that("checkmate wrappers work", { # df/tibble - expect_error(check_arg_is_dataframe(123), class = "arg_not_df") + expect_error(check_arg_is_dataframe(123), class = "check_data_frame") expect_true(check_arg_is_dataframe(data.frame())) expect_true(check_arg_is_dataframe(tibble())) # environment - expect_error(check_arg_is_env(123), class = "arg_not_env") + expect_error(check_arg_is_env(123), class = "check_environment") expect_true(check_arg_is_env(new.env())) # character - expect_error(check_arg_is_character(123), class = "arg_not_character") + expect_error(check_arg_is_character(123), class = "check_character") expect_true(check_arg_is_character("abc")) # logical - expect_error(check_arg_is_logical(123), class = "arg_not_logical") + expect_error(check_arg_is_logical(123), class = "check_logical") expect_true(check_arg_is_logical(TRUE)) # choices - expect_error(check_arg_choices(123, choices = letters[1:3]), class = "arg_choices") + expect_error(check_arg_choices(123, choices = letters[1:3]), class = "check_choice") expect_true(check_arg_choices("a", choices = letters[1:3])) }) diff --git a/tests/testthat/test-extract_tibble.R b/tests/testthat/test-extract_tibble.R index 1e5ba8f2..aef40994 100644 --- a/tests/testthat/test-extract_tibble.R +++ b/tests/testthat/test-extract_tibble.R @@ -44,14 +44,15 @@ test_that("extract_tibbles works with a vector and tidyselect selectors", { expect_error(redcaptidier_longitudintal_db %>% extract_tibbles(tbls = c("repeated", "fake_instrument_name"))) - expect_error(extract_tibbles(123), class = "arg_not_df") + expect_error(extract_tibbles(123), class = "check_data_frame") }) test_that("extract_tibble works", { expect_error(extract_tibble(redcaptidier_longitudintal_db, "fake_instrument_name")) - expect_error(extract_tibble(123, "my_tibble"), class = "arg_not_df") - expect_error(extract_tibble(tibble(), tbl = 123), class = "arg_not_character") + expect_error(extract_tibble(123, "my_tibble"), class = "check_data_frame") + expect_error(extract_tibble(tibble(), tbl = 123), class = "check_character") + expect_error(extract_tibble(tibble(), tbl = letters[1:3]), class = "check_character") expected_out <- redcaptidier_longitudintal_db$redcap_data[[1]] expect_equal( diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index 537f910b..79c45b05 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -290,7 +290,7 @@ test_that("make_labelled accepts all valid input types to format_labels", { test_that("make_labelled errors with bad inputs", { # Input to format_labels is tested above - expect_error(make_labelled(123), class = "arg_not_df") + expect_error(make_labelled(123), class = "check_data_frame") }) diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index 2a40fe30..b033a2d9 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -389,10 +389,27 @@ test_that("read_redcap returns expected survey fields", { }) test_that("read_redcap errors with bad inputs", { - expect_error(read_redcap(123, redcap_uri), class = "arg_not_character") - expect_error(read_redcap(classic_token, 123), class = "arg_not_character") - expect_error(read_redcap(classic_token, redcap_uri, raw_or_label = "bad option"), class = "arg_choices") - expect_error(read_redcap(classic_token, redcap_uri, forms = 123), class = "arg_not_character") - expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = 123), class = "arg_not_logical") - expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = 123), class = "arg_not_logical") + # Checking for type and length constraints where relevant + + # token + expect_error(read_redcap(123, redcap_uri), class = "check_character") + expect_error(read_redcap(letters[1:3], redcap_uri), class = "check_character") + + # redcap uri + expect_error(read_redcap(classic_token, 123), class = "check_character") + expect_error(read_redcap(classic_token, letters[1:3]), class = "check_character") + + # raw_or_label + expect_error(read_redcap(classic_token, redcap_uri, raw_or_label = "bad option"), class = "check_choice") + + # forms + expect_error(read_redcap(classic_token, redcap_uri, forms = 123), class = "check_character") + + # export_survey_fields + expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = 123), class = "check_logical") + expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = c(TRUE, TRUE)), class = "check_logical") + + # suppress_redcapr_messages + expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = 123), class = "check_logical") + expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = c(TRUE, TRUE)), class = "check_logical") }) From 84c6a624127ada2a8e7902f541b5cc9c3dde3bf0 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Thu, 15 Dec 2022 11:48:33 -0500 Subject: [PATCH 05/14] Update test-read_redcap.R --- tests/testthat/test-read_redcap.R | 41 ++++++++++++++++++++++--------- 1 file changed, 30 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index b033a2d9..0bd37f7b 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -391,25 +391,44 @@ test_that("read_redcap returns expected survey fields", { test_that("read_redcap errors with bad inputs", { # Checking for type and length constraints where relevant - # token - expect_error(read_redcap(123, redcap_uri), class = "check_character") - expect_error(read_redcap(letters[1:3], redcap_uri), class = "check_character") # redcap uri - expect_error(read_redcap(classic_token, 123), class = "check_character") - expect_error(read_redcap(classic_token, letters[1:3]), class = "check_character") + expect_error(read_redcap(123, classic_token), class = "check_character") + expect_error(read_redcap(letters[1:3], classic_token), class = "check_character") + + # token + expect_error(read_redcap(redcap_uri, 123), class = "check_character") + expect_error(read_redcap(redcap_uri, letters[1:3]), class = "check_character") # raw_or_label - expect_error(read_redcap(classic_token, redcap_uri, raw_or_label = "bad option"), class = "check_choice") + expect_error( + read_redcap(redcap_uri, classic_token, raw_or_label = "bad option"), + class = "check_choice" + ) # forms - expect_error(read_redcap(classic_token, redcap_uri, forms = 123), class = "check_character") + expect_error( + read_redcap(redcap_uri, classic_token, forms = 123), + class = "check_character" + ) # export_survey_fields - expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = 123), class = "check_logical") - expect_error(read_redcap(classic_token, redcap_uri, export_survey_fields = c(TRUE, TRUE)), class = "check_logical") + expect_error( + read_redcap(redcap_uri, classic_token, export_survey_fields = 123), + class = "check_logical" + ) + expect_error( + read_redcap(redcap_uri, classic_token, export_survey_fields = c(TRUE, TRUE)), + class = "check_logical" + ) # suppress_redcapr_messages - expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = 123), class = "check_logical") - expect_error(read_redcap(classic_token, redcap_uri, suppress_redcapr_messages = c(TRUE, TRUE)), class = "check_logical") + expect_error( + read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = 123), + class = "check_logical" + ) + expect_error( + read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = c(TRUE, TRUE)), + class = "check_logical" + ) }) From 40a7de9956848c0fadd9bd8e50b3b7f9a2666d15 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Thu, 15 Dec 2022 12:02:17 -0500 Subject: [PATCH 06/14] lint --- tests/testthat/test-checks.R | 2 +- tests/testthat/test-labelled.R | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index c21a922e..a0298ba7 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -106,7 +106,7 @@ test_that("check_req_labelled_metadata_fields works", { }) test_that("checkmate wrappers work", { - # df/tibble + # tibble or dataframe expect_error(check_arg_is_dataframe(123), class = "check_data_frame") expect_true(check_arg_is_dataframe(data.frame())) expect_true(check_arg_is_dataframe(tibble())) diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index 79c45b05..2dddbe9f 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -292,5 +292,3 @@ test_that("make_labelled errors with bad inputs", { expect_error(make_labelled(123), class = "check_data_frame") }) - - From 01359d7fe0114ef5ea9ae5e753c5a1a795554b4c Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Fri, 16 Dec 2022 11:20:17 -0500 Subject: [PATCH 07/14] use call in cli_*() --- R/checks.R | 54 ++++++++++++++++------- R/extract_tibble.R | 1 - R/labelled.R | 6 ++- man/check_forms_exist.Rd | 4 +- man/check_redcap_populated.Rd | 4 +- man/check_repeat_and_nonrepeat.Rd | 4 +- man/check_req_labelled_fields.Rd | 4 +- man/check_req_labelled_metadata_fields.Rd | 4 +- man/check_user_rights.Rd | 4 +- man/checkmate.Rd | 12 ++--- man/resolve_formatter.Rd | 4 +- tests/testthat/test-read_redcap.R | 1 - 12 files changed, 70 insertions(+), 32 deletions(-) diff --git a/R/checks.R b/R/checks.R index eac5a116..54c31efc 100644 --- a/R/checks.R +++ b/R/checks.R @@ -9,7 +9,7 @@ #' @return #' A helpful error message alerting the user to check their API privileges. #' -#' @importFrom rlang .data +#' @importFrom rlang .data caller_env #' @importFrom dplyr filter select group_by summarise #' @importFrom tidyr pivot_wider #' @importFrom cli cli_warn @@ -17,11 +17,13 @@ #' @param db_data The REDCap database output generated by #' \code{REDCapR::redcap_read_oneshot()$data} #' @param db_metadata The REDCap metadata output generated by \code{REDCapR::redcap_metadata_read()$data} +#' @param call the calling environment to use in the warning message #' #' @keywords internal check_user_rights <- function(db_data, - db_metadata) { + db_metadata, + call = caller_env()) { missing_db_metadata <- db_metadata %>% # nolint: object_usage_linter filter(!.data$field_name_updated %in% names(db_data)) %>% select("field_name_updated", "form_name") %>% @@ -35,7 +37,8 @@ check_user_rights <- function(db_data, exporting certain instruments via the API. The following variable{?s} are affected: {unlist(missing_db_metadata$fields)}" ), - class = c("redcap_user_rights", "REDCapTidieR_cond") + class = c("redcap_user_rights", "REDCapTidieR_cond"), + call = call ) } @@ -53,16 +56,18 @@ check_user_rights <- function(db_data, #' #' @param db_data The REDCap database output generated by #' \code{REDCapR::redcap_read_oneshot()$data} +#' @param call the calling environment to use in the error message #' #' @importFrom dplyr %>% select mutate case_when #' @importFrom purrr map2 #' @importFrom tidyselect any_of #' @importFrom cli cli_abort +#' @importFrom rlang caller_env #' #' @keywords internal -check_repeat_and_nonrepeat <- function(db_data) { +check_repeat_and_nonrepeat <- function(db_data, call = caller_env()) { # This check function looks for potential repeat/nonrepeat behavior using the # steps below: # 1) Define standard columns that don't need checking and remove those from @@ -104,7 +109,8 @@ check_repeat_and_nonrepeat <- function(db_data) { "nonrepeating" %in% check_data) { cli_abort(c("x" = "Instrument detected that has both repeating and nonrepeating instances defined in the project: {rep}"), - class = c("repeat_nonrepeat_instrument", "REDCapTidieR_cond") + class = c("repeat_nonrepeat_instrument", "REDCapTidieR_cond"), + call = call ) } } @@ -129,18 +135,21 @@ check_repeat_and_nonrepeat <- function(db_data) { #' #' @param db_data The REDCap database output generated by #' \code{REDCapR::redcap_read_oneshot()$data} +#' @param call the calling environment to use in the error message #' #' @importFrom cli cli_abort +#' @importFrom rlang caller_env #' #' @keywords internal -check_redcap_populated <- function(db_data) { +check_redcap_populated <- function(db_data, call = caller_env()) { if (ncol(db_data) == 0) { cli_abort( "The REDCap API did not return any data. This can happen when there are no data entered or when the access isn't configured to allow data export through the API.", - class = c("redcap_unpopulated", "REDCapTidieR_cond") + class = c("redcap_unpopulated", "REDCapTidieR_cond"), + call = call ) } } @@ -157,21 +166,24 @@ check_redcap_populated <- function(db_data) { #' An error message listing the requested instruments that don't exist #' #' @importFrom cli cli_abort +#' @importFrom rlang caller_env #' #' @param db_metadata The metadata file read by #' \code{REDCapR::redcap_metadata_read()} #' @param forms The character vector of instrument names passed to #' \code{read_redcap()} +#' @param call the calling environment to use in the error message #' #' @keywords internal -check_forms_exist <- function(db_metadata, forms) { +check_forms_exist <- function(db_metadata, forms, call = caller_env()) { missing_forms <- setdiff(forms, unique(db_metadata$form_name)) if (length(missing_forms) > 0) { cli_abort( c("x" = "Instrument{?s} {missing_forms} {?does/do} not exist in REDCap project"), - class = c("form_does_not_exist", "REDCapTidieR_cond") + class = c("form_does_not_exist", "REDCapTidieR_cond"), + call = call ) } } @@ -185,14 +197,16 @@ check_forms_exist <- function(db_metadata, forms) { #' \code{redcap_metadata} #' #' @importFrom cli cli_abort +#' @importFrom rlang caller_env #' #' @param supertbl a supertibble +#' @param call the calling environment to use in the error message #' #' @return #' An error message indicating that the required columns are missing #' #' @keywords internal -check_req_labelled_fields <- function(supertbl) { +check_req_labelled_fields <- function(supertbl, call = caller_env()) { # Check for presence of req fields req_fields <- c("redcap_data", "redcap_metadata") missing_fields <- setdiff(req_fields, colnames(supertbl)) @@ -205,6 +219,7 @@ check_req_labelled_fields <- function(supertbl) { "x" = "You are missing {.code {missing_fields}}" ), class = c("missing_req_labelled_fields", "REDCapTidieR_cond"), + call = call, # pass along the fields that were missing as metadata missing_fields = missing_fields ) @@ -218,14 +233,16 @@ check_req_labelled_fields <- function(supertbl) { #' @importFrom purrr map map_int #' @importFrom dplyr %>% filter #' @importFrom cli cli_abort +#' @importFrom rlang caller_arg #' #' @param supertbl a supertibble containing a \code{redcap_metadata} column +#' @param call the calling environment to use in the error message #' #' @return #' an error message alerting that instrument metadata is incomplete #' #' @keywords internal -check_req_labelled_metadata_fields <- function(supertbl) { +check_req_labelled_metadata_fields <- function(supertbl, call = caller_env()) { req_fields <- c("field_name", "field_label") # nolint: object_usage_linter # map over each metadata tibble and return list element with missing fields @@ -268,7 +285,8 @@ check_req_labelled_metadata_fields <- function(supertbl) { cli_abort( msg, - class = c("missing_req_labelled_metadata_fields", "REDCapTidieR_cond") + class = c("missing_req_labelled_metadata_fields", "REDCapTidieR_cond"), + call = call ) } } @@ -283,6 +301,7 @@ check_req_labelled_metadata_fields <- function(supertbl) { #' @param x An object to check #' @param arg The name of the argument to include in an error message. Captured #' by `rlang::caller_arg()` by default +#' @param call the calling environment to use in the error message #' @param ... additional arguments passed on to checkmate #' #' @return @@ -294,11 +313,13 @@ check_req_labelled_metadata_fields <- function(supertbl) { NULL # Function factory to wrap checkmate functions -#' @importFrom rlang caller_arg +#' @importFrom rlang caller_arg caller_env #' @importFrom cli cli_abort #' @noRd -wrap_checkmate <- function(f, f_name = caller_arg(f)) { - function(x, ..., arg = caller_arg(x)) { +wrap_checkmate <- function(f) { + error_class <- caller_arg(f) + + function(x, ..., arg = caller_arg(x), call = caller_env()) { out <- f(x, ...) if (isTRUE(out)) { @@ -310,7 +331,8 @@ wrap_checkmate <- function(f, f_name = caller_arg(f)) { "x" = "{.arg {arg}} is invalid", "!" = "{out}" ), - class = c(f_name, "REDCapTidieR_cond") + class = c(error_class, "REDCapTidieR_cond"), + call = call ) } } diff --git a/R/extract_tibble.R b/R/extract_tibble.R index c2477af9..7adf127a 100644 --- a/R/extract_tibble.R +++ b/R/extract_tibble.R @@ -15,7 +15,6 @@ #' @param tbl The `redcap_form_name` of the data tibble to extract. Required. #' #' @importFrom checkmate assert_character -#' @importFrom cli cli_abort #' @importFrom tidyselect all_of #' #' @examples diff --git a/R/labelled.R b/R/labelled.R index 078a2f76..b48bc0f7 100644 --- a/R/labelled.R +++ b/R/labelled.R @@ -251,6 +251,7 @@ fmt_strip_field_embedding <- function(x) { #' \code{format_labels} contains character elements. The default, #' \code{caller_env(n = 2)}, uses the environment from which the user called #' \code{make_labelled()} +#' @param call the calling environment to use in the error message #' #' @importFrom purrr map compose #' @importFrom rlang !!! as_closure caller_env is_bare_formula @@ -260,7 +261,7 @@ fmt_strip_field_embedding <- function(x) { #' #' @keywords internal #' -resolve_formatter <- function(format_labels, env = caller_env(n = 2)) { +resolve_formatter <- function(format_labels, env = caller_env(n = 2), call = caller_env()) { if (is.null(format_labels)) { # If NULL pass labels through unchanged return(identity) @@ -289,6 +290,7 @@ resolve_formatter <- function(format_labels, env = caller_env(n = 2)) { "!" = "{.arg format_labels} must be of class {.cls {supported_classes}}", "x" = "{.arg format_labels} is {.cls {class(format_labels)}}" ), - class = c("unresolved_formatter", "REDCapTidieR_cond") + class = c("unresolved_formatter", "REDCapTidieR_cond"), + call = call ) } diff --git a/man/check_forms_exist.Rd b/man/check_forms_exist.Rd index 02d329ee..b49cddb4 100644 --- a/man/check_forms_exist.Rd +++ b/man/check_forms_exist.Rd @@ -4,7 +4,7 @@ \alias{check_forms_exist} \title{Check that all requested instruments are in REDCap project metadata} \usage{ -check_forms_exist(db_metadata, forms) +check_forms_exist(db_metadata, forms, call = caller_env()) } \arguments{ \item{db_metadata}{The metadata file read by @@ -12,6 +12,8 @@ check_forms_exist(db_metadata, forms) \item{forms}{The character vector of instrument names passed to \code{read_redcap()}} + +\item{call}{the calling environment to use in the error message} } \value{ An error message listing the requested instruments that don't exist diff --git a/man/check_redcap_populated.Rd b/man/check_redcap_populated.Rd index 16c65e04..17993009 100644 --- a/man/check_redcap_populated.Rd +++ b/man/check_redcap_populated.Rd @@ -4,11 +4,13 @@ \alias{check_redcap_populated} \title{Check that a supplied REDCap database is populated} \usage{ -check_redcap_populated(db_data) +check_redcap_populated(db_data, call = caller_env()) } \arguments{ \item{db_data}{The REDCap database output generated by \code{REDCapR::redcap_read_oneshot()$data}} + +\item{call}{the calling environment to use in the error message} } \value{ A helpful error message alerting the user to check their API privileges. diff --git a/man/check_repeat_and_nonrepeat.Rd b/man/check_repeat_and_nonrepeat.Rd index e16ca84e..053fe608 100644 --- a/man/check_repeat_and_nonrepeat.Rd +++ b/man/check_repeat_and_nonrepeat.Rd @@ -4,11 +4,13 @@ \alias{check_repeat_and_nonrepeat} \title{Check for instruments that have both repeating and non-repeating structure} \usage{ -check_repeat_and_nonrepeat(db_data) +check_repeat_and_nonrepeat(db_data, call = caller_env()) } \arguments{ \item{db_data}{The REDCap database output generated by \code{REDCapR::redcap_read_oneshot()$data}} + +\item{call}{the calling environment to use in the error message} } \value{ A helpful error message alerting the user to existence of an instrument diff --git a/man/check_req_labelled_fields.Rd b/man/check_req_labelled_fields.Rd index 1872fc40..f02bd3bd 100644 --- a/man/check_req_labelled_fields.Rd +++ b/man/check_req_labelled_fields.Rd @@ -5,10 +5,12 @@ \title{Check that a supertibble contains \code{redcap_data} and \code{redcap_metadata} fields} \usage{ -check_req_labelled_fields(supertbl) +check_req_labelled_fields(supertbl, call = caller_env()) } \arguments{ \item{supertbl}{a supertibble} + +\item{call}{the calling environment to use in the error message} } \value{ An error message indicating that the required columns are missing diff --git a/man/check_req_labelled_metadata_fields.Rd b/man/check_req_labelled_metadata_fields.Rd index 2f3f74fd..40475635 100644 --- a/man/check_req_labelled_metadata_fields.Rd +++ b/man/check_req_labelled_metadata_fields.Rd @@ -5,10 +5,12 @@ \title{Check that all metadata tibbles within a supertibble contain \code{field_name} and \code{field_label} columns} \usage{ -check_req_labelled_metadata_fields(supertbl) +check_req_labelled_metadata_fields(supertbl, call = caller_env()) } \arguments{ \item{supertbl}{a supertibble containing a \code{redcap_metadata} column} + +\item{call}{the calling environment to use in the error message} } \value{ an error message alerting that instrument metadata is incomplete diff --git a/man/check_user_rights.Rd b/man/check_user_rights.Rd index 85e56c86..6dfcccd9 100644 --- a/man/check_user_rights.Rd +++ b/man/check_user_rights.Rd @@ -4,13 +4,15 @@ \alias{check_user_rights} \title{Check for possible API user privilege issues} \usage{ -check_user_rights(db_data, db_metadata) +check_user_rights(db_data, db_metadata, call = caller_env()) } \arguments{ \item{db_data}{The REDCap database output generated by \code{REDCapR::redcap_read_oneshot()$data}} \item{db_metadata}{The REDCap metadata output generated by \code{REDCapR::redcap_metadata_read()$data}} + +\item{call}{the calling environment to use in the warning message} } \value{ A helpful error message alerting the user to check their API privileges. diff --git a/man/checkmate.Rd b/man/checkmate.Rd index 53ada609..b0b70df8 100644 --- a/man/checkmate.Rd +++ b/man/checkmate.Rd @@ -9,15 +9,15 @@ \alias{check_arg_choices} \title{Check an argument with checkmate} \usage{ -check_arg_is_dataframe(x, ..., arg = caller_arg(x)) +check_arg_is_dataframe(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_env(x, ..., arg = caller_arg(x)) +check_arg_is_env(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_character(x, ..., arg = caller_arg(x)) +check_arg_is_character(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_logical(x, ..., arg = caller_arg(x)) +check_arg_is_logical(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_choices(x, ..., arg = caller_arg(x)) +check_arg_choices(x, ..., arg = caller_arg(x), call = caller_env()) } \arguments{ \item{x}{An object to check} @@ -26,6 +26,8 @@ check_arg_choices(x, ..., arg = caller_arg(x)) \item{arg}{The name of the argument to include in an error message. Captured by \code{rlang::caller_arg()} by default} + +\item{call}{the calling environment to use in the error message} } \value{ \code{TRUE} if \code{x} passes the checkmate check. An error otherwise with the name of diff --git a/man/resolve_formatter.Rd b/man/resolve_formatter.Rd index b5bd021b..2e35eaf5 100644 --- a/man/resolve_formatter.Rd +++ b/man/resolve_formatter.Rd @@ -4,7 +4,7 @@ \alias{resolve_formatter} \title{Convert user input into label formatting function} \usage{ -resolve_formatter(format_labels, env = caller_env(n = 2)) +resolve_formatter(format_labels, env = caller_env(n = 2), call = caller_env()) } \arguments{ \item{format_labels}{argument passed to \code{make_labelled}} @@ -13,6 +13,8 @@ resolve_formatter(format_labels, env = caller_env(n = 2)) \code{format_labels} contains character elements. The default, \code{caller_env(n = 2)}, uses the environment from which the user called \code{make_labelled()}} + +\item{call}{the calling environment to use in the error message} } \value{ a function diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index 0bd37f7b..4d9543cb 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -391,7 +391,6 @@ test_that("read_redcap returns expected survey fields", { test_that("read_redcap errors with bad inputs", { # Checking for type and length constraints where relevant - # redcap uri expect_error(read_redcap(123, classic_token), class = "check_character") expect_error(read_redcap(letters[1:3], classic_token), class = "check_character") From 908212aacf5bbe1b82f06fe9c9cdc9f3e11bdb3c Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Fri, 16 Dec 2022 13:31:34 -0500 Subject: [PATCH 08/14] add check_arg_is_supertbl() --- NAMESPACE | 2 + R/bind_tibbles.R | 4 +- R/checks.R | 95 ++++++++++++++++------------ R/extract_tibble.R | 6 +- R/labelled.R | 3 +- R/read_redcap.R | 10 +-- man/check_req_labelled_fields.Rd | 22 ------- man/checkmate.Rd | 48 ++++++++++++-- tests/testthat/test-bind_tibbles.R | 6 +- tests/testthat/test-checks.R | 36 ++++------- tests/testthat/test-extract_tibble.R | 7 +- tests/testthat/test-labelled.R | 6 ++ 12 files changed, 137 insertions(+), 108 deletions(-) delete mode 100644 man/check_req_labelled_fields.Rd diff --git a/NAMESPACE b/NAMESPACE index d9989905..11965008 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,6 +55,7 @@ importFrom(purrr,compose) importFrom(purrr,map) importFrom(purrr,map2) importFrom(purrr,map_int) +importFrom(purrr,map_lgl) importFrom(purrr,pluck) importFrom(rlang,"!!!") importFrom(rlang,.data) @@ -67,6 +68,7 @@ importFrom(rlang,enquo) importFrom(rlang,env_poke) importFrom(rlang,global_env) importFrom(rlang,is_bare_formula) +importFrom(rlang,is_bare_list) importFrom(rlang,new_environment) importFrom(stringi,stri_split_fixed) importFrom(stringr,str_detect) diff --git a/R/bind_tibbles.R b/R/bind_tibbles.R index 4fb96f7b..20abaa2a 100644 --- a/R/bind_tibbles.R +++ b/R/bind_tibbles.R @@ -43,9 +43,9 @@ bind_tibbles <- function(supertbl, environment = global_env(), tbls = NULL) { - check_arg_is_dataframe(supertbl) + check_arg_is_supertbl(supertbl, req_cols = "redcap_data") check_arg_is_env(environment) - check_arg_is_character(tbls, null.ok = TRUE) + check_arg_is_character(tbls, null.ok = TRUE, any.missing = FALSE, min.len = 1) # Name variables my_supertbl <- supertbl diff --git a/R/checks.R b/R/checks.R index 54c31efc..853d84de 100644 --- a/R/checks.R +++ b/R/checks.R @@ -188,44 +188,6 @@ check_forms_exist <- function(db_metadata, forms, call = caller_env()) { } } -#' @title -#' Check that a supertibble contains \code{redcap_data} and -#' \code{redcap_metadata} fields -#' -#' @description -#' Provide an error message when a tibble is missing \code{redcap_data} or -#' \code{redcap_metadata} -#' -#' @importFrom cli cli_abort -#' @importFrom rlang caller_env -#' -#' @param supertbl a supertibble -#' @param call the calling environment to use in the error message -#' -#' @return -#' An error message indicating that the required columns are missing -#' -#' @keywords internal -check_req_labelled_fields <- function(supertbl, call = caller_env()) { - # Check for presence of req fields - req_fields <- c("redcap_data", "redcap_metadata") - missing_fields <- setdiff(req_fields, colnames(supertbl)) - - # If any are missing give an error message - if (length(missing_fields) > 0) { - cli_abort( - c( - "!" = "{.arg supertbl} must contain {.code {req_fields}}", - "x" = "You are missing {.code {missing_fields}}" - ), - class = c("missing_req_labelled_fields", "REDCapTidieR_cond"), - call = call, - # pass along the fields that were missing as metadata - missing_fields = missing_fields - ) - } -} - #' @title #' Check that all metadata tibbles within a supertibble contain #' \code{field_name} and \code{field_label} columns @@ -302,7 +264,10 @@ check_req_labelled_metadata_fields <- function(supertbl, call = caller_env()) { #' @param arg The name of the argument to include in an error message. Captured #' by `rlang::caller_arg()` by default #' @param call the calling environment to use in the error message +#' @param req_cols required fields for `check_arg_is_supertbl()` #' @param ... additional arguments passed on to checkmate +#' @param info additional lines to add to the error message in `cli_bullets()` +#' format #' #' @return #' `TRUE` if `x` passes the checkmate check. An error otherwise with the name of @@ -319,7 +284,7 @@ NULL wrap_checkmate <- function(f) { error_class <- caller_arg(f) - function(x, ..., arg = caller_arg(x), call = caller_env()) { + function(x, ..., arg = caller_arg(x), call = caller_env(), info = NULL) { out <- f(x, ...) if (isTRUE(out)) { @@ -328,8 +293,9 @@ wrap_checkmate <- function(f) { cli_abort( message = c( - "x" = "{.arg {arg}} is invalid", - "!" = "{out}" + "x" = "You've supplied an invalid value to {.arg {arg}}", + "!" = "{out}", + info ), class = c(error_class, "REDCapTidieR_cond"), call = call @@ -341,6 +307,53 @@ wrap_checkmate <- function(f) { #' @importFrom checkmate check_data_frame check_arg_is_dataframe <- wrap_checkmate(check_data_frame) +#' @rdname checkmate +#' @importFrom cli cli_abort +#' @importFrom rlang caller_env caller_arg is_bare_list +#' @importFrom purrr map_lgl +check_arg_is_supertbl <- function(x, + req_cols = c("redcap_data", "redcap_metadata"), + arg = caller_arg(x), + call = caller_env(), + info = NULL) { + check_arg_is_dataframe(x, arg = arg, call = call, info = info) + + missing_cols <- setdiff(req_cols, colnames(x)) + + # If any are missing give an error message + if (length(missing_cols) > 0) { + cli_abort( + message = c( + "x" = "You've supplied an invalid value to {.arg {arg}}", + "!" = "Must contain columns {.code {req_cols}}", + "!" = "You are missing {.code {missing_cols}}", + info + ), + class = c("missing_req_cols", "REDCapTidieR_cond"), + call = call, + missing_cols = missing_cols + ) + } + + non_list_cols <- map_lgl(x[req_cols], ~!is_bare_list(.)) + non_list_cols <- req_cols[non_list_cols] + + if (length(non_list_cols) > 0) { + cli_abort( + message = c( + "x" = "You've supplied an invalid value to {.arg {arg}}", + "!" = "{.code {non_list_cols}} must be of type 'list'", + info + ), + class = c("missing_req_list_cols", "REDCapTidieR_cond"), + call = call, + non_list_cols = non_list_cols + ) + } + + return(TRUE) +} + #' @rdname checkmate #' @importFrom checkmate check_environment check_arg_is_env <- wrap_checkmate(check_environment) diff --git a/R/extract_tibble.R b/R/extract_tibble.R index 7adf127a..5103001f 100644 --- a/R/extract_tibble.R +++ b/R/extract_tibble.R @@ -32,8 +32,8 @@ extract_tibble <- function(supertbl, tbl) { # Check args ---- - check_arg_is_dataframe(supertbl) - check_arg_is_character(tbl, len = 1) + check_arg_is_supertbl(supertbl, req_cols = "redcap_data") + check_arg_is_character(tbl, len = 1, any.missing = FALSE) # Extract specified table ---- out <- extract_tibbles(supertbl, tbls = all_of(tbl))[[1]] @@ -84,7 +84,7 @@ extract_tibble <- function(supertbl, extract_tibbles <- function(supertbl, tbls = everything()) { - check_arg_is_dataframe(supertbl) + check_arg_is_supertbl(supertbl, req_cols = "redcap_data") # Extract specified table ---- # Pass tbls as an expression for enquosure diff --git a/R/labelled.R b/R/labelled.R index b48bc0f7..34685047 100644 --- a/R/labelled.R +++ b/R/labelled.R @@ -54,8 +54,7 @@ make_labelled <- function(supertbl, format_labels = NULL) { formatter <- resolve_formatter(format_labels) # nolint: object_usage_linter - check_arg_is_dataframe(supertbl) - check_req_labelled_fields(supertbl) + check_arg_is_supertbl(supertbl) check_req_labelled_metadata_fields(supertbl) # Derive labels ---- diff --git a/R/read_redcap.R b/R/read_redcap.R index b1caf50c..0a769866 100644 --- a/R/read_redcap.R +++ b/R/read_redcap.R @@ -73,12 +73,12 @@ read_redcap <- function(redcap_uri, export_survey_fields = TRUE, suppress_redcapr_messages = TRUE) { - check_arg_is_character(redcap_uri, len = 1) - check_arg_is_character(token, len = 1) + check_arg_is_character(redcap_uri, len = 1, any.missing = FALSE) + check_arg_is_character(token, len = 1, any.missing = FALSE) check_arg_choices(raw_or_label, choices = c("label", "raw")) - check_arg_is_character(forms, null.ok = TRUE) - check_arg_is_logical(export_survey_fields, len = 1) - check_arg_is_logical(suppress_redcapr_messages, len = 1) + check_arg_is_character(forms, min.len = 1, null.ok = TRUE, any.missing = FALSE) + check_arg_is_logical(export_survey_fields, len = 1, any.missing = FALSE) + check_arg_is_logical(suppress_redcapr_messages, len = 1, any.missing = FALSE) # Load REDCap Metadata ---- db_metadata <- redcap_metadata_read( diff --git a/man/check_req_labelled_fields.Rd b/man/check_req_labelled_fields.Rd deleted file mode 100644 index f02bd3bd..00000000 --- a/man/check_req_labelled_fields.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/checks.R -\name{check_req_labelled_fields} -\alias{check_req_labelled_fields} -\title{Check that a supertibble contains \code{redcap_data} and -\code{redcap_metadata} fields} -\usage{ -check_req_labelled_fields(supertbl, call = caller_env()) -} -\arguments{ -\item{supertbl}{a supertibble} - -\item{call}{the calling environment to use in the error message} -} -\value{ -An error message indicating that the required columns are missing -} -\description{ -Provide an error message when a tibble is missing \code{redcap_data} or -\code{redcap_metadata} -} -\keyword{internal} diff --git a/man/checkmate.Rd b/man/checkmate.Rd index b0b70df8..3a10d15b 100644 --- a/man/checkmate.Rd +++ b/man/checkmate.Rd @@ -3,21 +3,54 @@ \name{checkmate} \alias{checkmate} \alias{check_arg_is_dataframe} +\alias{check_arg_is_supertbl} \alias{check_arg_is_env} \alias{check_arg_is_character} \alias{check_arg_is_logical} \alias{check_arg_choices} \title{Check an argument with checkmate} \usage{ -check_arg_is_dataframe(x, ..., arg = caller_arg(x), call = caller_env()) +check_arg_is_dataframe( + x, + ..., + arg = caller_arg(x), + call = caller_env(), + info = NULL +) -check_arg_is_env(x, ..., arg = caller_arg(x), call = caller_env()) +check_arg_is_supertbl( + x, + req_cols = c("redcap_data", "redcap_metadata"), + arg = caller_arg(x), + call = caller_env(), + info = NULL +) -check_arg_is_character(x, ..., arg = caller_arg(x), call = caller_env()) +check_arg_is_env(x, ..., arg = caller_arg(x), call = caller_env(), info = NULL) -check_arg_is_logical(x, ..., arg = caller_arg(x), call = caller_env()) +check_arg_is_character( + x, + ..., + arg = caller_arg(x), + call = caller_env(), + info = NULL +) -check_arg_choices(x, ..., arg = caller_arg(x), call = caller_env()) +check_arg_is_logical( + x, + ..., + arg = caller_arg(x), + call = caller_env(), + info = NULL +) + +check_arg_choices( + x, + ..., + arg = caller_arg(x), + call = caller_env(), + info = NULL +) } \arguments{ \item{x}{An object to check} @@ -28,6 +61,11 @@ check_arg_choices(x, ..., arg = caller_arg(x), call = caller_env()) by \code{rlang::caller_arg()} by default} \item{call}{the calling environment to use in the error message} + +\item{info}{additional lines to add to the error message in \code{cli_bullets()} +format} + +\item{req_cols}{required fields for \code{check_arg_is_supertbl()}} } \value{ \code{TRUE} if \code{x} passes the checkmate check. An error otherwise with the name of diff --git a/tests/testthat/test-bind_tibbles.R b/tests/testthat/test-bind_tibbles.R index dcd54595..2eaa0d81 100644 --- a/tests/testthat/test-bind_tibbles.R +++ b/tests/testthat/test-bind_tibbles.R @@ -44,7 +44,9 @@ test_that("bind_tibbles works with forms specification", { }) test_that("bind_tibbles errors with bad inputs", { + supertbl <- tibble(redcap_data = list()) + expect_error(bind_tibbles(123), class = "check_data_frame") - expect_error(bind_tibbles(tibble(), environment = "abc"), class = "check_environment") - expect_error(bind_tibbles(tibble(), tbls = 123), class = "check_character") + expect_error(bind_tibbles(supertbl, environment = "abc"), class = "check_environment") + expect_error(bind_tibbles(supertbl, tbls = 123), class = "check_character") }) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index a0298ba7..c969ac82 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -58,30 +58,6 @@ test_that("check_forms_exist works", { expect_error(check_forms_exist(metadata, forms), regexp = "e and f") }) - -test_that("check_req_labelled_fields works", { - # Check data and metadata column errors - supertbl_no_data <- tibble::tribble( - ~redcap_metadata, - tibble(field_name = "x", field_label = "X Label"), - tibble(field_name = "y", field_label = "Y Label") - ) - - supertbl_no_metadata <- tibble::tribble( - ~redcap_data, - tibble(x = letters[1:3]), - tibble(y = letters[1:3]) - ) - - ## Errors when data is missing - check_req_labelled_fields(supertbl_no_data) %>% - expect_error(class = "missing_req_labelled_fields") - - ## Errors when metadata is missing - check_req_labelled_fields(supertbl_no_metadata) %>% - expect_error(class = "missing_req_labelled_fields") -}) - test_that("check_req_labelled_metadata_fields works", { # Check field_name and field_label within metadata supertbl_no_field_name <- tibble::tribble( @@ -111,6 +87,18 @@ test_that("checkmate wrappers work", { expect_true(check_arg_is_dataframe(data.frame())) expect_true(check_arg_is_dataframe(tibble())) + # supertbl + + expect_error(check_arg_is_supertbl(123), class = "check_data_frame") + + missing_col_supertbl <- tibble(redcap_data = list()) + missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) + good_supertbl <- tibble(redcap_data = list(), redcap_metadata = list()) + + expect_error(check_arg_is_supertbl(missing_col_supertbl), class = "missing_req_cols") + expect_error(check_arg_is_supertbl(missing_list_col_supertbl), class = "missing_req_list_cols") + expect_true(check_arg_is_supertbl(good_supertbl)) + # environment expect_error(check_arg_is_env(123), class = "check_environment") expect_true(check_arg_is_env(new.env())) diff --git a/tests/testthat/test-extract_tibble.R b/tests/testthat/test-extract_tibble.R index aef40994..ac04a682 100644 --- a/tests/testthat/test-extract_tibble.R +++ b/tests/testthat/test-extract_tibble.R @@ -51,8 +51,11 @@ test_that("extract_tibbles works with a vector and tidyselect selectors", { test_that("extract_tibble works", { expect_error(extract_tibble(redcaptidier_longitudintal_db, "fake_instrument_name")) expect_error(extract_tibble(123, "my_tibble"), class = "check_data_frame") - expect_error(extract_tibble(tibble(), tbl = 123), class = "check_character") - expect_error(extract_tibble(tibble(), tbl = letters[1:3]), class = "check_character") + + supertbl <- tibble(redcap_data = list()) + + expect_error(extract_tibble(supertbl, tbl = 123), class = "check_character") + expect_error(extract_tibble(supertbl, tbl = letters[1:3]), class = "check_character") expected_out <- redcaptidier_longitudintal_db$redcap_data[[1]] expect_equal( diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index 2dddbe9f..f615feee 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -291,4 +291,10 @@ test_that("make_labelled errors with bad inputs", { # Input to format_labels is tested above expect_error(make_labelled(123), class = "check_data_frame") + + missing_col_supertbl <- tibble(redcap_data = list()) + missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) + + expect_error(make_labelled(missing_col_supertbl), class = "missing_req_cols") + expect_error(make_labelled(missing_list_col_supertbl), class = "missing_req_list_cols") }) From 419332fa488e630d97fcfd99e5e864b782168cb5 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Mon, 19 Dec 2022 12:48:25 -0500 Subject: [PATCH 09/14] add check_arg_is_valid_token --- NAMESPACE | 1 + R/checks.R | 14 ++++++++++++++ R/read_redcap.R | 2 +- man/checkmate.Rd | 8 ++++++++ tests/testthat/test-checks.R | 6 ++++++ tests/testthat/test-read_redcap.R | 4 ++++ 6 files changed, 34 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 11965008..42d21cbf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ importFrom(REDCapR,redcap_event_instruments) importFrom(REDCapR,redcap_instruments) importFrom(REDCapR,redcap_metadata_read) importFrom(REDCapR,redcap_read_oneshot) +importFrom(REDCapR,sanitize_token) importFrom(checkmate,assert_character) importFrom(checkmate,assert_data_frame) importFrom(checkmate,check_character) diff --git a/R/checks.R b/R/checks.R index 853d84de..fa18545e 100644 --- a/R/checks.R +++ b/R/checks.R @@ -369,3 +369,17 @@ check_arg_is_logical <- wrap_checkmate(check_logical) #' @rdname checkmate #' @importFrom checkmate check_choice check_arg_choices <- wrap_checkmate(check_choice) + +#' @rdname checkmate +#' @importFrom REDCapR sanitize_token +check_arg_is_valid_token <- function(x, + arg = caller_arg(x), + call = caller_env(), + info = NULL) { + check_arg_is_character(x, len = 1, any.missing = FALSE, + arg = arg, call = call, info = info) + + sanitize_token(x) + + return(TRUE) +} diff --git a/R/read_redcap.R b/R/read_redcap.R index 0a769866..e3695106 100644 --- a/R/read_redcap.R +++ b/R/read_redcap.R @@ -74,7 +74,7 @@ read_redcap <- function(redcap_uri, suppress_redcapr_messages = TRUE) { check_arg_is_character(redcap_uri, len = 1, any.missing = FALSE) - check_arg_is_character(token, len = 1, any.missing = FALSE) + check_arg_is_valid_token(token) check_arg_choices(raw_or_label, choices = c("label", "raw")) check_arg_is_character(forms, min.len = 1, null.ok = TRUE, any.missing = FALSE) check_arg_is_logical(export_survey_fields, len = 1, any.missing = FALSE) diff --git a/man/checkmate.Rd b/man/checkmate.Rd index 3a10d15b..13c1c501 100644 --- a/man/checkmate.Rd +++ b/man/checkmate.Rd @@ -8,6 +8,7 @@ \alias{check_arg_is_character} \alias{check_arg_is_logical} \alias{check_arg_choices} +\alias{check_arg_is_valid_token} \title{Check an argument with checkmate} \usage{ check_arg_is_dataframe( @@ -51,6 +52,13 @@ check_arg_choices( call = caller_env(), info = NULL ) + +check_arg_is_valid_token( + x, + arg = caller_arg(x), + call = caller_env(), + info = NULL +) } \arguments{ \item{x}{An object to check} diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index c969ac82..d0911ae4 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -115,4 +115,10 @@ test_that("checkmate wrappers work", { expect_error(check_arg_choices(123, choices = letters[1:3]), class = "check_choice") expect_true(check_arg_choices("a", choices = letters[1:3])) + # token + expect_error(check_arg_is_valid_token(123), class = "check_character") + expect_error(check_arg_is_valid_token(letters[1:3]), class = "check_character") + expect_error(check_arg_is_valid_token("abc"), regexp = "The token is not a valid 32-character hexademical value.") + expect_true(check_arg_is_valid_token("123456789ABCDEF123456789ABCDEF01")) + }) diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index 4d9543cb..1200aaa4 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -398,6 +398,10 @@ test_that("read_redcap errors with bad inputs", { # token expect_error(read_redcap(redcap_uri, 123), class = "check_character") expect_error(read_redcap(redcap_uri, letters[1:3]), class = "check_character") + expect_error( + read_redcap(redcap_uri, "abc"), + regexp = "The token is not a valid 32-character hexademical value." + ) # raw_or_label expect_error( From 13026a9fedcb4c970f75fcb7212369516fc201da Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Mon, 19 Dec 2022 13:46:51 -0500 Subject: [PATCH 10/14] use S3 class in check_arg_is_supertbl --- NAMESPACE | 1 - R/bind_tibbles.R | 3 +- R/checks.R | 54 ++++++++++-------- R/read_redcap.R | 19 +++++- .../testdata/redcaptidier_longitudinal_db.RDS | Bin 1087 -> 1205 bytes man/as_supertbl.Rd | 18 ++++++ man/bind_tibbles.Rd | 3 +- man/checkmate.Rd | 52 +++-------------- tests/testthat/test-bind_tibbles.R | 5 +- tests/testthat/test-checks.R | 16 +++--- tests/testthat/test-extract_tibble.R | 7 ++- tests/testthat/test-labelled.R | 27 ++++++--- tests/testthat/test-read_redcap.R | 8 +++ 13 files changed, 119 insertions(+), 94 deletions(-) create mode 100644 man/as_supertbl.Rd diff --git a/NAMESPACE b/NAMESPACE index 42d21cbf..3697fc5d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,7 +25,6 @@ importFrom(checkmate,assert_character) importFrom(checkmate,assert_data_frame) importFrom(checkmate,check_character) importFrom(checkmate,check_choice) -importFrom(checkmate,check_data_frame) importFrom(checkmate,check_environment) importFrom(checkmate,check_logical) importFrom(checkmate,expect_character) diff --git a/R/bind_tibbles.R b/R/bind_tibbles.R index 20abaa2a..8dcffb44 100644 --- a/R/bind_tibbles.R +++ b/R/bind_tibbles.R @@ -22,6 +22,7 @@ #' @importFrom purrr map2 pluck #' #' @examples +#' \dontrun{ #' # Create an empty environment #' my_env <- new.env() #' @@ -37,7 +38,7 @@ #' bind_tibbles(supertbl, my_env) #' #' ls(my_env) -#' +#'} #' @export bind_tibbles <- function(supertbl, diff --git a/R/checks.R b/R/checks.R index fa18545e..5dc9c980 100644 --- a/R/checks.R +++ b/R/checks.R @@ -266,8 +266,6 @@ check_req_labelled_metadata_fields <- function(supertbl, call = caller_env()) { #' @param call the calling environment to use in the error message #' @param req_cols required fields for `check_arg_is_supertbl()` #' @param ... additional arguments passed on to checkmate -#' @param info additional lines to add to the error message in `cli_bullets()` -#' format #' #' @return #' `TRUE` if `x` passes the checkmate check. An error otherwise with the name of @@ -284,7 +282,7 @@ NULL wrap_checkmate <- function(f) { error_class <- caller_arg(f) - function(x, ..., arg = caller_arg(x), call = caller_env(), info = NULL) { + function(x, ..., arg = caller_arg(x), call = caller_env()) { out <- f(x, ...) if (isTRUE(out)) { @@ -294,8 +292,7 @@ wrap_checkmate <- function(f) { cli_abort( message = c( "x" = "You've supplied an invalid value to {.arg {arg}}", - "!" = "{out}", - info + "!" = "{out}" ), class = c(error_class, "REDCapTidieR_cond"), call = call @@ -303,10 +300,6 @@ wrap_checkmate <- function(f) { } } -#' @rdname checkmate -#' @importFrom checkmate check_data_frame -check_arg_is_dataframe <- wrap_checkmate(check_data_frame) - #' @rdname checkmate #' @importFrom cli cli_abort #' @importFrom rlang caller_env caller_arg is_bare_list @@ -314,9 +307,24 @@ check_arg_is_dataframe <- wrap_checkmate(check_data_frame) check_arg_is_supertbl <- function(x, req_cols = c("redcap_data", "redcap_metadata"), arg = caller_arg(x), - call = caller_env(), - info = NULL) { - check_arg_is_dataframe(x, arg = arg, call = call, info = info) + call = caller_env()) { + + # shared data for all messages + msg_x <- "You've supplied an invalid value to {.arg {arg}}" + msg_info <- "{.arg {arg}} must be a {.pkg REDCapTidieR} supertibble, generated using {.code read_redcap()}" + msg_class <- c("check_supertbl", "REDCapTidieR_cond") + + if (!inherits(x, "redcaptidier_supertbl")) { + cli_abort( + message = c( + "x" = msg_x, + "!" = "Must be of class {.cls redcaptidier_supertbl}", + "i" = msg_info + ), + class = msg_class, + call = call + ) + } missing_cols <- setdiff(req_cols, colnames(x)) @@ -324,12 +332,11 @@ check_arg_is_supertbl <- function(x, if (length(missing_cols) > 0) { cli_abort( message = c( - "x" = "You've supplied an invalid value to {.arg {arg}}", - "!" = "Must contain columns {.code {req_cols}}", - "!" = "You are missing {.code {missing_cols}}", - info + "x" = msg_x, + "!" = "Must contain {.code {paste0(arg, '$', missing_cols)}}", + "i" = msg_info ), - class = c("missing_req_cols", "REDCapTidieR_cond"), + class = c("missing_req_cols", msg_class), call = call, missing_cols = missing_cols ) @@ -341,11 +348,11 @@ check_arg_is_supertbl <- function(x, if (length(non_list_cols) > 0) { cli_abort( message = c( - "x" = "You've supplied an invalid value to {.arg {arg}}", - "!" = "{.code {non_list_cols}} must be of type 'list'", - info + "x" = msg_x, + "!" = "{.code {paste0(arg, '$', non_list_cols)}} must be of type 'list'", + "i" = msg_info ), - class = c("missing_req_list_cols", "REDCapTidieR_cond"), + class = c("missing_req_list_cols", msg_class), call = call, non_list_cols = non_list_cols ) @@ -374,10 +381,9 @@ check_arg_choices <- wrap_checkmate(check_choice) #' @importFrom REDCapR sanitize_token check_arg_is_valid_token <- function(x, arg = caller_arg(x), - call = caller_env(), - info = NULL) { + call = caller_env()) { check_arg_is_character(x, len = 1, any.missing = FALSE, - arg = arg, call = call, info = info) + arg = arg, call = call) sanitize_token(x) diff --git a/R/read_redcap.R b/R/read_redcap.R index e3695106..29a380a0 100644 --- a/R/read_redcap.R +++ b/R/read_redcap.R @@ -235,7 +235,7 @@ read_redcap <- function(redcap_uri, out <- add_event_mapping(out, linked_arms) } - out %>% + out <- out %>% dplyr::slice( order( factor( @@ -244,6 +244,8 @@ read_redcap <- function(redcap_uri, ) ) ) + + as_supertbl(out) } #' @title @@ -446,3 +448,18 @@ calc_metadata_stats <- function(data) { data_na_pct = percent(na_pct, digits = 2, format = "fg") ) } + +#' @title +#' Add supertbl S3 class +#' +#' @param x an object to class +#' +#' @return +#' The object with `redcaptidier_supertbl` S3 class +#' +#' @keywords internal +#' +as_supertbl <- function(x) { + class(x) <- c("redcaptidier_supertbl", class(x)) + x +} diff --git a/inst/testdata/redcaptidier_longitudinal_db.RDS b/inst/testdata/redcaptidier_longitudinal_db.RDS index 07e7d0b995e8d6309cae4fb8c4e7b9b107d6af04..5ecbdc7dca95ef57790226a48566c40b3d6d91fa 100644 GIT binary patch literal 1205 zcmV;m1WNlKiwFP!000001MOH(bK^7=SDe3Ycbn{VVL0Z@3_H^-FbtP=TiB(SJ#^X` zIB6V5Nj=zBR+if?7x)N#1vqizt8n4YN7x%2phdRyWJ`{dl-Ul@iDw)=y(hi*^z`1( zioV=J2sKg5X`p6Xkf?oj`uu}W1aDV#GT}fDK(1)FV;VCuCmtsg#d=U;jTEn^$5_)} zR;RyQF#V*MzMD^%-gLyflganrp!|XM09kF%Y6oVk-0CTNU2;KUj`z&&=+2~11^Fag6OVgOrp$|MOD?0APh!DO)OI@Gi60TAKWvv^P-d{B zXA_^Y2@Z52Ff#GIInGlAj4PhUqDlekq$;ss3m;D@i*Uj{o+em_GGDz>NX<$C^^5{( zE=}V~SB9Z!?RjoUSK?#Yew!Qa{;1^xC4bMBHy7y4!rQR7@E>H2PJ_Ehl;(|<7k^29 z3skSbkz>HHm26K6>POI*4B4`%yBlq4$Gmhg5};W6_=s$t)ScL0(9s2 zxZ-sz*9+8!{Sv5cg9_#B8Aif~T$Y|R?GVcP|E+i3n-g?J9c7h3a372G=O``;Gg z?^Ypp>k9E*RdlMRf>_j1?8BlQ~rD3dnh$z~P{9lzDMKFL27F8NfaCT;aERvki8RZ5cF zl;Pu}$m1-y!ZSwGc{z4FN+3*sEi8j}85S=Vfyo`elf#Do#t-b;UjiKqj}j}O!#x!- z8D=h385_X3NAe9|pbcOwKh&&%ioSWC__U6_fsK14-@pdC@33L~RcR{qt=s(3uDK&^ zp~ZKipu7EyMZ>+?&dBVTsR+wo^N*Y$Wys%p5dTC4_CoL)c6j6zh(&pbTK0c*aW@MV zx5!`OYy7D&mr{7Ta9Q^P`wm*N50*bmD! zlEAt}KBPWR85nZ28JN+_#9;U|G#N?ojXn?LjM&3-pD({sckHmgBYon*M0}TVl8W6b Ts&2h~)!bZeVS4?zNS zCqkC#M3_Xn6qTgAY#(7?VLR=%ud>VT`v|?YhqWn1@zEk>*-p`5TVMe)AKxS2dwhKF zCz>xd5JDbmH5h1CTG<8b#)Fa#2ye|)#z;P#Tn6b=X(;z z>`WS3wj%wunyS^aV;PY+b<$*GpN1@%#zcUXjU#$Wcr=O3VtS8Zgsrh1#z6`SjhRUh z3dSY%z8K!Ta7=c@D8}On1Woq9@;DH|{Rs~e*OJfK*?lVcsou`!&+8%DAnq%Lh>pF)Uyi2 zTbRa`ZV?90*>h#cRN|eY{Ye?_{$}KTE&t4wdvkQ=;cd8E_z_uS(%>o*#k+9w;$6XS zfyz&p3J8xV;vzJ@6m&aXfNq74 zOWvmA`V6&Uza(nAIR3aod6L}eY(5LUHXnf4sG?yZj1*5Rk`tiR&yvQL9E{Xk70>_awe9+Go0 z*kk8|eLBrV4cAuE5>i@A!&vtaF>BZIe^qW3K_4<$R%txO`I!Z>sNlrGh{X0F@oEZ# zHd7Lch*5k(f-&KaGG?IQUY;8GG>9Wvruq0>2WA|nC+rNTl1(_KSu!#@w%r*?L~BLC zIarp8sK_A)^lXi|EZ&od9^;rDMT!n5Ij1^$DC!;a_ly>K$`wRS_bV!SOO{oqa44I!-o0B_ublG03CCW5=)@NKa?>U zHGi;~K(R^0v^LYM@F}s=V>DDjtI{NL(ZgCs?``;*kc7J_cw1519if8U+&CQsN zQo-@)l~DKGxx>Zv@}I@5hkqTZ2bsr;_6ER}j;y*7DS_MVGQa$JxS<85zaCqfl@Jk> z*tg0XnL>c1(^)7o4u<@E2IlN6wHP6bZAKdXXg*qsK?6Ju#o~M4k4y{n{sWM`zJsG1 F008-&DVqQQ diff --git a/man/as_supertbl.Rd b/man/as_supertbl.Rd new file mode 100644 index 00000000..bd317197 --- /dev/null +++ b/man/as_supertbl.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_redcap.R +\name{as_supertbl} +\alias{as_supertbl} +\title{Add supertbl S3 class} +\usage{ +as_supertbl(x) +} +\arguments{ +\item{x}{an object to class} +} +\value{ +The object with \code{redcaptidier_supertbl} S3 class +} +\description{ +Add supertbl S3 class +} +\keyword{internal} diff --git a/man/bind_tibbles.Rd b/man/bind_tibbles.Rd index b9ebeef3..d21a9c82 100644 --- a/man/bind_tibbles.Rd +++ b/man/bind_tibbles.Rd @@ -26,6 +26,7 @@ and bind its data tibbles (i.e. the tibbles in the \code{redcap_data} column) to an environment. The default is the global environment. } \examples{ +\dontrun{ # Create an empty environment my_env <- new.env() @@ -41,5 +42,5 @@ supertbl <- tibble::tribble( bind_tibbles(supertbl, my_env) ls(my_env) - +} } diff --git a/man/checkmate.Rd b/man/checkmate.Rd index 13c1c501..7c17a3c6 100644 --- a/man/checkmate.Rd +++ b/man/checkmate.Rd @@ -2,7 +2,6 @@ % Please edit documentation in R/checks.R \name{checkmate} \alias{checkmate} -\alias{check_arg_is_dataframe} \alias{check_arg_is_supertbl} \alias{check_arg_is_env} \alias{check_arg_is_character} @@ -11,69 +10,34 @@ \alias{check_arg_is_valid_token} \title{Check an argument with checkmate} \usage{ -check_arg_is_dataframe( - x, - ..., - arg = caller_arg(x), - call = caller_env(), - info = NULL -) - check_arg_is_supertbl( x, req_cols = c("redcap_data", "redcap_metadata"), arg = caller_arg(x), - call = caller_env(), - info = NULL + call = caller_env() ) -check_arg_is_env(x, ..., arg = caller_arg(x), call = caller_env(), info = NULL) +check_arg_is_env(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_character( - x, - ..., - arg = caller_arg(x), - call = caller_env(), - info = NULL -) +check_arg_is_character(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_logical( - x, - ..., - arg = caller_arg(x), - call = caller_env(), - info = NULL -) +check_arg_is_logical(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_choices( - x, - ..., - arg = caller_arg(x), - call = caller_env(), - info = NULL -) +check_arg_choices(x, ..., arg = caller_arg(x), call = caller_env()) -check_arg_is_valid_token( - x, - arg = caller_arg(x), - call = caller_env(), - info = NULL -) +check_arg_is_valid_token(x, arg = caller_arg(x), call = caller_env()) } \arguments{ \item{x}{An object to check} -\item{...}{additional arguments passed on to checkmate} +\item{req_cols}{required fields for \code{check_arg_is_supertbl()}} \item{arg}{The name of the argument to include in an error message. Captured by \code{rlang::caller_arg()} by default} \item{call}{the calling environment to use in the error message} -\item{info}{additional lines to add to the error message in \code{cli_bullets()} -format} - -\item{req_cols}{required fields for \code{check_arg_is_supertbl()}} +\item{...}{additional arguments passed on to checkmate} } \value{ \code{TRUE} if \code{x} passes the checkmate check. An error otherwise with the name of diff --git a/tests/testthat/test-bind_tibbles.R b/tests/testthat/test-bind_tibbles.R index 2eaa0d81..8c41b51a 100644 --- a/tests/testthat/test-bind_tibbles.R +++ b/tests/testthat/test-bind_tibbles.R @@ -44,9 +44,10 @@ test_that("bind_tibbles works with forms specification", { }) test_that("bind_tibbles errors with bad inputs", { - supertbl <- tibble(redcap_data = list()) + supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() - expect_error(bind_tibbles(123), class = "check_data_frame") + expect_error(bind_tibbles(123), class = "check_supertbl") expect_error(bind_tibbles(supertbl, environment = "abc"), class = "check_environment") expect_error(bind_tibbles(supertbl, tbls = 123), class = "check_character") }) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index d0911ae4..06122c3e 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -82,18 +82,18 @@ test_that("check_req_labelled_metadata_fields works", { }) test_that("checkmate wrappers work", { - # tibble or dataframe - expect_error(check_arg_is_dataframe(123), class = "check_data_frame") - expect_true(check_arg_is_dataframe(data.frame())) - expect_true(check_arg_is_dataframe(tibble())) # supertbl + expect_error(check_arg_is_supertbl(123), class = "check_supertbl") - expect_error(check_arg_is_supertbl(123), class = "check_data_frame") + missing_col_supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() - missing_col_supertbl <- tibble(redcap_data = list()) - missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) - good_supertbl <- tibble(redcap_data = list(), redcap_metadata = list()) + missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) %>% + as_supertbl() + + good_supertbl <- tibble(redcap_data = list(), redcap_metadata = list()) %>% + as_supertbl() expect_error(check_arg_is_supertbl(missing_col_supertbl), class = "missing_req_cols") expect_error(check_arg_is_supertbl(missing_list_col_supertbl), class = "missing_req_list_cols") diff --git a/tests/testthat/test-extract_tibble.R b/tests/testthat/test-extract_tibble.R index ac04a682..49061943 100644 --- a/tests/testthat/test-extract_tibble.R +++ b/tests/testthat/test-extract_tibble.R @@ -44,15 +44,16 @@ test_that("extract_tibbles works with a vector and tidyselect selectors", { expect_error(redcaptidier_longitudintal_db %>% extract_tibbles(tbls = c("repeated", "fake_instrument_name"))) - expect_error(extract_tibbles(123), class = "check_data_frame") + expect_error(extract_tibbles(123), class = "check_supertbl") }) test_that("extract_tibble works", { expect_error(extract_tibble(redcaptidier_longitudintal_db, "fake_instrument_name")) - expect_error(extract_tibble(123, "my_tibble"), class = "check_data_frame") + expect_error(extract_tibble(123, "my_tibble"), class = "check_supertbl") - supertbl <- tibble(redcap_data = list()) + supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() expect_error(extract_tibble(supertbl, tbl = 123), class = "check_character") expect_error(extract_tibble(supertbl, tbl = letters[1:3]), class = "check_character") diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index f615feee..54661abf 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -4,7 +4,8 @@ test_that("make_labelled applies labels to all elements of supertibble", { ~redcap_data, ~redcap_metadata, ~redcap_events, tibble(x = letters[1:3]), tibble(field_name = "x", field_label = "X Label"), tibble(redcap_event = "event_a"), tibble(y = letters[1:3]), tibble(field_name = "y", field_label = "Y Label"), tibble(redcap_event = "event_b") - ) + ) %>% + as_supertbl() out <- make_labelled(supertbl) @@ -60,7 +61,9 @@ test_that("make_labelled applies all predefined labeles", { data_cols = NA, data_size = NA, data_na_pct = NA - ) + ) %>% + as_supertbl() + supertbl$redcap_data <- list(tibble::tribble( ~redcap_repeat_instance, @@ -172,7 +175,8 @@ test_that("make_labelled handles supertibble with extra columns", { supertbl <- tibble::tribble( ~redcap_form_name, ~redcap_data, ~redcap_metadata, ~extra_field, "form_1", tibble(x = letters[1:3]), tibble(field_name = "x", field_label = "X Label"), "extra" - ) + ) %>% + as_supertbl() out <- make_labelled(supertbl) @@ -193,7 +197,8 @@ test_that("make_labelled handles redcap_metadata tibbles of different sizes ", { ~redcap_form_name, ~redcap_data, ~redcap_metadata, "form_1", tibble(x = letters[1:3]), tibble(field_name = "x", field_label = "X Label"), "form_2", tibble(y = letters[1:3]), tibble(field_name = "y", field_label = "Y Label", some_extra_metadata = "123") - ) + ) %>% + as_supertbl() out <- make_labelled(supertbl) @@ -220,7 +225,8 @@ test_that("make_labelled handles supertibbles with NULL redcap_events", { ~redcap_data, ~redcap_metadata, ~redcap_events, tibble(x = letters[1:3]), tibble(field_name = "x", field_label = "X Label"), tibble(redcap_event = "event_a"), tibble(y = letters[1:3]), tibble(field_name = "y", field_label = "Y Label"), NULL - ) + ) %>% + as_supertbl() out <- make_labelled(supertbl) @@ -245,7 +251,8 @@ test_that("make_labelled accepts all valid input types to format_labels", { supertbl <- tibble::tribble( ~redcap_data, ~redcap_metadata, tibble(x = letters[1:3]), tibble(field_name = "x", field_label = "X Label") - ) + ) %>% + as_supertbl() # NULL out <- make_labelled(supertbl, format_labels = NULL) @@ -290,10 +297,12 @@ test_that("make_labelled accepts all valid input types to format_labels", { test_that("make_labelled errors with bad inputs", { # Input to format_labels is tested above - expect_error(make_labelled(123), class = "check_data_frame") + expect_error(make_labelled(123), class = "check_supertbl") - missing_col_supertbl <- tibble(redcap_data = list()) - missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) + missing_col_supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() + missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) %>% + as_supertbl() expect_error(make_labelled(missing_col_supertbl), class = "missing_req_cols") expect_error(make_labelled(missing_list_col_supertbl), class = "missing_req_list_cols") diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index 1200aaa4..7947f0db 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -435,3 +435,11 @@ test_that("read_redcap errors with bad inputs", { class = "check_logical" ) }) + +test_that("read_redcap returns S3 object", { + httptest::with_mock_api({ + out <- read_redcap(redcap_uri, longitudinal_token) + }) + + expect_s3_class(out, "redcaptidier_supertbl") +}) From 38f179e7dc0a21cbb0ba721ed667800b5f2ca356 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Mon, 19 Dec 2022 14:49:52 -0500 Subject: [PATCH 11/14] add superheroes_supertbl data for examples --- R/bind_tibbles.R | 9 ++---- R/data.R | 32 ++++++++++++++++++++++ R/extract_tibble.R | 20 ++++---------- R/labelled.R | 17 ++++-------- _pkgdown.yml | 3 ++ data-raw/superheroes_supertbl.R | 6 ++++ data/superheroes_supertbl.rda | Bin 0 -> 20327 bytes man/bind_tibbles.Rd | 9 ++---- man/extract_tibble.Rd | 9 ++---- man/extract_tibbles.Rd | 11 ++------ man/format-helpers.Rd | 7 ++--- man/make_labelled.Rd | 10 ++----- man/superheroes_supertbl.Rd | 47 ++++++++++++++++++++++++++++++++ 13 files changed, 112 insertions(+), 68 deletions(-) create mode 100644 R/data.R create mode 100644 data-raw/superheroes_supertbl.R create mode 100644 data/superheroes_supertbl.rda create mode 100644 man/superheroes_supertbl.Rd diff --git a/R/bind_tibbles.R b/R/bind_tibbles.R index 8dcffb44..52c082cb 100644 --- a/R/bind_tibbles.R +++ b/R/bind_tibbles.R @@ -28,14 +28,9 @@ #' #' ls(my_env) #' -#' # Mock up a supertibble -#' supertbl <- tibble::tribble( -#' ~redcap_form_name, ~redcap_data, ~structure, -#' "super_hero_powers", list(), "repeating", -#' "heroes_information", list(), "nonrepeating" -#' ) +#' superheroes_supertbl #' -#' bind_tibbles(supertbl, my_env) +#' bind_tibbles(superheroes_supertbl, my_env) #' #' ls(my_env) #'} diff --git a/R/data.R b/R/data.R new file mode 100644 index 00000000..9fca615d --- /dev/null +++ b/R/data.R @@ -0,0 +1,32 @@ +#' Superheroes Data +#' +#' A dataset of superheroes in a REDCapTidieR `supertbl` object +#' +#' @format +#' ## `heroes_information` +#' A `tibble` with 734 rows and 12 columns: +#' \describe{ +#' \item{record_id}{REDCap record ID} +#' \item{name}{Hero name} +#' \item{gender}{Gender} +#' \item{eye_color}{Eye color} +#' \item{race}{Race} +#' \item{hair_color}{Hair color} +#' \item{height}{Height} +#' \item{weight}{Weight} +#' \item{publisher}{Publisher} +#' \item{skin_color}{Skin color} +#' \item{alignment}{Alignment} +#' \item{form_status_complete}{REDCap instrument completed?} +#' } +#' +#' ## `super_hero_powers` +#' A `tibble` with 5,966 rows and 4 columns: +#' \describe{ +#' \item{record_id}{REDCap record ID} +#' \item{redcap_repeat_instance}{REDCap repeat instance} +#' \item{power}{Super power} +#' \item{form_status_complete}{REDCap instrument completed?} +#' } +#' @source +"superheroes_supertbl" diff --git a/R/extract_tibble.R b/R/extract_tibble.R index 5103001f..c3f634f0 100644 --- a/R/extract_tibble.R +++ b/R/extract_tibble.R @@ -18,14 +18,9 @@ #' @importFrom tidyselect all_of #' #' @examples -#' # Mock up a supertibble -#' sample_data <- tibble::tribble( -#' ~redcap_form_name, ~redcap_data, ~structure, -#' "super_hero_powers", list(), "repeating", -#' "heroes_information", list(), "nonrepeating" -#' ) +#' superheroes_supertbl #' -#' extract_tibble(sample_data, "heroes_information") +#' extract_tibble(superheroes_supertbl, "heroes_information") #' #' @export @@ -67,18 +62,13 @@ extract_tibble <- function(supertbl, #' @importFrom purrr map pluck #' #' @examples -#' # Mock up a supertibble -#' sample_data <- tibble::tribble( -#' ~redcap_form_name, ~redcap_data, ~structure, -#' "super_hero_powers", list(), "repeating", -#' "heroes_information", list(), "nonrepeating" -#' ) +#' superheroes_supertbl #' #' # Extract all data tibbles -#' extract_tibbles(sample_data) +#' extract_tibbles(superheroes_supertbl) #' #' # Only extract data tibbles starting with "heroes" -#' extract_tibbles(sample_data, starts_with("heroes")) +#' extract_tibbles(superheroes_supertbl, starts_with("heroes")) #' #' @export diff --git a/R/labelled.R b/R/labelled.R index 34685047..6ea80807 100644 --- a/R/labelled.R +++ b/R/labelled.R @@ -31,15 +31,11 @@ #' A labelled supertibble. #' #' @examples -#' supertbl <- tibble::tribble( -#' ~redcap_data, ~redcap_metadata, -#' tibble::tibble(x = letters[1:3]), tibble::tibble(field_name = "x", field_label = "X Label"), -#' tibble::tibble(y = letters[1:3]), tibble::tibble(field_name = "y", field_label = "Y Label") -#' ) +#' superheroes_supertbl #' -#' make_labelled(supertbl) +#' make_labelled(superheroes_supertbl) #' -#' make_labelled(supertbl, format_labels = tolower) +#' make_labelled(superheroes_supertbl, format_labels = tolower) #' #' \dontrun{ #' redcap_uri <- Sys.getenv("REDCAP_URI") @@ -195,12 +191,9 @@ make_labelled <- function(supertbl, format_labels = NULL) { #' #' fmt_strip_field_embedding("Label{another_field}") #' -#' supertbl <- tibble::tribble( -#' ~redcap_data, ~redcap_metadata, -#' tibble::tibble(x = letters[1:3]), tibble::tibble(field_name = "x", field_label = "X Label:") -#' ) +#' superheroes_supertbl #' -#' make_labelled(supertbl, format_labels = fmt_strip_trailing_colon) +#' make_labelled(superheroes_supertbl, format_labels = fmt_strip_trailing_colon) #' #' @name format-helpers NULL diff --git a/_pkgdown.yml b/_pkgdown.yml index 6b6d7a96..65c8f292 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -42,3 +42,6 @@ reference: contents: - make_labelled - format-helpers +- title: "Data" + contents: + - superheroes_supertbl diff --git a/data-raw/superheroes_supertbl.R b/data-raw/superheroes_supertbl.R new file mode 100644 index 00000000..5645cd79 --- /dev/null +++ b/data-raw/superheroes_supertbl.R @@ -0,0 +1,6 @@ +redcap_uri <- Sys.getenv("REDCAP_URI") +token <- Sys.getenv("SUPERHEROES_REDCAP_API") + +superheroes_supertbl <- read_redcap(redcap_uri, token) + +usethis::use_data(superheroes_supertbl, overwrite = TRUE) diff --git a/data/superheroes_supertbl.rda b/data/superheroes_supertbl.rda new file mode 100644 index 0000000000000000000000000000000000000000..8ccb7134a72d6db59a4b57e551135f4547172bff GIT binary patch literal 20327 zcmV)ZK&!t(T4*^jL0KkKS@rXh4FSf=fB*mg|KxS||NsC0|NsC0|NsAeKtNDHP(VON zKtVu2LSx``SO5S354->XA3y*F-&B2oqwfUz@ZyGBGvELR*IM6q4QWLY1+dfsP(6(v zvQbI`2vSrM&$FOFf`CyWQc&=EPM)`C-2jgD@y_|&w|#t_V}mu-xBvhE9M4syQ1qV8 z^@_cuuIqH=rk8GXrM|uZb8c+y=9G9o?)CN8*S)m4$^tvRecm12-&=dW&s|>cdna4I z`R_{;Ub0i0yIIceoxTp!z4krtS`PS~?f19PUhR|Xa`$FnBdG&R+j~vOhE0_lzK3|^mWzc*mODFfg#JodF1f~krAK* z34{d5ZAi&9+G*`m)OrxrKSF8xih61`rkSbe@{@W=`Y7^&kZAP-KpJQO2AKp1Ac6uZ z=$R*}fChk!02*Wf00000000000Va_WL=s8*Mw4o7MnRJh224NzXaE2J0000013&-( zN$ROWnoMu?RVaEfCVu}_RDfjAX@E>X4FJ)g8Zr$G0W<(K00003K@vpL8WRYUYEyb? zrjX|*1qd(M4sQ*`$Q z@rqXdg5)HX2v!9`QGl|QM%<-Q%M19niH)|lR+V5f(YliXGyVCBn|BD>HvYv71>5`_ zxRpelp^jH2S3eiG26OUlQ!Rb4fn;)`!SzX33u_3rW@ZFfp47yNgj?HUBn2@mRVCtA zDOG6F+9*~eMyVSceeD%YO2kUo%V0dh=D4yf9D@kdr9>mlFv%Sb0FdFPN` zNH0gXkQc61PLp1Zr$KB7h3N>k0`*UCCOrT=^UR0Yw;b4>GY#hu}u z=I1vrIP|@)?_MVpo$1}D8Ccs~H=Coha_-x1=5v=hnP)M!Q@jjz^S7?)TIV|5ImLG7 zvul~xDSM||c@f?ZA2#va%rlW}if-YV<>qIbdvtesop}>;alKHNH@6pbfV&0WocP?< zcKO%Coy?|Vce$ClhFi2`;oQs{3xp!xZXFDE5z2N1Q-B>LbEa}Z%*IIBdlR*Ag3<~- z47aO0(RfI_1?(WAbFu@tW<}@=(Kor-0dNK5p%m!~I4?-O7qArPK~9o&Ov}kTxt)Ny zBwj#7?;`d9y&x|@UW?cYK8cD;t29Y61d+&1kkz1BG@~X%Cb_1j)-PG}SN)$nxvo|& zaOJ4u=XuLh-RH}TkACCbY;rlOIX*5uy>FA(-^VLG-f-m?&h_SwYB{m$aOTmu?d$L6 z*-t#>qneItj%n@ZEOSRO@>tyXx#vAOb6b`&LI0qUN!3 zu49qSM=CjElx}a8%8pcA=8kPVyyh=`ZaJftIka-9-urRGmN}!}taE7Pv|PDd=B#s5 z-RCtYBIgccmZ-ev$Ea;#kBa*k2WN6n6EIjW9YIcViaEgaS^ZE`ti<+I)8 z%be73<&%~S2@V# zju$ytxvJ$+%||LZtrs~QIC94}E?nOF=ckt{+_uLmH@{qRqn6m_v|Q$+k@IYGV&^>i zcTv-UA>`tLC&bA8O<_ zRUh|0vt$1{J`{iNQFg1RXzh;e9Xq1$b&lxnH^W_bV(s48>DoI-basx%Z5MaKy6&j$ z9kh2v+jQ-*+edYd(b|sD-DvKP=

zcSm+Rj^nmB!)vb97jE{ncE@dw>N~7=9mjFI ztEY7x*zIGwqqSJ>J4bQ87TtGjcWOJe9omlCH^Q#FXzfp|^R#^R>9<|hJ7c=Xb&lBS z-D2(CqqfIwqqecy*zU3V9Y=O9_ic{tj@2Eij_Nx{ZLxOmYCEbsvDn`Y*KBrsZ5^$PuZ34#)NhAfj_B>FJ%y9lW=8Hc*hwu5 z!lNf{mBM2po$}HWOzk$b#*9VF@?~Z|*SV-}mm2y{5+uvxlpM89%fL6ZO-Y0kswO2m zgfA~Dd8v=sPdb#gl~d{Gt<%%iWvzLQwYu>NcUX&A{G#%atGqxpE=q(N$s)lLkXxC@ zTt?fC3~Q}0YQ>5dmh&)hDD!i8TerQlj~=zmsxGitu2U_CF6b`N$D$eUw+hz2yxcur z$bJj>Nl(4&cOm+I4yiLo)}Z$N&R+J(sIsk-Lh@;Sc*7Y}Z(^89u4(TEiyJuKpFtpfeHHt~4pUtaHxX=2gMozAz11t`U}zK!bmtwy!m zWhcux@Z%ILw#4pe+WWzygWdVjxY>-UmAncUJI@_+R?41&u*8$*kiAA?@00A z;^U_sa{VzrHgMs3I(EH!JY$XhT7KQ_zGPi#+Wo5gD{bR98&?C${~Fe|#}~I8Uzobt z;;r*ui_c|kEe~qOrC)pdFWk zg=p35HO6BOxLf-6?dP6-eRO?Gr>7RrjyukFuCX}qm+$Gb`#n0>81lY#wfpu^0wI8j zcrj6t5e5Ld5P%GTf{_8`6iEv1Ec~BfP`Lv2$Cwn z-bO%J9#$-fkr&DxOpp>CsWGZs>sw~-$~Kzrw2e*mw9*U{v={V1KO&!&2i(8HQ@uY- zP3Zp(KQHqr`(V)c;Cx%3f5#~op}1O@6>&nOlz!?}Q}=-JH8QiB&m}epDys%Z;H}Gw zCHnT&RIB;&O?nHv4pS)GKal*6VLb3gFK#a1!tnugfjb#9!qfIEEI?4hwP+^GR1Yu8 zzFCB&z+eqCdDI>=+FUzjOu*I+TB$Nc;YwsA7-TMnZnVcmL3b`c(f= zuMhRB?IZeNe#!xHAKFL9?jU>rfDiT$?T7YX+z0Tl;siav_K)uV@W1Xs`o9?dL{Inr zhwq{P0T1}6U%Ni<>3jb!QDH@c#6L0sEK4RTM#( ztRz5k7yyV_P!eGLSAPcMB*G%1LLiE=D5wk~AchyvsG5?d}U=RQh$3?6v2=nvq&NomIZPoF9-O)r7W_jLzU(xvZg7M9k_mwrk9g!d?U}AXS zOh2#rz0SkPs7VPpX`uvDNo!zK{jIwRe~MxX3L^aY(g=zVXJ`@UeRiLfGws|Emws_)_L@wL%J6kV}YQ5V0smc@%5(bPo$gr#=#0gjiAY%g=F(6hQVOSb4CLs)DivUnH)>aUx z3k-hCB_TD&Vh=f(z~^k}uMh>B&B-~Ge4&|OJ)(h*x-ZperF=qqO6ww`#zhy^EKurS zR@w_%-_&$*&AR69>GRF*oikjh zdQX=MWvbn{XU)SEt9`B)E9&*g*1ipVYnOcAZTE4W$ya=)K2q@b?Zax|+%3D2x@y@iOJC4`kt&_z7{o$@0oRW&%(kyiU?dfQVlaz;X!= zS_lQu+pm09dFQR)4D_dycOR9w@}EYX7dGc6IIU}*Ti>hoY$3J@AtNFQBC-g`m`0+j z30VNF4&+lkiV2y9Ch+9qrld^~@mO1aK0n~c$oxEOJc{_a?smA850q+* zw6MMVo!@teVlNr4ZG&jUzOD4(ZY;0Ru9y-iNFgF2*953Ypjxz=){9yyu~v&~7Ks9W z9ZT$e1by*1ZYQ*hgyay#~^l4Z7>%ra3_ zSjIOqnMJn~64l+cN4K`loxGXrmo&7aYEqVoOG}tse$#2^IE#w5iwePgTt<8w?IgFx zwHmz@SA%O}tZn)wylS=~2GR-@sU!uFKoo%r1GXqT)2 zjjXl#;CZ$wzdM2P+?XhpqgnN`RTW!GqJkoxZJ0EnSz8a4D5@3of*a| z>l<12e*8O=DE1Fe1uvRh=N$F9GPG#d>B8W& zua~Kt+jX3Ch|Fs%nUNl<1!uzU^ zJ$dw=?>*i0t?pHgQAUc?n`25yECmIS50|e)=gVob!yB!3nWIhC{3X}t&3|ch^R4ji zZcQ6^4KqDZ{lubG?q1-Dh4JnLV|3xQ^FSxatrrTV;QCaDfao5b z2v5_#Vhg+9F>BOBSbL9ozlTZ3kcoA#GP7+GLCv;%5e5n`wcS3?chYlMQ5SNr4=u5y zGH+moV$L@TQ?QH6{5)uEj*UR=UPW&XRQalE%9urDeDHr zy~J+oWlj$H7JJ?3=JT!4ea-C&+ZH2&3llYn-(H+@_KrCC(QPiBFBkT2=(iiqvR^lF z0WqV{Yo_$p#*^0C9|O46an7&CtOmI@sGL?z#wc^f7`>_idFGjz?(3Fmft#0IINUEe zX|bj%)usF(R=Rq($!%#Zbq~vwcp(@PgP<4xy3O^DvGf_qqJ!znaWeb2BC?B!r@uaK zY6>;2t0lM6VybZr7+{#2aGcXH^~>C4=351e2TF>C+eW1jT@wtxsa(8aFEb!GTAPja zxlAwB<`}Z@=AJV=vpd|6Yra{YO6gY`l;Ro{*X+_`1r{tLa%R^+?Yi-o9PY>dQoR!gM_nnZ!91a^-DnNJ^q^;Du{1fy-|) zUmbdB&o{Y5bu*`PZ6|VvW-NhT!$inZ^=AhFya80oX9-&jKsOFzgMl|sX+CSbIUe+^ zTds~m3WuO0ZAXmPZRe-Hci$u{5u!FIk&a(j-w)S5n;~tO4~{GYQD$URsA-7QM$sIq zkqbn+1)`2|BoP1-7;lXR^UcoEWi4B>jb-EnS;&ERaWO1wK0LoCo@329)9TQ=G*KT` zUAW<~`)u@{ygc+Ki;8(z&GnnZkFMd9mMi8aGZrvv)fY(05fc*_ezPWzc1<%K2WaD5 z*86hjN$(#6-(D+cO;PCd<^z4tMb~^(40tf^>41o&{b9H2Xi=v)TnxbU4leZq_#}t$nA1ELp1JWF51AXZQ zzcYS&^8IBwEHrxM2pW=hIdapSMsYR-WS~hPoklGAp3$daSo8^kczJ>8S(>P5FSOi; zGi9N5$fpl-1mhGT)FO^lV7@mzaeoe;{{F7|55XMSbXl0=h~D`3_nIRBw^V{wFFzUY zPl@!MYIv9-bKw&>z%`t1*~NV%H5Z7aEa=%#d3D4yG~Jc%<^^D4K3O#dM3}7KY{D-2 zN|P4RR(Y0VD<;x{kyJS5SLN{Pl&L&(FRgCdIiCHL^R(!?<;}~swAAyQaB_gWp_xM` z0E;mcMX6+kS90FpchQI!zm7cnE$f~7W2op~7NL5=WDBNX;fPM~enYT{pxGM8P(orI z+#VoC6@?-}Jfy<+fNBN_-9tNC)o4=LwoWdCQDQ?25=lb$PRO9?mCJ~jb;BZiIomaT zt?`B0eArF-eSa|F57*PgU=yX62^88cL$o^tK!VRhFQD8O0Fgl^iGfC9TjuN$^VA1tYUbtT8zp%2ho?J!D&zsl>64o$6 zJeWJ?W|w*m(6eBH#_Ba=x=~b|;slWB7NQi|Gnm!cPH&Q=iM@lTWtt-hS=I!qzUsOp z4P-5i+3{QkV?NZwiMEn~v!R1Va>ZTc;36bQ`y=OYQEQ-#^KJ`lb2l!s zyeSkU#5sZDhDanGFGsG!k_VBS9iM{u$_jHz zi0O(qMUY2iMy2sDh-VZ-D7V2yf@VktVF)%wz?&SlLdUWc-3l`>J+rgJ7QmqNfvOYX zAx>rC#4h;lU?>*fZQLys2oQyA)^Re6xpafLM@9Fim4}n<-Zoq3jSGHkj!OJ95zY{eUvJ!?}w+;dz-6IyK#7dB`WvM_hLsp$gxFQO{Wf2(8 zNUaKpC@Nl1(!?KC|2pFJpKUqL?lZdO1%;HJ(@%7=u3;#EnF7h{iD0O~p!k$rknZf~ ztq3T3BNun@A~v+`ir#SfmJs_p?4x|&cfKrGfJ^NqI&1XRZ zL8HmU3^)}1qD?o?G&PkJa@;OD;G)FR)I7Dsrc&cH#BGDaH8U{GwiM;QX?w5A`09CQ z9_73*UrzaAjiFl-zLMg4%jV+Y(Uv*9!@6+s!j)B3^ARVFM80w4lA9V~K`bd}hAs zIGhrtb**s^B{^Iq9E42M)JbuCHcjPa=8P-{#hwK-69uezc!`>_8ml#;VXY&1%%O-y z)Z)$%b7!YPh%tl+BGHGiB01t?qsgH=K;tsptV^eV z8bSwOou1g2Jy%HzG##FfP#kX}Y%LC5l4R+^dzUD0EIh~!sip*pCZ@R7DZBH^>k7wZ zn67%Y$56pK;&b7=hU<9TwtR1_F~C7;J(^V=0;BVj|K;LPV0#n64?uxt-{uB2(rLGek}X&>&&lWT?y1WNRcH+%sEI zCS{(27eh4+7-Q$wZ)X%(LO@)}!2+9SvRv|+o^zY;eBG1c&iO*IVH7L#Q4NE{;}zmS zyxp@17eIhQ1PljPI~N2u6imH*d{^L}A)R`gxv7!QSRu7n7VoYaVaanh<{s#rOYdsj zC?{#ACM42iMPgMuhy{$u+$=h5)7d~8Atoux2SrWuNp6;G$s#3?a)||Pi@eKh;RoEo zABuYQn=8Agrg>%NR|Vr;_nB7mpkX#+!ve9Y3S;2!xV1~c0mu+Tg1{F* zV|64z!gos!~D-kY~OBTV_Db5HYfN&515hMTw2qJ<5|Hz7p?cp8_6FU_R062h@6xP=~1pz<3`6;Cu-95j-9Q zRbKk5+X>;I1zy;7)Cv_8yipb)fO#T@vsmi@)~2uxZm}~|LC8W1ibNOT?|*kE-XEa@ zL-OZ8EdcznkKZ4EaVt`{@2IOxpr{fRDoUd}R7Oh)UzG#s9ML_1{L1@J1@IRC4EzVc z4+IYcJQKiQ1HebXJQQ}jLJrUYur>j(7Q`C>TMdgZ7ZJy!sRm~y6-58kIw!`0p*jxG zPqjhh^1A^ONJ%iPvB(?LP_~@3W_m8mPL)gMdQ9Y!DmK@oz~;EWJ*1}0B}XY@DOpn4Q3QgFM!4X*W+o*J(Y-u*csGjh^UoNVUMH7>&pcCjyvxUslp!Qf zJUnka^z_~=QK=%6N)Jywl?^XEypzS`#y~a{p)is>^Ii%JTgEq%ym;|Zw~ZTOo-YlO z5jKouJZ}{v)5~~_dU@bzjS(761W~+4k0t3M! zSkiM*4SIUFqO0$9sBSF4V*+;!0W8eQ|NSu9>hb~W)*q(a#jIr&5{(Q*H)~nVC!1RG zEJa??X=Vq*kOMe=MSiRNE&O|Qs>FFN-fwQy`3&80(qLrA3%-s8S7NAg8OU1JD2T|k zq!P6yqYEslZ5W`zKxkWIYE=QT3+=w>zdI0xDpD1h5()Fg^JcE82?cOO`Y}L@=C>ha zvgG44y0h6oE)D48voLOqgo4F_L1co2k}zb983>FdT+x46GQ^!zPV-+AFzr0D({H_r zCmV}^h;oudg6D=C&%CmM;Tgs&3DK$6ZZqzO-k zx@nsf3KlgQWLZVmqh(5&8@A&IExa#ttH6kX`Cy_iBcahAiu4ztFGYF-r~n^P!2Grp zQQH_mk=+mi5i&?Z`MkXz`^T|}aob^3&qXjJj3Ea*0E(-f z0-_z1kXZ{uI6&l~R<7Qnza{hacT2g`)zX0T3VzrHw6la3U_PoA)G9;GOK~B2=FnSB zsM?XWBgmoTe1qgr@(TGMAfCFY|0nrJ-k+^kKwmw5zYL!2$weynEP%OMfCJ%*jx(iI z;5-+AoCF>U@DqZDU?$=S2eHzGHGbdwZL0mmw!wYFYsIW>8aBp?jaA~;jYcwRDmKN4 z#*4WVV(S6-LpvB8zNVku9RM zQ(Frg7TY8nYBts@X2{zb)NK|lmwwP^=w#Ka46k6G-M$}r=t%ai4t2KtPwX{4Ro=B`h zodkc`0xTU?+()X->sFc@MNDBg?M31i92uG0J#xZ2(aZ`0po}x-gXvKIh-}ML+p1XS zzjVMzP_YacY9-hcw(v0+ntXC^R;oh)FkloDGcp?U*Uz1cPJ3``zQh4G+amj{tCS>I z5LgB!nSm@w5mO>c7Q{}}{5lFVyn4BdIGc4+4x5D&dS{ifjSYO1Pj~#PAKX+$f{9UG zLPP!jF00UVN z)(}k~Ck@mV1j|mZz9|9QcdKzA@);6B79Uyx@LNVH0gW4i4dfPD%FJ`0_uGRNGFeqd zIgcfB(Q*6;I@K-;=YGiyB^ipaW_lQ*0WgpN=3oNJ%~K?PTkQl+q(5|Y>(3<%aO*`4 z1RMe(N{5LNi|c@f!9~zj-~qA(iKSMqT66l`)XJ||Im-ZpRH&L?r~su6ZnG^})P^#w zt5704ZjM5UjrYDpI1~8ExgOn^F^w&2DDBiOTSYiseVuTSy1?4ObfOzY&!3{{i(IC1 z+48H>2JS#_+kSIii7w1d+O=!qFLFJ~_bPV}avjKb4r1+54_~m~*V&gU8C<#Lo_E`R zIb48&&VmE20Ebp8~O&NH-6y)R`!16+^BHaztG+ z)0WOaJ}S59!wisls2bSY3nK8wP^xM7E~#XV5fBCuY!Vk*_dBay^>HJOwmU;b-S9w} zN6)C~c5G*m7!QSp#_Y)uDaEL%AxHtHe7EGbj7#wZC0o?YB?`7;*RB8t?pM;R3UFN1 zwpVjORiN1hNJ2=$JF>>pArLoA0&fLeTa-G10C!NRm7bngjHqsSCQ+&SZ}^`VskP#`OR z{M@Iuksztqwq%46j#B~wdJ@{-!KyRPNWloC&_`ArMjJ~^X#}fQ8dN?nciZ-Ydd2%x zKGW!5IC=#1Be73F=z0gxdKEnj<~+;hUoiQPphxKD*}Vg&sE=2IucGT!-H@*MfOhyd zJ=5TqFQ2&6r$3A-aRby3$_BB!90LS$ZU87143#zi5AmUn7y!;l4t7v;*L1Dvj;=t5 z%M>_f8O=PE`Q`vhB7cYQbze@+V`V*M@{Z*-Y@F(SFkDRci%&axgIwD+-^#*^SXU^F zii0AJBGiBa!EswAG^KSYdrU7cDidA-gE!*iy@asI7JgQHJ#AnFmS7=Zk_Qq1qXLp- z07QdIFGTvL3?>0tjdBBAYZvN_voK>YzyM+0xIjJ`s8=1i>34jvRdUm5V{OfDo48D9 zY*Y}~yWK1Z23cpa#j~d6f+Cqjyc2qbAQlX8RM{|5S8#}?lNs7O)eN-YlO#5YT*L!? z9JSmACODguuu}RWyMa>32Qfg35;2^zmyo6qtZU3Ln#g6c$kUJz;02I+Yd}Em0o_Oy zF+hUL>}XYx5}G)qi>{VJ`qYYi)!dS*RH9gH>DM)rPCa(sZRZPX-K&Tu&>kfYVMBT; zy#|nVWNgv1OxwnYA3#CM{DBN=&ne1KwOj?Zo5flMcPNiy>;Tzwe1Rg8G6l5TbC$;@ z+UDG3S)i6#RWU{BAlQ+xTN2r^0BlQQ2_#chE^BOzunwLH19$c74&0g#B+&==(^J=cZ0dAwNTvd_slD z%!d+$3yliD-5m@?1N1{9XwcBWZUZ*oeLtxGRRe@RUFiKIn1P|FYgg%q)g+bw+_Wu> z{`eBevlM@hbP0Db9Gwaq!S}nJ>%D#8Zs`N5L-B{aedoMA>+e0{dr;F=S_q5>WdD8>eT*0#!_HC6T;jHu2(4h0H{Hc~;Sv91?u;^WWO4rkXgpx2pBj>xt?@fVy zElJqV??s5~R8ud>OCm7oDY*3&Tv#ZB{clgJ3xl%rP~-RT%=@u>aZoR}4&Fx2lRIIa zG;WGiI%4*VRr6=Pk_BIp#GSERSsaXG^H&*}keK>FK_*8Nc--J~uF6&Zo}4!AGc#M4 zk|mWdRwEE`EEICg%1a;#2}uvPXUiaPK2$`)E$%z;jo2~-MSsQO@bX=32?-L#77Zk9 zV^K*Bk+U`pMoej%h|IK^B9lg-$xOyfL{X%%8Yv2lZ5jx&WQ!V-(GxUU3kYH`XvMQ2 zrUXSrqZDGrGZrBuAQ471QX?v9Nw5)uA}bRNff-1WN=(X$GXfI#{XeB|z5HqPHLb6m zq+EmpiD>kw)<6(jyDpf}2m@AU37cai#gfOuZ|CCBjUYz%I;EmOgH$)T6-_jRjSZm4 zAv*rPn<5v2$b~>583g+f8iE|QQF<*KXu(l!?Jw1}y$0LqdFI5_ogHV^%AT$5exEZ~ zqNt{p7TO|->6nHgSaaII7D+R|Pfb{EC)|_8aDB_*Aqpj#41kW1 z5a!TxW+B@Ys9*}SQ+9fKj$0QD7b_OgFv!jM4PJ{NfboYW%>;Nu@IWxhMehfEXj92byk2T9KtpvKsKtaxH2{7)a+EL8amJR=ce(U)vUd5n z;c69aZLJ$y6-tX*p;8r+B9Rd%DfL`NCZSn|T(aEd?%q~8MoTflnB12!$&9qYMoN{5 z5*4IE_DwU0b&dxd1}b%>u_(0=UdjQZE{P(*2Jj8LYa!}x2Y-Nvw76ig(U~MzXn{=p zd)JuxA)+Y>a*ZnqoJ&rs0$LAdkG3mkO`O)7q`R0V1V9gT}G8*sWPMO}34-me#!Rq#~#X$cU%u zS>)=!SyyPv=IL|-`@1f-i>4^CH41u++At;69a`xDBt*1Ds-+~7pjri`h(c2h+9;e_ zGF0EVk!*5p4lRHI*^u)*n1U3!T%olRMO8x@?5chKql#GvkO`T43Y>nD$9)wqQ28oP zkA*#)78`4vw#$)L3!KEuCQ)kdE+~pSpv6WAD-cvwAcB&GEKnETKfSwf_vV5UKdlqHhUL=f}hzAIiPYB6YtFjye5f{82C(v9oEQ5a4# z)vsI(AainLV4caRuvjd(a+#76=D2;TY8a5$5*{R%x5$oAfqbZl;};ox3`n3BhDaF; zNq8vSpa2ZgsSpexFck|X7R8GLfdmu5v?pXzDX4tB2=zZjiv?wQ>3|T8I6K7MMTlS{ zMM5wbD}57gdbKiT0|uZ#bSnQ5+p}5#Y%pj50oE|&*uC@66d=4{JBvl2A2(dvzq*)4qiC=DW>GFc9n&;g#)hNie(_j~wmW+WS z$OMozg>3Y@oi?d}V|k0KRY+m0jq&syw#00SVSUhA19jD=1R2Y!pZ` z-IlirzgC8Ng{(^7m`N4{Q=Im1zlT^p9z^0>l`Qc6Wb zpr(FyJ3;k3i6z@YDfUI|1Ou&mlL94w1P3>Xmwff7Ylnw7;7PXG`wwnAOW>O}-m5fwrtV9ZleVJW6*VH1^BGO1N3Cyh$!Y$8Lp# z+mLSolLQh#?TE-AgJ|xp^0E*e$gez52ZADz6xgVBW5!|8DlCqe>wp@LGpJPyr<@O} z42nkm7-isi_W*;(ysuf}9}FbTN3!T0=!A$!J0OcsyG=0L4!d;rYW}oLYV6h<=i})3d4<(vRk?l$2>|d8uKwyet-*FKPY~gzcvCkYm`_7NqS0Ai&Cmh5nBKOz zkj&P@j8i;(l8{@QSC^910KjZq`CM@JKJRpf#iiW&j(qUAVNgaZ79>297JOK!iv?UK z&W-aqehc&7ZJ{!xc9H-PmMn-USOC8rb&w1a>(-52e7iORFQRQkQUJKQ1{%BPMz@~~ zl@%tOjP#CqL6d-u6r;!6+GPPDs%sSY3)1sfgcKw~KnD<1(Aj+tV)j(PzsM=)=iOo9 z%L&fCfl_cK{2*;>td7$$HFh%NC4$#$wg-9aSnvtGj2R>?ByrfG0$HwQlRlCUYnuOd(>G_rBmfF z+b=LbvGZ{J*a7T0j^XJFBCid~M2t`g8@doyd?rKS-!3)fL;!c3`?(MTw}LJ8%HL{b zMwqDxqx3`;(FH=$L2^MRB#9wt7KC_l&iL0kTeqz zil@s;Sbs3f000|Ibt)=zs1MkK_Al7KVh7kE_7B;J967;%I-yL72%-dtj;NIx0t*5; zNJiNTfJ**tmBf$=gc!&Q5Kw@j5ja3F;-+e123Da=foz!t{^M_O_{`2As^yEIxaHmO zlTLsN9m^sBQv;KOlXz7X3?`h@tj7h&USeHPGD9>R^8HO0VWT#xAO~MAlLJgI3KX&A zuqxkIavpFbgn%tQc<%B`A3y5Nkpe z-Th{<;PC`EIXFNpbw?}SA-ceM`J)}z5yqt34KgyK$#UGzSIHBqD)TCvA5) zAeeB8E$7f)1_7|rfFFUow((RutzJ{9h*P2{8ZM!PxVoVU6bgzISzrmY#DExqNPVTj zB1nUUBe-+`Owh>b?Y>B4^;g}eekC3AKyGM;dJu>SU#D9cDAWXMnMgnp7Ldw_RM^ud zOIWE!)NK)|v`K3gOhv4i*wGPDi$#)(QcA2=HpWw0Rf}s$2*FM_pQGTdUygZ8POgE- zBsnm9^@=5P0xnPm!6=z`DAgD~M%4Aje3QehXmHNk)elsehZ8EOR%$K<`3eYiZl`w` zJx~Zi9sdd8@mrg+s1sNq8~g9Sj{>`_G7up7WzoLfR;#+LzI~47o-cwO;0B<{E8P|h z``r&*EM|DN)`8_=(nuRGL1-v!iQd~tm&n(XjX=3;76Ri1!~jUUS_@TzMj3=qqo!@G zN;}(RI{0$1$b0&@b(J7qY6%|_pl8B>FH#(`dgp{_q9!@$dESYi6WbpSB*Uy+Me8%q zZgIkbJL+~x>=U%Zvql@X+G=^@Jr<9ic%d51mYs<3->-vS?b25=)3-iwG;lcy%7B-| zS9Ae7AjkxOGDrvp$b~>8LP2>&5NHq>jEIpya)O3we&r2-tI>SNM?k0)XaQtlA#7tc zKw1|Zq})J-plxF+ul7nev+R;GMn(shpHgY;(4)^4kp@8rnjmw&br$2E-w;EkcO7b- zVu0I3k&u!|5Fr4;^y8L|^)&zsb%%>Cf$EFZ9w-6LM$^o3i1~CVH~Fc1r$=P-p8?4d zMI>P&LPAIcB!t=WXt?rqJl8}(+hVFM@dBcXfDu4HDyahy#z+~K0gOfLdapLuqO(9r zwxU*(Z&l>70|NwNG8q{p!KEW8%QQ%BuU5235}^RbL1ZAX1tf-2n&L$O#um|8zgUc7 z2^bk9JEz_ciW#+DOEiu0z7&wFopwPXKd+eU@g$d>H~?|v%n~R$L^wdSR1R?x+V|Kf zy((q6#vJo=(pLD2dACnuAvi$wB$iGLGy{kl+|GR3afmab+X-L^kyp1m;BXnN)+iO_ z;#n$EWQ#R4Q&Yv|6{r{0DJD;VgYfun9W%~vE#X*6BaPWx7HGD>SGPzeL`E^0Mx{z{ z&A#UA<11Dy*+%9l<%VZITQPu%&K$WlL}8W8*J_}QCgXRo(){^^?Jn4MDKQnwRb(Bm zW^JKWyG&(g6H$om8Ei`nZ8WQxrX*6bEETsLSsbNX5ST-rN zFx5t83ME8b!KzR!L{{3s*pN)j8!O#%IVl*V%VccWv{e?`RJOOrKU4I7Oew%}+vqh# z+><@~1x_noX#<|X;(ba=1Vc4IGwemp`sh1d2$4D+h%F zsaj=O8DCYLE;#Pf4k1k|E?k+@AUd^^eHt7zhh<;7yKmwO#fs&zp zJ{AoGQXsHd%|NIELID?Q1R+9j%m;a*z#OZtnt;fHNPxv8h((Gqix@%++r1KKzCCM_ zC9)I>k|AYE)s;=OR-uq;gZr=&`vNW3Xga!p)%Wms-G5>5>%%4EfHEqw1Dn-Pdn7yC z=r^kHK@8)f*jVerQH^6} z>Y%#|77{^5)RiK1>jhl$#n2F+l>IW#19POyOeBF?R4rmyi%Xpq2_*tGZ*_O7+yMM3 z#;<4?(Uy$4plZD1G(>V$R4y+R5Uh#sm-bzv2H`-)DYO8sTCyDI4OM;N4m46WmJ|!r zZDCEi1Ol}vOW}Iyp%SKMd4p~0hurpOqDC>F4YL&?VEIZMK+wgoq9{2`#waMF2(sf~ zYbav{SWQC;F%WDq-6$+I8e=OXdfy+O)73yoBp{L*F&K)9BNf~?NvX(zTF9VP8ui=R zXwk7^#i}hWzE{xn_j`MXxlF);8xWF4Fe3%iDMO@$d2M0F7|B@ettvSrh7ks2F%D(W zG{=}^a*ev1kdEP%pt9vML5v2XG=sK`BLsnWA%Kh(L1ZB92vqfG8iWdi%x)+uvM|O0 zP!2HEnByQtAu9@mDh|>WAR>eYMH0jo=q75wKyGaXfq8w(*6U&xNj~C|rh7Fw8-`rU zV;3z|z?%By-a_VQu?j62o?(j1%*hEQ&y+P0W_=D3YueCi=}v4&bRw`EpoB8RgCJtfF?aeeP->-l6)pFES>=&(0s^pu8qc}z8=`C^=Pa& zo^H#tt3k0SAyTSPK&BD|2`UuRMR=&J`#D`gh$u(^1k)Uxqd3GKz9CZZdZqvJIi3?@S9o!0$s-i>- zMMk14=YsLUPKb}9Dqjc754nKq?1I-+K;ODUBZMe7lMOz>#V$6g0aVqvCM=S2#|zf2AZUerVyE8QdZXa z|58Z?c0iIWH0c0IE%~uHdEZTIK8^_UzET5k70!HFRuCQ8*%1LY3VP(2+=nU223_cfx~D$!8U7(u8nsur&{ zuG2VX>8L;h*fKVXsu~P^A3Yh6G$01N4&=6}glb)c%>?{WQYN5pJ`al)iya8TI#Nlj2#84GR1}|tWfc7fazYslpoI}eMn(}; zT7aN5Froo5sf@%gYZ5X~r%aq3l)ssMv+MbO+l}_MuSTh*t%|0?%F|h)0tm245nzcB zBp8tn2N%Cjvsu$!@a>0#w~k^!E3ZfgKnw{d?xK=$vAsxY@Sh>_aa{Y(z#7pMU7sct zSZ1MR`4JBMXQoF7OcO9*#ftKBSCkNn2_%q65=fw_Y6AD7@T#1ql~oW46f|DNO%*;s zOYH7c@rIj){%{#aMM)4oXvuIN;BL&$-*2za`M+DEM=w#;)Po2rK#YKrMC?V7dmaFY#DV#Off#TcfMgeDwaptDd4q>^RHphm=%pQ_&No^%mtqEVig zEG}FeW%MwGk%R$k3UH2BRdO`bi)vC3wtxpP;}cJ-+vS^|EbnRPc*H>wkLKAjCyO4xH@{!L z7z9J71gtxIJ-TE;1PZf}NKnMdf-r-;bDHgYxq-pnP~O*_yN9?^}Hw zz4`CA4{6&M$_)06ZP!hz6>xI}8da9qYg5rZzIRglN)w#mUs*mof$Ym~67~UnMK!Mv z1WrQNw5$|ZbJvFh&yD!|6WcrMa%XS@(nXRf4x|X6RzejZMS!wJ4`u;aNr)0#Nj@ww ziplGj)9+=f{BSb{neIu(dwTD6yk-coFOJdM@VrxXUJzez4L41m$O?COV1^+%04|CZ(%b=EReJ}p3qU?;EixXeZ8IAgg~`pqY!8d08!s$QkQncB8z z&qNy~Un=Ss%}OoADw!kJmDnHWWsQCp5)`Mz zAP2@46jC6RK~yUmDi}=gb!U}Eq9YMFu1ZSc{Y-D}V?ID^g5buB?nlW%h=bBH)*Rxm*h7zJ9P%V;k}#a&l$RzO2sNf6&<98{45eso#_LQMpz zR-(dgn}DGzT`7iA6-h-IVKG&h*uyf5VgYi=?#TkVnGBeuQ)p$J!b}$8;RVE8wHF(i zK)5wF!ebT{5?NI>mWf&*YX}<*p@~})QP$nWHP;#%$1^cfL{2)#TP0+Ig;v(i7Q#*h z2?SjXQ!ugu!&>*5sfV4iE_P#@m5u<&e3`;VjWZR~p0`dADKOm<9cfQ@7SJ0Y83~73 zLL!@u1aHp<-Jw^E1i}iMGtbe0iGEZVz*C9{l@u}rhp<2wNI7YeE$1Y{wr%7JX?Py>lT zY-~p!9$oI)2**W&T=jH8^S*xNJadqasR;&qiLzu#28^c>K4p*qE)k=3+WWw6>bFP& z77e(12G!qGs9_dFVxSM|XJ-_CD)N@d@xuaG_82NyM;L^PBLp)|LfiU2zz7T{V zLd3%YkYND)?#p|}v?FY6RGOCtgbq+aUz_u1I3+-Q{{OT249$S|pru7%0y0Ra%R4j9 z6Q5f9IMs`)KmPQJdQVColut^YlhP@v)5Ep=`ns~`<~dvz;S?yMzzR`vE9SoB9{L4O zU5p^}M81w{MKdEJ!*@E-uA#8SP=t9{?K@p?v+6J;X# zW%(2d)(}_=B=G=cwT{w@5OFILA_iq7F`B|jteK@*85AT?W~EKF1rZx+E2TMv1;h}v z7D*Mk4IpAGc!YyWZm9q{5-E%%H6T=hDx$$;45}Fv1L@9HnLhu9a^Xb0a zlZXmPpu~d3QeoeJd8i`DNJs>Vcwj91+VzSb8bl47i<3v&ih<~QF7XXac2JMPc)s04 z)A}`E(t3O_NHlXc*k*>71X;Lg490c=Zq5gr&izxX9v{%GLKg+M=ITrdOfZI;=Xj|0 z%;KY(&ps9ml=b3%EuTJaID#TSSL#=%Uw*|;(twmdFUq6IPY5Trp8@fsu{lGl!QUh6 z&DSTNV>&~L-H|l^ao~6f-e@gAb(ru`;7VpUev0NolOB_Hg(Al%l`6=Ag`=4YL>zAztYR|1?*R*}5qc*1%B}hV@D0FO@^EMiEA$dOo~VGgUq{qQrgwns zJ1zIOspqAPN!f(_y$UJYK~Ys=dqkrOg-Y#sHlI1*-s%DUAm$FpQiGfk&H=~0?uxxU zyvL@Os2MrLj`+B}-he$-uc00_kBnY1bFt%IG?CJg(sZMx2J;kmPY1y~6x0WT>-is$=uU^B4vvGMPK8}FS252q zGcy-H@2x)H-2D%sF@B!ZUo#1z=-Y0nXquvjAo$5XP{$8!+6$HnI7Q zL#cHLY7mrV>pH>f5bFRs!>tam+-@DmD(*va?grX- zf1fZ6!!r!iG&BG2%6dOJ4O6xUx);Oil2_uSs6S2Am`Mxd57R{uuujsIH}FX)_trt@ zEKDnkJ zDGwKm9~Ca-oavPh&KOXzhbQ9&RlM0{Ybs6H#51sG5Sgqk9CqsaAJWUnifjmMTK_uHiB>Ph>tZfCg&ON5m*lkHo*GX*z{)$U#1+)#O8&Go`z`2Bq zd608+Am&jH;K1_2L9bQ4H!VQAEAT-iP=r&uD|GbF8n4$adp5ll;;ZjB@UexEl0 literal 0 HcmV?d00001 diff --git a/man/bind_tibbles.Rd b/man/bind_tibbles.Rd index d21a9c82..c8f8dacc 100644 --- a/man/bind_tibbles.Rd +++ b/man/bind_tibbles.Rd @@ -32,14 +32,9 @@ my_env <- new.env() ls(my_env) -# Mock up a supertibble -supertbl <- tibble::tribble( - ~redcap_form_name, ~redcap_data, ~structure, - "super_hero_powers", list(), "repeating", - "heroes_information", list(), "nonrepeating" -) +superheroes_supertbl -bind_tibbles(supertbl, my_env) +bind_tibbles(superheroes_supertbl, my_env) ls(my_env) } diff --git a/man/extract_tibble.Rd b/man/extract_tibble.Rd index 2f569bec..c2cf6b83 100644 --- a/man/extract_tibble.Rd +++ b/man/extract_tibble.Rd @@ -23,13 +23,8 @@ This function makes it easy to extract a single instrument's data from a REDCapTidieR supertibble. } \examples{ -# Mock up a supertibble -sample_data <- tibble::tribble( - ~redcap_form_name, ~redcap_data, ~structure, - "super_hero_powers", list(), "repeating", - "heroes_information", list(), "nonrepeating" -) +superheroes_supertbl -extract_tibble(sample_data, "heroes_information") +extract_tibble(superheroes_supertbl, "heroes_information") } diff --git a/man/extract_tibbles.Rd b/man/extract_tibbles.Rd index 51ad9a48..99ac8a01 100644 --- a/man/extract_tibbles.Rd +++ b/man/extract_tibbles.Rd @@ -26,17 +26,12 @@ tidyselect helper functions such as \code{dplyr::starts_with()} or \code{dplyr::ends_with()} is supported. } \examples{ -# Mock up a supertibble -sample_data <- tibble::tribble( - ~redcap_form_name, ~redcap_data, ~structure, - "super_hero_powers", list(), "repeating", - "heroes_information", list(), "nonrepeating" -) +superheroes_supertbl # Extract all data tibbles -extract_tibbles(sample_data) +extract_tibbles(superheroes_supertbl) # Only extract data tibbles starting with "heroes" -extract_tibbles(sample_data, starts_with("heroes")) +extract_tibbles(superheroes_supertbl, starts_with("heroes")) } diff --git a/man/format-helpers.Rd b/man/format-helpers.Rd index 835f27a5..0fdcb265 100644 --- a/man/format-helpers.Rd +++ b/man/format-helpers.Rd @@ -55,11 +55,8 @@ fmt_strip_html("Bold Label") fmt_strip_field_embedding("Label{another_field}") -supertbl <- tibble::tribble( - ~redcap_data, ~redcap_metadata, - tibble::tibble(x = letters[1:3]), tibble::tibble(field_name = "x", field_label = "X Label:") -) +superheroes_supertbl -make_labelled(supertbl, format_labels = fmt_strip_trailing_colon) +make_labelled(superheroes_supertbl, format_labels = fmt_strip_trailing_colon) } diff --git a/man/make_labelled.Rd b/man/make_labelled.Rd index e1f5c6fc..9f69ad87 100644 --- a/man/make_labelled.Rd +++ b/man/make_labelled.Rd @@ -35,15 +35,11 @@ The variable labels for the data tibbles are derived from the \code{field_label} column of the metadata tibble. } \examples{ -supertbl <- tibble::tribble( - ~redcap_data, ~redcap_metadata, - tibble::tibble(x = letters[1:3]), tibble::tibble(field_name = "x", field_label = "X Label"), - tibble::tibble(y = letters[1:3]), tibble::tibble(field_name = "y", field_label = "Y Label") -) +superheroes_supertbl -make_labelled(supertbl) +make_labelled(superheroes_supertbl) -make_labelled(supertbl, format_labels = tolower) +make_labelled(superheroes_supertbl, format_labels = tolower) \dontrun{ redcap_uri <- Sys.getenv("REDCAP_URI") diff --git a/man/superheroes_supertbl.Rd b/man/superheroes_supertbl.Rd new file mode 100644 index 00000000..49cc3651 --- /dev/null +++ b/man/superheroes_supertbl.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{superheroes_supertbl} +\alias{superheroes_supertbl} +\title{Superheroes Data} +\format{ +\subsection{\code{heroes_information}}{ + +A \code{tibble} with 734 rows and 12 columns: +\describe{ +\item{record_id}{REDCap record ID} +\item{name}{Hero name} +\item{gender}{Gender} +\item{eye_color}{Eye color} +\item{race}{Race} +\item{hair_color}{Hair color} +\item{height}{Height} +\item{weight}{Weight} +\item{publisher}{Publisher} +\item{skin_color}{Skin color} +\item{alignment}{Alignment} +\item{form_status_complete}{REDCap instrument completed?} +} +} + +\subsection{\code{super_hero_powers}}{ + +A \code{tibble} with 5,966 rows and 4 columns: +\describe{ +\item{record_id}{REDCap record ID} +\item{redcap_repeat_instance}{REDCap repeat instance} +\item{power}{Super power} +\item{form_status_complete}{REDCap instrument completed?} +} +} +} +\source{ +\url{https://www.superherodb.com/} +} +\usage{ +superheroes_supertbl +} +\description{ +A dataset of superheroes in a REDCapTidieR \code{supertbl} object +} +\keyword{datasets} From d7ed2e45ceb5a411bf9930c517031d0cef1d2453 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Tue, 20 Dec 2022 10:21:26 -0500 Subject: [PATCH 12/14] update error message --- NAMESPACE | 3 +++ R/checks.R | 26 ++++++++++++++++++++++++-- man/format_error_val.Rd | 19 +++++++++++++++++++ 3 files changed, 46 insertions(+), 2 deletions(-) create mode 100644 man/format_error_val.Rd diff --git a/NAMESPACE b/NAMESPACE index 3697fc5d..1d6baf3e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ importFrom(checkmate,expect_double) importFrom(checkmate,expect_factor) importFrom(checkmate,expect_logical) importFrom(cli,cli_abort) +importFrom(cli,cli_vec) importFrom(cli,cli_warn) importFrom(dplyr,"%>%") importFrom(dplyr,across) @@ -60,6 +61,7 @@ importFrom(purrr,pluck) importFrom(rlang,"!!!") importFrom(rlang,.data) importFrom(rlang,as_closure) +importFrom(rlang,as_label) importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,check_installed) @@ -67,6 +69,7 @@ importFrom(rlang,current_env) importFrom(rlang,enquo) importFrom(rlang,env_poke) importFrom(rlang,global_env) +importFrom(rlang,is_atomic) importFrom(rlang,is_bare_formula) importFrom(rlang,is_bare_list) importFrom(rlang,new_environment) diff --git a/R/checks.R b/R/checks.R index 5dc9c980..0767246d 100644 --- a/R/checks.R +++ b/R/checks.R @@ -291,7 +291,7 @@ wrap_checkmate <- function(f) { cli_abort( message = c( - "x" = "You've supplied an invalid value to {.arg {arg}}", + "x" = "You've supplied {.code {format_error_val(x)}} for {.arg {arg}} which is not a valid value", "!" = "{out}" ), class = c(error_class, "REDCapTidieR_cond"), @@ -310,7 +310,7 @@ check_arg_is_supertbl <- function(x, call = caller_env()) { # shared data for all messages - msg_x <- "You've supplied an invalid value to {.arg {arg}}" + msg_x <- "You've supplied {.code {format_error_val(x)}} for {.arg {arg}} which is not a valid value" msg_info <- "{.arg {arg}} must be a {.pkg REDCapTidieR} supertibble, generated using {.code read_redcap()}" msg_class <- c("check_supertbl", "REDCapTidieR_cond") @@ -389,3 +389,25 @@ check_arg_is_valid_token <- function(x, return(TRUE) } + +#' @title +#' Format value for error message +#' +#' @param x value to format +#' +#' @return +#' If x is atomic, x with cli formatting to truncate to 5 values. Otherwise, +#' a string summarizing x produced by as_label +#' +#' @importFrom rlang as_label is_atomic +#' @importFrom cli cli_vec +#' +#' @keywords internal +format_error_val <- function(x) { + if (is_atomic(x)) { + out <- cli_vec(x, style = list("vec-trunc" = 5, "vec-last" = ", ")) + } else { + out <- as_label(x) + } + out +} diff --git a/man/format_error_val.Rd b/man/format_error_val.Rd new file mode 100644 index 00000000..8748755c --- /dev/null +++ b/man/format_error_val.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checks.R +\name{format_error_val} +\alias{format_error_val} +\title{Format value for error message} +\usage{ +format_error_val(x) +} +\arguments{ +\item{x}{value to format} +} +\value{ +If x is atomic, x with cli formatting to truncate to 5 values. Otherwise, +a string summarizing x produced by as_label +} +\description{ +Format value for error message +} +\keyword{internal} From e24d454c4d9dccdf868c7a21fb16f88f78388c0d Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Tue, 20 Dec 2022 11:14:47 -0500 Subject: [PATCH 13/14] update S3 class --- R/checks.R | 4 ++-- R/read_redcap.R | 2 +- data/superheroes_supertbl.rda | Bin 20327 -> 20306 bytes .../testdata/redcaptidier_longitudinal_db.RDS | Bin 1205 -> 1198 bytes tests/testthat/test-labelled.R | 6 ++++++ tests/testthat/test-read_redcap.R | 2 +- 6 files changed, 10 insertions(+), 4 deletions(-) diff --git a/R/checks.R b/R/checks.R index 0767246d..6d9ba571 100644 --- a/R/checks.R +++ b/R/checks.R @@ -314,11 +314,11 @@ check_arg_is_supertbl <- function(x, msg_info <- "{.arg {arg}} must be a {.pkg REDCapTidieR} supertibble, generated using {.code read_redcap()}" msg_class <- c("check_supertbl", "REDCapTidieR_cond") - if (!inherits(x, "redcaptidier_supertbl")) { + if (!inherits(x, "redcap_supertbl")) { cli_abort( message = c( "x" = msg_x, - "!" = "Must be of class {.cls redcaptidier_supertbl}", + "!" = "Must be of class {.cls redcap_supertbl}", "i" = msg_info ), class = msg_class, diff --git a/R/read_redcap.R b/R/read_redcap.R index 29a380a0..0d540a13 100644 --- a/R/read_redcap.R +++ b/R/read_redcap.R @@ -460,6 +460,6 @@ calc_metadata_stats <- function(data) { #' @keywords internal #' as_supertbl <- function(x) { - class(x) <- c("redcaptidier_supertbl", class(x)) + class(x) <- c("redcap_supertbl", class(x)) x } diff --git a/data/superheroes_supertbl.rda b/data/superheroes_supertbl.rda index 8ccb7134a72d6db59a4b57e551135f4547172bff..14b619b61779ea9419ead1d071d133b6bbd4f56b 100644 GIT binary patch delta 20259 zcmV)JK)b)^o&nOH0S-c1XgM)KSte6igm}q(kq$6_AOHsMsy@I`@Or+yIU$zKd;kFY z*01X0#XDL_FAN`hJTbO;bo3M48@9|x63uXeuZ1aDs)&%2j<>m>N# z=Uq+!000Jedsj-QRIg6;p4q8ucU{w#TW!}VcH8UV2R7nop2j>IxxF{71-PIiuWzmm zx2?W^-)z0Fcdt#`yYHRqvNh`}u5RSH3BC_~^X`Y)+ig4I-d}s&1?g3FH(g`|bf65* z!Ao}g$67e|4(*M0*KY##-uGzjUhj6_PP9ANIz06IV)uq!X3T)?)SikpPX@Q$=UQ)J zjSXZvczd4q>|l~2Gyp(GfC%!6c~kVKwNJ%=J*iK@De8WjjXzUV^Hj}E4>Wp|Z%IEy zo=^bM>Kb~0G|&JIG6)bs1O!viMD;KL&=G(GOn?9Y000000000a(jrKLNXd~j+M82N zGBg39iJ${O4FCWD00000XaE2SJyj@^LT`Smr4LO{NYCHus*#|=X^?4%XfzrI1Zk6h z5C9q)8UWFd05WI|27)CCq{Jo&n^IHs(-iYjHmZN9(dnvxs)y=Krh1Q1{ZCYSr{zHO zG9V44V?mIOp_E{T3F>4Xpot;`0w$Q4niCp=r|(3YQ$0;4Mw%z;r|nc}>OCg)O!T8b z$N&HU0000QANW7HC;k896s`O_kdjn?Ay^d&Mgq!J8*-ILEHC3)CN|pHT2+9{M(Rui z&-dmkZQLVh+xsLi7jN)#;#CrIhB;i7T>Ng_8PB_FnQQHY3nP^l52{MITUbT2GcY2= z_NF9EBHr5(ASsDjsV@?_N~=be(L%8zHAvXo?`W!GRw7o$TLI=5HN}x&0xv>J=5S0WUOnx9F}Iq3OV0mk?-#AgaWyx~%)861uDNceFEd-~dUV@! zn)jUJ#N0X1cH|q*8`uN7KYyHaYnA56EmSwhZgb4VI-MK5#Wzk|v~Kp@V{uL#aZGP1 zw=dW4lOC1pFLyN0Htbp68QyMla`TT%+V1t@aXH?d+HsYQwZnP3J4Y^m?Y8b`Idhqo za~owlz{hVpdhV63bFI^yS8i)Ixt(&Cx^=ga9pLfvZyn6TITpyK?irq5W_h=_M|YXm zkvBIR)d_QZad$`yuwCiTjm>9ooqRdm%4RovnVXnpyGBkO%)zj@LM`Uu(8pmMr(i`m z0n$f0XCxfVWQ~`xJ68yQEg+-N%X+iD7lezzUcw3|J0LrTWL|*16MLPI7XV&55l)b! zg7k~gdjU>#6zL~a%)FDknb-@GMdSod@-JWu(gO4a=)HiW=$RzFXo)6Zk~xXG8#N0i zv}DX=+cnhM#p^z5|GVdxHOj@#9JL&Lo^sUp`SY=H?YQ^b9FA&#j!%n^cdhdJ`*F(8 zf1Ei*@_O?}H5}OWICE&+_j>ztY^R=b(alFSM>O|&%N)_ne6}|}E_u&RT-N1|Smw`n zoH?VIZJ}S}5(aJedy|r=8QOg%An;hCX zJ^paOV!aeDFV=P0?XT&tMmb5Y8USmhg==Q&Zzi=5HTrlQ=1{gQr~ zkNh7~f3g3q9|}MBsJm6uw06gKj-AnWy2o^P8{w|Iv3BolbnP9Zx;sZ>wu`&rU3XM= zj@mn-?Yef@?W4NKXzfR6?zDGDbatb~^u;QQE9`9izD43vRo%JGC9!j_pTne;eUfU9@(m)cM*zdi2|_>m9M(W4gy| zbndZs?$O(0w$a;I?QC~g{T`#c7kjqHcE@Ut)kk$5qqf+)ceNeW9oXz|hU>OFM|Q__ zUF==0cWOFa?y=Lm8{xNIs~w|!E3V@2ZKJx!YCBl&tX=Mo>~~|dcSmhT_-(rSE8(|S ze|E2hU3BfEwH?(TEso=SHtV?G4Z7`U?MH1Lt&6XPS6$R^hh2{7?WsD}PPSle;;#85 zv@Z&bo(*-vV}VZTX$dA)n_6Q=BIWrqvma~R)Hh3weJ6<$W%0@mTBhaT8`>tM!U@$A z5}iU9mz6x!$Lpt^N?S^)^!e*_^!1r*e_ms4ZoERB)*{w_D7>Uk$E|ZJi>wwal*?hux(l>%=!Sdk!nLoj zHxE~`AAtS}Q|0k?q4xcbQf7~egY0`+{2L~s%C=1l$))zA3}sEdN?|6sr}BNOf4(OQ z|50}%tiOM&w{Ne#S0gD$Q(@In>1PvdXcz6lw~NO*`uBWmOBRl7?sdF4DMl@=^lw+i zYBjFgDLz@phZvz{wkLB&*WL{r9`Da-9$7~8ae!mu_|zVn@Lh4f){Sj8dvv}2!yS8{ zdPk1`7ach3m+6V|vxf`O)3xi-f8!i)>eKe`ZSx}QPS@>M*;{WJxZ1cLSNPVowm7}G z;{3(d&lPW)^j>=_X=r;^H7fhx*?#@-@+{aIe!j~<>*19f^Eu>ZwZ^k<xb~_J-f$#IqJ9P zj(0vII>r^FSFG0=j5^_O>)W@UdG+s({X`PSHX zHqZeOxQT!C2#^3dsyx8v0R})q zFIWUg6=3rbkQN7tiy|aN@draB1c!|#HA{U{Y~9&L(_Pk)slKY3e?fwH!GBN#_v(I# zA8P*rPQ?9TIg$Nz{U6Dr^#P&hf$!-3Z;nzgLvS@PD&d7mDEui^Ps9g9Q!6``dMU6$ zRai1U^=@2IFW0uJrC-mIYtUWPa+yZi{RiQ53Fm?_dvSLDCx{E23E0V=7N4(!A!qV^2_;wU1rhzR7hu3?W&40IS;a&51do^M4Iz3TWf=+f zldtzs{pCM=S9koC@T2}fKjwf~NB9x(c@R9mY!Bfd;t%z|#t+7yyV>P!e4Gwtn8j1iB)kLLiE=D5wk~Acixk?I zBOouV@%rfxf4?(D70?0z0vT$xML`}v2Fzn+0T#Ui^2&S^u#Hssx_Y)6VWC{u*{CQFciVt63e`ppe zx2ap3#vEikuOSuw{UjO~u5LHCXeYwxd`6X+TmTgKaBjx%Phf zIW=uDs$=PGjst0qCqXM8FSFR+hG%f|-)|mse{oUu!wwa>-u2$&dS>@7oNjLyoTj*K z+}o~h?w>r~>C-jJhot#%rdqArhJ4&HTDRKaa=x!zjcef7#<_RR_TP6I?3H)QW92Uo zj@&k`4Z_^`Tt`c(4R1FZ=3ZNBBB&QCTQNu_Vu-<9e_NL=V0$MFzrah4_D_~k^Dq*D ze+A-pl1v0b_>KdRNOI6XE{5HE;j~-&nD@OcYQ|%rQ5IClxg!Xpf4*+wt%|K0Zg`<5}ca z#`JSsq_1z{h2@wvcB|=34 z)uh(6TG3UCv|CuTNE7htg~Hpu>^YvjE34ldu-uE3xlD-jghWG`R=HZ_xn+InuDZIL zhTP+k-?dDWEwtugl8U0nF}a+|Ex4GLuI;Kly|#4i{7dG6RIv|u+<(F%jnL+tA9HV&cH!hf4sj;;iqn72(`%ao-@#^Pu zcT{+m+njC`6M3haN#3GfL`=(=e@-PjNRXU~@c#*sYX%FQwT8C3m|M2EE@aH|-JHXV z$8EOa+^%ICbAZP#+?2R(q7=Nm+s1O5a+Nu}WjS*lFvE#-DN#y?MIwQCFir8^HE@8R z3H4*uwf6EuaW&InJ&9n0SlY{9o(G#^oAbCI9m#@;S~Z_rB~ewhswg5Uf9BbPN)?r` z`BI9ZUrsu<6>3yfZTaQKfNW79l1L<$K4(NZZyw8x(`jMu2m}+y4(vm2lM)LWTGjR8 zRjq^bx|zp!ipbliUjD8tw?478pJ(sGxiXJn^zdA=?4o}^y*-11#d#NUO~bczt)jPy z%&xZISZ;C8TaznBjeedNe+8v{y-eQQtmB+UV_96xw9I+5-nMe@8qHc;sk&3^v^i>v z8Eq2Ut+tz)mf9tXBBeMu=h|8rTkUbm$|XHvgX4XAxd*4V-t5kA)S@ruqEz6;kR}m3 z3$GrR-#s$#ck}O2y>8wY-Bfw&&!qSH@9(8=daP=SG*+bB8d5=Ee<&<~e7$-fK3h$e z7~N~M%^GgE;V!>EYxuWMI^PcF(*k++UsLEB?mrvzV6j&X}>U*_ocoql_fo3*q6AC-E67B-y+X@y&T?kx(~U%p*v#4a6w{bu^a2t zj$YBn9~v#C)1~76&HWbRdA3XD?f@n9j_|<^dCe;&)$(Y3s zc*7U9KrcMge={B3a?LO^a_grXh373cG{su9zk~|cPgeOYttGCZ`Erj0BLYx#0{{0} zzOmLmgE=%%eK~F>Uv}hHQE?Ra=grMQMzytMw)#v}P9cK~6BBL|nr0rkdyKrxV6kB7 zQBb>R)S?TbVVBh_my9LmWCsgValW@Hh5DSs7G50Ff5vB)XM2(Dcgr)$T`J>JoI^so z{h~}@qQ!)Kp_b$msfv*qjBN#v&dD(kZRScd;mQZ2oj%FGOJO*d`Zth7g5 zCqvOGf1E>+M=n;@w1lcA?g&=0_#C$LCGpp$ob!8>M^id?Hqv(}c4EjC>@-Y;FII4H z3&0gjrf`+8!~<~VC^!>z_LJtj!;$Yw#k%O^AgFo*Hq>~{cHVk>=Y8@*u^J;{i5TVe zjqv?*>9Q8tfcWCTH5O(?N`|dUtrHb0KfN$bPULTI?Bm5kq6yg2&q898FU zVq-C52CY$ajG+-RF^B6iX!m5(G0=97HO+6gE_9yp@O|~-wsh4Vk4|7W-1J>{#X!e{ ze-7@L2#QbE8-A9R-DP^ztfDpf=Q+#+)?8uHL%oc<$tF6wD&fpRNxXtxe0pdzfQgW+^&(EP+NR z5f+t2K+FrsQR^-gtbDXH%rSwVMZ*JZf6P@aM$lQyx>#3qSc$wq6i&%iJ97NXmx(zr z3=oyd4ij1NDCihoBYlg_WQn!e?Yzbap&1@ zT<_BzM?(0u3)T}LT{8y^LU)7m9fVB=$ksxF6A;wFUifkVSLYQtlmLjOIX1O@?h_onqBBOe?rZI2OFr>j_E~G zbBGc{pjwDiXwG9-WjVe|k|y>Jot9{fA!k?;s{5+wkTsCDH)q9g8I1c=4kp@42F`{J z8;~dv#iaoTg=io^7CcS3p1p^clv}vX&<=FI6>&W|G2!N~)0YO`UG>UbkO>44B1$P~ zA8R|bH|V$=ZOavRf0uxWkt6Jnoxw$}f-}vyEwRkpy2|jRP?Hem2Z|XWkaWEsyADVm zMr?L|3*(TJ@m~x#UQva$PMq*CajQnuQ(8rQ(Gxf+$tokRDBdiBJEAo(iG)K)q8Y`) z3M>;cKr;wIvMvPJ<+2t%kf!KSnSt${o*1?T2c!*9p9uh zgezvViIiQ-q#eRKFTFghJfCjyvfn&tT!>|yGcw_yE1E0t<$JrAURRi4vSs!TSt6bI znW(jplrrtOa1jRS7_~kkRE2{rN&$)*wCY8{5LOE)h{ke7XjDN#Qu2nDAo{QQ*B7k& zY0h_Xo!2NVe=MZ-ntP>{a|uKQ$QDmrO9e&^2gIV}hj(W^XhB2K7`wlL5w)jmR`Z9< zu!q^-WgF)I9lB|4B}oDZ1itq|3vO*p0+c}+@7n%$YdQ!L4IWM)VZf*Aq|%0p4b?cLf1%Mvqfm^F>dF)WKo zL<~B4e?bI+I)w#*qQD_!8VLkBwAx{d?Dn<#Sq|C=KT&QYeHLN4lA$|=$qEQe9F4M| z$|;c+kctVosRxxU!{(PP^fD#p($)|$4hu>P+6Fk7Wyi*A?vshZDpy+95b{%%!a>MH z%{@ey7sF)UR$gerzdUP0r7(jw8 z7<&REo+dgxniI4RGcC%*u`nDX#h%1(l|a>&VeJDV$zcJSd(G=OLQ*2i@PrVc-q7ZV zky)V)0GGqCaCXJtJ9zrKNEp?P`f`PYMWAqmhfQb-48+6C1qM-jyQ{bzJ53WR)Yc%q zf7D5*X<}Fqieki)2_z6}hllJ9+$b$=4{9C01oIgx>%%T6B7Bo2ou|)m-UF|?Zp*^L zynd6xoOnS6&PaQXfz^$NDI6IjM|@9!sOoz@7+kaT-KS9VD4C$7#?j z0|C{}#laJbCSJZiEAUSc&b>|C)X3+o5ZbGYch?Otm6SUFO5@|9b zu_~R!0>)%+79BQe?4S)0lN99xf1;-Oq_;~pWRVicIYffC#olGMaE5MRkHtND&6VBL z(>${CD}wQ^`^>9&kT9Du;elg#v*3&oL;`4xg)z3mrXC0mK!O|=0J;MEDIx{ax>v;K zX_gigMvPUQz(MV4y;Goxu#2@+xNgqk2t~F+=_|k~xQ(+yT?8`mFNvmDe?kP!h7`I< zSc!C^RISb;oFIZI2U36li6W|qK@<=l{zO#)8o)ph0;2#VAcR6d098+RD5};dst7;N z8bLpvA}S&E;HrT7Pmu%UUyx6Y_|ZN!4~0-b)QSM0_C*w5k_ZYPR6s;|qWXvkBElW% zAgF>{!Uxzjko|kf%}iR`-DEC4|wlA=e+lk?;>}*$f~_+uQ*Qq z02O?2>ZlYdDS)CZ0RZsD4W`lB0kKVh8y$jVsDr3N3W`J*v&lbQego+O;pi~!K%9P){@7xe3{m6}xV4_yAB#TKvl7tHH`^~%~vJNC7MUY)~C`T|Ljv3z( z6Ie+xtn$np6i~LjfAwT|?W;`{Fqvp&B#}|B%?q5YVV6T82_rEPH@nXw0Ssni6vU|I zEJZ6STPh%sQHa+Z7fi&&p_(_Rk1q!CULJYl6AQ%h@OkHoZx@+(@)Cq3iRXun=boOM z#fmi~QfWcy=aQkN=a-UryqL%a!jvWwN1kiJL5q0C@>h=@e=0Wdqij>f;j%&|(TsNNe~323HG)|lMN|n0hDw>NiPD+DrzVi{w*-eBv?;K~wn4?NtzFKG={Tr{ zT76BZs{6c@HWpwpfjfo(mS$yt{+Mlbc>wk657Ta9)-sBTMus9AwXEio&8>MBBClw) zvjgGC0h~V~zg7Mg{yn-?Vmy~`H@9khhHkj&FfwC>f8R#}tFcr$4CF0q6hvfNQVCj; z(S?>&wv13=JXSz4V(>l>fyY~ z)XQxA`?w>H+<~-YBo-_Z3nUaIk%J^)$V6cx=!^RyoC z0=Y^C-NMo&1-qH0htncrUfX=svY}#<%%-=_e-)I=D-(@G)52GYV<1Uq7E%PK!&NlR ziUkWAjW8;r<)c+fObwdvbB4XvvC-Z{K>P4f7lGJzBiOHCy@0)n_5-K@AE<6V{Y4aZ zMi3--!~ld$k`TUcPkY>RcX_pD+VFJuI5#NYhXX#tk)byowiQhDQvx``5Ob&qs=3fA ze<9XM1(2*VgboxHX>Q_*`EZ|Cs#~Qz+|V9Ep6Cy0uf7i;J>+{)$UW8SQTeB6J*R4R zsoJNdL(=+3(xK@U^uCcg6-U|aKTdyMu7JOmyS!3+^92;E+_D1UY5)(v6&!Mv9YvUdNt(RUNz#hY(*8K+BLMBZ4pW1Z@GP^^M1--jjA4zh!65J z`g@T|KJWvv*$Lw&Q+urfruk9nwa7|JUtnG9pmtmyIh*NJ5loV8fm^9hf{ohx5VD7<+&cixy#0GH(a6 z67nP1sqB6S*r%}%bJ!lh_9^TG*r%J=9>5P^p1?d}Jbn)W;1_`#-UN>ZuK*f2xTWe2 z<9d*T9<3VK8bV%lcU#YK_jh1N8Ng6b0-=MdHDwZmZW@|K|AgWEYSjMrne~6OFnuRG) zMvG%ZD-mea%?3?mf{n1Ykwscm3Yu0nu^OW_NGls)nu->&sIps23W}p>+Yv>!El8Hp zS}CoCjf-uP4YeC<6|-b*jcPWF7EA>eie+M>ZM15ZNk*vJqSRuFwlT7%)MIUn6}Bpk zEZQSz*0C0in!?7$x8b(cf8$$BHpbgyR&0tbY}BJ_EoxT6(QH+k!&utcv`cE1MvB{0 zZG{@!X4)iMYHcXCEv*`xVOXlMR#<9{w$!1GTS#nMR%N!SXhz#=Xq9VAR4p4;@wHwm zr4w4zYid>%My+Pr8)&t)d|PRFw${oUV%n_QhK;J!TGd9?X290fe`QeGjcU}wsMS?G z)?UZl_ru5c{+N3|kMB+)3(|xnG~E;;kA>(2B&mP1L(xa%^MOqt91%imhpXhV1jV0{ zNUTDg1b^8AEFD$YN20B%t4$4JrS6+`qVEcg%uH*JQldH|kQ4<$7-il;{OTW|HDR3D zoUz{Bwqg<#EJFqwe~ESk?Ys;|CZ8Oe)vA!d3>XCj#KeYJ<;RUm&N}X8Y|sSPTnlWf zt`L!6L0}k`W(2VyMNEk(TM;``@aQPc@#^L(-fPuF9X1Lk)W-_m`WbLhJvfbQ*fIVj0xldP7`k`+;hEbz9?L`w4Af1>4Lw5H?+|3qs^cpw5o zAOK`UG6*J+6L!i4K`_&!^u-`L?Dc3!JqAROg@@UId99-qfX0mi4b&D|%FJ`0`PXvv zm@K6zUx@Hm4Ho}-2PI1axZ9>f2}WY98J>nHKujb6IhX*lb8cjhs{26`p%40woUy?| zySXBUf(^kCf1;t_L}K?qLor3rRonrb2@^_FR}DD+2Nf`@)+c&c1RAA8*L~mxC}`+m zo>d`^6@@hdBd*BcD3{x7U_)^~88#!&JD0wdtyFjH7OkqBZ-t$(kiCJmg7S!O7f$~@ z=1n+EWpUw4Q3GcHHtV+;mWeFO&6>4kykAN_m3=Cnf06W|=|j>ui>*XEy(ZpWIB=lK zaN~wJ;cjfRx&jA%1TWvyBH81lQ0tDD!#nDN8mCU0z!9^TGisQs_coYkjt^5L_&X5l%abUlNEm55VY56g3K= z$_j8qe_b%shI{~eD&C_EGC}5`Yh!FIi^Ca0si)C(OC)HBfG~?-kh)j7-CFOfi5zXQ z+8QqJf&|JweMd{PV?2Psd@MFMW=MffEk#KRKn*kHza_L{Ux*vld=*|);Bp1xmr%Aw zH^+WT1O;vV+gt3&P|lFqf{0q&O~pf@7q)))J6`4{0QHIMM>RcTq3a)6>s0lxp!6@HeFNw|Q6HC+cQOZqppQptub%d+ z^}@R%0psm%`KP%qzF#q~UY__;jXtJiGU|Eg&-CTu~gkLQCDDyrjq#9J5>xc z+>-<~iB2K`wucO?0}}hqiP9-;5nX_(R0D{hMF|+rSxd-M2v#-b7)@j{*<@+R2yg<( zJvE>pc7X4s3YeflW%e{G$O%mxe^N!)OCfzVBA*RCDJe-wLR4z$%4AJ9@~+cg7*{Qt zw}Nj0;GxJUb0VC`G=sA1ToJnCmf+_xC?E2g<1u6sEgMG$xiBFI+&@(7dt)B)@OsC4?xI7T z(sEG=`_5JGiWeg?97+%_G%EjebTJeU(F~2JLqh?$4BLJ4d+W}C!H*TlU!o}p3d#iZ zeX#f$nV%L_JA($PYqE>PYV$j^DEU3ud)-M03*`S(?me`-uS4u#X?t$jEM zNh1UjK6|=6vtVCKQgt)=V#IbTDXZk7$c#CZY&2eW~!a{L(ReYrk7 zlngD?>ff089tElQDyIF<@IW@ROi1caoA+%x5nI3Fq^T^80Iw?@nv0wTY! z;P3EUm=Y2tiYyvP*v6ug8zW|H8jP6JH4&L? ziK#j|&#jd`e_Pu9KQmaOsHT<{+9HYRn1&%(bK1ZbNi)AsrmQy;@+0;%yeZbBpGtax zKBAzYvI``K#I^=Tk+utB$rep7FE;T7lSSg*3sM@%sL8Nq3a*BJl@~4Ulj{38^c{X4 z{=5K&9DHI2LWO``go=P^*YcAf!u$DnjPHE7061eF$rJT$Ar$wkl*<)fC2m_&n63Gv&M zp?-^wG`54i&!e4_x6Q{3P^)WgXxiASR9e*ve~_$^6o`pAPpINCH44l!<(B6!cJi^x zGFgrc#^kwL4 zLC42Ky(%R#+^R)}m=w>)yLpeI8e))^wj{|1CDm^+6re?z3Pd@Me@}S1%iFHT!7l@< ze3t)4!NHkEx@-MqX53-#XGuQ8&;%v0_%Xv9mZIq66Ve*Q$EJ6~Pa_XXR)taX_DI(b8-W)do2VP^y@#F|n=XDL}k}9ef%BrX7^c&Ks zJOE5fR8-&oGN)Q9T9ElFPmhH?oE95voVLr6RtucO%O-gq9=`8A2@}`Wm`x~U2vP_s zC{o1%fTS2=Nt9DDl8F;0h{&L*e~O?c8qH*$nTmnQ#$wq65*Q;yNJvIziyA1fKvIE< zO9>V<8jXudvQVZm8yeAL5sJo)f?~$ev9XAV#U{m+DoQpAWEh!3SuGSn4?Zj6wc=)@ z7Knli1Qsw+C3>1sy?81k3C3Er>w$z0ZcL05xiuCG1(yy}GD2L}54BB0e-awvL&TEy z`4P$xFqIJ;qUA7wkrV>Z%>yxMFa;eb00)q^5CgCXgpe{FlMFB%2q2yfr8^>#O+)41 zN3Hq{SSu^fOaO#w!QLj?EJF~D6$rp!t@WnNv(1wT7@2|xLcSty%~=7k!Jq&KSi`K) zS($lx1-yun>4ZPumNO($r&msU2F0Cd=4{JBvl2A2(dvzq*)4qiC=DW z>G?uQ44eciN`Fz!U zt8a3~l8P%)YAGasmL3}`;DCOO0-T_IB$?`-g9-{6L2U^TBod+}&ijQ;$)3J54&BO( z*YVLaOq(0usVtR@e@oqK*VLJcBpF_s*L2&fLmfiW@|$r9BEX7ahLW{q5zLT_2tp|m z5F$t<Ol^57b1~UhNVr5iqfSvC=$RQ2MsS%*W%tOpRWZ>h#9CsfBA+IL?lKqhSKg}fmOT+ z5(EMP7-X#xq7kJmfo%eUsX_YU5@uN?K$0lIg90G1B1o#!Qn-;6@PPvhWF_35q) z5mX{Z2;!QP2~9I=)7NU)+hcEC?u$}$mFWwe>S@%;k2$6Ywr?EkmQG9Q29~~pfX&7NF3ra2q4xwDYjEF0p&$|@jxDw zMItG=Q0U8u$DUMK9V4;;Yd4+IR4qI}ejFJTjv3!qdEe;)2Y*t$j{x`KCMrEPK4CrKzz(@yxa_?>JOo&kAPa>XXpWXtY*Wvey7NQybRTG8vlKaf)Y;l2QwEYVz`0fEW#njqW&mAA7n( zV$$w>f5$#}Trj936^jxcNeezKR7HZW6X!5kwQacF%2ul`36f6K=i%P%- z349iY{yR1TFOF?QQUJGc3+d#YdfuDrR8*SyjJ3xsAj!N&ic#U_*kJ)7oX}IqT8qJ5 z&`^;H02{$mLpx}DHmaq}JR+W6|22oFy$X^6e2PB}*hJn6jXmWFmGRnxLMI&xT zL%1AafN+T`4lI)jC;{V$7=Vh!Btis;#z+)KqUnXI6l98I?LZ9C0P_F~({jo_P|bRb zu+JupyoQ3-5*-yPN2ATV&h>@^Jo?l$Qv{V_{yTu<&G@{+I{_Endhxa*3ROdR>lb_r ze`C|aPk6r^xOtTaf^}=WIq-T5Dio@GMmy#PC-uJfPwip{sO~#QY*7_>XrxHR0Fk++ z1!ufuJln;_tf+tsN#Et;KnmsrTr0fcYGp>4sR*O;#1^pyLa{+`K_%pgAy^fJcW=hm z%5bkfNsUJsMnO#IQC^yhLZE6DLxGAff33pOu7{seMQu zp$|~{vID2S3-r_}ks%a7krCMvqaY%{j#3e}LZA}AoMmw&0-**n0)!MGC`3*We+)RO znwWvipr!z|Oak9UuaNvx6L>1PUdS!@dVJ;=KnfkpA^=kZlYf(RRTT^-oZ8f5g5)nT zBJ3HVq7Iq=3sv#eqg4MkvUnw2{n{2nmRwwTuuLN{R?r zj>QL!!D(HE*BtizmXI4}uUAOiA532ZNiNva?Y&sLlN#CdMe`TuE2z-1) zyN}*0zap0xcQ=&j+H>=mSfGB9M9g%P$6jX?6CRkB^6D@H5b8Cc2hiWgfT|vASBU6X z7JIS*@3e^NwGm_jvIQ)#1lnRi3_zqlt-&HlgM}rb`XC9K867>iNerH<`}FTbqrzzo z8eyJY1H}6>7HmjCizGtBBI03~pod2-JiI{kKp_Nqz0DL*LcItf>O?P)PWd13nZ1 zdXVLl*E}Od5i!q0f6nww_@3DKaV8yN;xAdAdvlHy5#Lj?Phji9tr%`wX}0smdMzJ3 z@j^8jEjp3lzgGUO%cQPlwS76jtJpXbiUMH~UZ?_f!H@|6WRMUH;uL^Lgo5yjAkYvP zjEIpybApD6hbo5PRp-KGtDIB{Ie>WBNLv`qP!@&8vThJUf6_Lgl~?;E8@cu~GG=B* z2Y;tpY3$~s(-n~hK?jsT>3m8p&i%dMhkjwFgm!bF6GkO)Z$yW!Py!_e|xA_n^v zQE-S9$VmVQf1n?fRDpgFbiCRs)SCYsK3=xRPWMq>Dl#HV+ z(IK|ITG49WAppifWFW8wB!*I&;za<+l~hR^^9*AG3_{A7-1rHUfyv{;?b3uUM zA)2i&1WSRs=DntK=F^Npofg&V06G z0TY}#e{yPw!z-Dt)j=3d#_wUJ`SS_dU9jv@Vk?xY$U9uj+d`{$n99y3qY>IN*p?RB zX;(2!NTp<0D{eTlIZC!6Fo=VUxp9!sP$tC_34kCBM>^p#*+zycB}82Ts!%FKR=EM1 zK`}08PjSHDq+*0%u#sZOB!ChMkO(N|Pd_iXe<{*A@AI1?@}$$7aH+!B8o=+^9FLtz zK!{|h20eG|+qUH20Sr*uLxKqA{(ssj{hUOE%R;w#cCc&liJ!NMKlvcMINjW>f1ottGj|}h8yluMzaS1 zKq_JSgxUb>Ab`RsqzReDs)Y>c9bG*bVdMxyho2tYvhb=Zxt|JH=B}jO7OW<{31NUf zz}zBmC>!^`Sd)EdSPVrC070uL3D4rD&_hV-wl+Gklx102y-;5p77{^5)RiK5e>Q@y zndIsSPtbm`XQbtInd^j*D_VuDOA%>wqM;<9My>3w#anTxUM11dAspCk>K97d>) zYO00I1q3THduAPX)dQ4JGKy~iD`w2cN&{tKfJ2ECjirSH1shmXexU%ZiW3N6y68ly zp{9V_nNasJZJ5R}pAEAWAz=ARlW;sFe+8O)^W8mE1cE{dA(JKwiX#==H%Y0;fm+C* zR2Ca25(@>9NTgB#q!Leq^z+Vmuf0sbfg2E#Ml~jvOr;Kz5#_aq7-J=4wzR0^k{Co8 zki{W~plT2*e-AOZ zpsL8j7zIE$!%}06ffR(SDiEkUNK}A|2t|;F2_~dHq=-N!%t;X8&5^Cv#4M71ib|R6 z)ZlIzb195mwO0ab>z8>8nV!Tbv}SpRD=#x7By|Cn6?6-fB~Y5Pq*M$lp~s`2B@0pV&`}7eq9j4i9S=Ci*f3Sff1VpH|YFh(pjc7>?R0Wb|qSD(MsMa-!7^@;e z3nH=tNB|**oNDoLRUD8T0<>hp(-!Ra6*0C269rr^%~qr@YX$Az*J~Wo^jgWX9dn`s z;sjmDF7-uCWzWzVE|$vwVeQ{R6;|4740qu6oCqge*^?uQiw{_ zA}L6dU@EuFC5!`n01EkbO|qWCCW47~!3b4xR01&FZCn*G#~fs2VFP)*$Tv(03@bFx zs@M|Mk*<=id;l~%eg0ugY;>L-LYgs=B#}}?6gH+pfMSZVRp&+Mz0gl}>uqDzuOKKf zB@{E;$z>8gNDTpl0u+)!f7#uH;CH4SK^w~;scdUa-s!A5_?W1HeuE-Yz91WAU2S`C z+~b7t+ZBmOvW9xJw_R3=B8RIKJ_6`<@caG4x8jjL zJu^=4J%WAeHEG?7Y0O3fqR+B{C|^NZ=1}#_FQElJ1Um1-n{o1Re^lY&@Gy7$_l?bq zggc_I;d|cwW9)r>_PCPzdo79xTRQkrP5B^8%{j_MRaLO=i}ym;IrID{7N0!WxL z_es$_{0=SnZIr%|Ov5e*yF3Z&j%G5{lt8Mgl?ywGB!tB9>T!yyhnK~;<=4x+$c3}y z4>w6tHB?A}XsFahe|)fBC@Ieo^TkXc_@YP(Y>1(*^ev(iDy`s(g>b+sG%&QNHOi-n zRj`ZJ9nAQ2ZxJ3a>6<&%gUH|HU%%geQ(5s83>SsVF-~4 zBWZ*tSd^8uzJJketLTshwe;a!#W;1g`M+u}z$)KnJ zE5=o@>uWQ+3_;wf#~{QQafHJmCQinqhpu)nkw;_e(V##qs5*Gdh;eb_!ODeCNJ=Ho zxtI$>O91yqa>DTlU45>W;Dd@=0wM(p1|IeS-wq)0UR)G>e(O-`P~Dg{(XCDn5Qs}qqLC3GuwqC^NrJUh0Dt^};2}W!u4mlmma%xjUSD)ffBlP&pm>n>tPAB8d$Ma9D{BGNej_nUrjhP*{a=!A!AMeGL#5 z!b=G^3oR^?DkCXn79nj9s*}e-Ab)~o6#PEqgfbjR6l5aBh{+_9p&$~GD1kAlXxas1 zQG*rlT(g0874c0i)0K2#D*+PCQ%hSFO@)=Fvq4Ks1d$d9kpe-95a~F3b^5lR4SVhC z56judF(4J!qywM^1e5pCNjTWvq%-gy6T^z*)aCQQd z8y+PO4-#=QMi7|r@dC|&Du0qmpB|wb5>}nI{Vm?&3AAoeo|h~xTiiwTFoltX0c;9z zj#pK2w9|^jNS%di5CEVgObHaIjEn7M8xPK zu0o*jhTo@nSB%RIfSiL2x=gnh=YF{)5-OU?g_dTuHni5$A_*iQ^nY{hJ@Mu>3PI-x zEZ&R}8nKc`F#BU9r~wRJw1K~WpKR}90RoVrBSJcWO6kYn=Xnr7bta`ubbuDpHE4x# zfsZz5onT9E01iRQCcfP^+VLEVeY7=N#KFgQEP8`|@{bvsJU@}9_v-jxqY0}zKU`Gt(+Ji(k#GO8j* zg=<-(H|nX3tW9uN2rD3gA`%iPVOz$=P@)~%@X;xcdtxrVu`Q1zHC{A;MePsCV2eU1_OV|bR6xO^v5jhK9(y&p9hItqU zTPtRRrLoTTZH<64gCepCj1t9OHnrl_jYin7k*e{ny%0%lB>1q#D<`gBPra6_@xaU) zXSpXC?d!eP@qd^i#J)R6Z^H3S)p$XDyfoc5dmt&@;er^1=ajAH&X-*SSz=Lw^m4;< z8dNyToWPpmR41&X%1WH>zGZx+6y>OK>7=QsW*`zJUstr#yEdytGg^)EQL$$vkV$KV zv)S3^;&NJR&o4Hv?Y6%CcMM7ff6aQQ3AI)+>8rm2Ln@SV{hRs^0DeCX}ZL!~?#z_ExLJ}~N3U0B}k`E{$Q4L^g ziVlh|VM4Ee4Ms{SuOl_kuL^0Es0bNErt2UDLcpsITf5~|Gj?I;8fE}tg2X^|06rxL zK|*(N>F+%mBO~=>kK1eeCz-N*l^=zpOIPFp!riVnBQ|0-=_W z0-XY|O2anEkV7>1Q!6!-BM7pbrRH2mH*g9w=15tNFl1n&F^0%YJ8mA@X(TkI%g>4G zhJRuh#!<9vwTka&QCp5)`MzAP2@6NJvBy zh$@9+tx&}>#NU<`8i zH=`m;FoYULMHPrKAWFnsp&?uVKuK8wB%uhf1&}IIHropZLc)rGn&R0A770K~m|m8k zrs==T%3UH3Iu(=6OhO30<6D%$H-AmQ zP?au}!zl`+qKvSZs?2O*nMJVxxn%cbfn3anOj0SdGR|Qp3vqCQ;x1Z?jm)528k=D; ziwcP>s+!A0tq?VY4Tey}t%<1XZsHp2jSXX&n5iNs9b>JMvOz+tYiA2#Cj>Yrq%lmw z$O{c?-e#sAcF4Kej%rpo10nJ-L4Pcbb0ycN*IqCwG3AL4q^Hfpcny#Y1jW#xh^E6q z8*#a>SW?k|mqAlJvhmzR!#WJ0DZ&Vq76T%}5QHRAkVu3XA&&Djkr}*49MdCEmsL$N zZ7OhvD55X492FD%{C8ClK8ef7@MW8DNLM|PXIdldj1 z;Ugjf!V(INheH7?z;UNAfLD8ur%-q#>bF{%>9xvrf#EJHsC$u+hR+fOw4p!_3Ik(u zIdu5Bo$?WnHo<;H03x+^DKY?5ekl5?d$=+MZ5qA zSU2P68&_pgp^RA(ihw`C(#}Zx)#5Fg>&FsU^%$yHM<|4fBLp-}g4_{(bc$>g!VrWZ zLd3fQh%kVB{+j!zghsc`Qfgb85I8{veV-KXK`I0JJ|7?Z42?kY!GB7MzyxHGPw>v1 zafIW^eXHudl^_3nLZ1=wA@L%7N_dwm&^xS#zbr;I{~&MHT>3i=w_vE`!-X zsp+wd9!Qx_H*Nh_3c?Bp-@Yf-`>W!xc7mdQSDtreK>YjQC?gb5L&N}|q2b&X2*nu? zV)xdhjOal3IsxzN>nfaJT~uEm@m0eY*Q^5E$Mt;FU!4Dn27+9Pw-q>=h?7O_Yxp& z>MWW1@lZZ@o|Ld{vDQL9`SE_8MAQCdSM#0T2qYSNjrHN08%zkZL4ULvjO+s3oDZ$c z{HH8^pf_ z5aRK8k`_dc07oi1=Y0yKWMh|q!bjJere6NsqLdm^CKvq*RQLv53n5ga}<=i_tgERd3J_ zfM^AuCjOAJzl~3m=nyvaeLj_#RamH0d^NYp@h=t3WFhFFp-$QgimMaaB^XpHS8d1b ze=%|P&=1=V;B|tO9KeoX4n5y&Rqbo;9n`&G$;>2pMZ@j)fPehetGtedk3hNw%*R6L zNgU}M=Q=sij&XBBuTVd?nt6Pm52as4FQGjEdIdT=Q?>0* z)iwdzyM7npIe*ig=R=>I=M$Y*UP|OSWF|&J<@9w<@5T5&H7*NZO2EPpkwOt`(w~Ev z>52D{%)^lJL zQ?O3K>_@O3!8;UtJ3L(+#T5$kNgG)GlVI#!f*Sgg(h7 zeRP!v=Dj8|LkNe~$RS{zr7CaW5>fB0gU`E28R?&hm@|y)Mhs#40U~X7nx6?WluAg+ zH6#zPgnv5f@ck%$H6)st{er{Q^@Sf~*AIw?t>KrgOYzS7XG8IZG%O+?8jyr4NW7F# zND0p$Tou^|*1AwpjQ~hVswYxBaHQx4Ve1-CSP~HRnyc16}z4pi1|Ntw!g_56G#H-WT5*d+K}YZyv=C!FxLwu|t4m4#ax^ zdla>T){S6mHS5-cT0yNPttG7iuUZVfK6xhLJM1B9D3v7?HANl$i?DVkz&0+y4UC86 z+;W{SNObg_qPmKDH{NNYEeZ?$pBQ3`vnyL_`8xR!i0n)#!KKL&2%9E delta 20227 zcmV)BK*PV%o&o2c0S-c1XgM)KSte6i_4ASqkq$6_KmY~bRDFP>?*#hr;)Yu@-~b2L zTHkjKX+;qQu+#xiJ&hi+QAz>`QdAPpv!FnNfKee*Q1E(Ap0{V+0FL$X&iUN8eSDo` zgEiH-0000S&sC*R^q$W3ioK++>vZL&mu_^WzPcdna4I`R_{;Ub0i0yIIceoxTp!z4krtS`PS~?f19PUhR|Xa`$Fn zBdG&R+j~vOhE0_lzK3|^mWzc z*mODFfg#JodF1f~krAK*34{d5ZAi&9+G*{7Q`CA8)jvXM`igpLHl~@W=<<_#N%|=A zfsknR13(&R00x-^2q1z2Dd?FeselH6i~t&B000000000000AbE5=0V7`bLv#ZAL+p z5C%*@0B8UJ0000000Te(07>epLYho(^;IZ(F(!WhRaAgv&}o27Kn(!Vpc*m_3;{HM z05kvq00Ti1MA8})2$O14dTFMWKYprdil6G4J(QzA)J&-VRUf4^_o|wIp-6wKgY{2P z4Kx7LAk9q5Wb&E-&<{{Vk^%w)A*9nuwA3|I_o5n<{imrBJu;8=Q}(KUsQpmddZv$4 zAZ=3;4E)jkdN{m0&W_ zx|0Dj{rQTUcL>@x{>2Oh+x#53l|-DOj#njDKNq(KbMkFdEq$mlFv%Sb0FdFPN`NH0gXkQc61PLp1Zr$KB7h3N>k0`*UCCOrT=^UR&LyOHuF#EdEf0l;`O;sCZ_p$mw9!S*Dch==4*X# zPMdCXUh|xIn}<3M+=F?;djNMw^SQ@1xn697)kA!C=RC|)snNU4Q*`CaM(=IbHx%K= z6vpzKa{Z3^G3j2i_j641ZpEG9o#y8^FF5qQuJ2wa6P@YZrx{q=TsND4qqK7F+ivD_ zmpPedF}72@40iLkuIXCmI^8+NcILBdnb#?Mr(1au-VYx(@!ZTak!*@?;hE*;XPbL; zcX^$86LWFBP?tBi7j%HT1>T(a+}3va*TbF6rek-xnYo5rv}EDj%o_`YBHnHt40aL9 zb_7#^9VBz6azV_-NZEUT6SZ)H(h5Bcx2rqRcu2ej>>#3ZvIDqgMd%CBH@VpXa0TO` z6zK{$FG#%?uoUM(PLg#@%gH;roq)L{UO+_eBK82iATK~(i`WW2iHb|BG)Xc9k;qMu z)u354qb5Tpxu&MpFIn?f{hvI!u2wE^<*4K5dCODX=gW(ae&gMLY;rlOIX*5uy>FA( z-^VLG-f-m?&h_SwYB{m$aOTmu?d$L6*-t#>qneItj%n@ZEOSRO@>tyXx#vAOb6b`< zW1Bs^;msV!BbqN~&8p+$v~cE*YemafHqVpJZ67RiM=Wy3#acO9IY%ltzgHa99Ih?J<+NP6T;{BEQ{9tt1u+5LlcWVBfA-^=#^vwaa>dSQ=EpQw zImqRX7dcqDs^wA5M=Ck37dad_a>q6!So(Dz@uK>#`P&!h z|LA>HANM}9e`EhTJ`{iNQFg1RXzh;e9Xq1$b&lxnH^W_bV(s48>DoI-basx%Z5MaK zy6&j$9kh2v+jQ-*+edYd(b|sD-DvKP=

zcSm+Rj^nmB!)vb97jE{ncE@dw>N~7= z9mjFItEY7x*zIGwqqSJ>J4bQ87TtGjcWOJe9omlCe>cLeyJ+oCtn;*d_35`=);nXm z$90a_>D^-O-J`b0ZKJla+Su-~`W;7hF86JY?T*zQs*dVAM{Tio?`k`$JF(c`4cBaT zj_r=F2G} z)7E9Jd5yKY@d|fXi&^}l@{y~&Ks7E(gc`{r!4i;Lna5m4+l>rstuSiEihmcD^DuBI z^K*Dxx4pBE9<|J>F0fdxQ!R%s=q}O6q8abE3f8{7+&x~%ehc_XPrd7RA^Ls}sWV5` zp!WUFUiQhTvaORs@@ai|!x>X=Vwg#;Y5lLSSH$68>MrDUm+$p)iozAz11t`U}zK!bmtwy!mWhcux@Z%ILw#4pe+WWzy zgWdVjxY>-UmAncUJI@_+R?41&u*8$*kiAA?@00A;^U_sa{VzrHgMs3I(EH! zJY$XhT7KQ_zGPi#+Wo5gD{bR98&?C${~Fe|#}~I8Uzobt;;r*ui+|5$Z7mOK#-(3- z`!C=drJ{ja1{5*Q*_N%7Yr7=hBU^v3cU=sJi2Dt)$dg1&!k8bhbj(V;69hMiI@cKTzIC41j`> z0p%1)5L6&3)&xONf+`pQ2>}t&K-dumMHL{9;DQn$i4-}pLVrO-ASVSNEP^W$cObzP zfUC?@d&*7#& zkP;oKF{)eZTW0RcHk$6VjZO8m(hL){7xX|sBA=EA+`qz8y+2G%=>H8rFY_q-V9@yB zd|RJ?$0-+~xPMxh6>&nOlz!?}Q}=-JH8QiB&m}epDys%Z;H}GwCHnT&RIB;&O?nHv z4pS)GKal*6VLb3gFK#a1!tnugfjb#9!qfIEEI?4hwP+^GR1Yu8zFC zB&z+eqCdDI>=+FUzjOu*I+TB$Nc;YwsA7-TMnZnVcYpuThx%0iP_Ga5tL-EDV1CL0 zaUa@8$L=6||9}tn5ABEcU)%@qui^wfzxI#r{_wxn~t+=Bf^Icf1c8)uo^YDu9raE%j;#C-^NdF6LX0SG=n)GPl}hrjyARL71#0KynxWh*?k) zVEk8q2IC~cBBDYdin1uE3?d+g7tpAo{$OqeWD)U*>INeqFNxdZNPX#&D6U`-01(GT ztSSie^X|?!P!Vm_@qXRWL=$Ft-hN-v`1peH&3~5nl{LT}ksv5wVtC+8Kdago2J^nxYzF?|}up)@71^|ev@8Rw7wb4WrU9nVA7r(gWO+c++6@)83;efx8VTtt+ z<$ufr>mc@%5(bPo$gr#=#0gjiAY%g=F(6hQVOSb4CLs)DivUnH)>aUx3k-hCB_TD& zVh=f(z~^k}uMh>B&B-~Ge4&|OJ)(h*x-ZperF=qqO6ww`#zhy^EKurSR@w_%-_&-?~{{O(;B8eme}AnnBsI2vGV&p zjreAF4?Xtr=QkA}TrlBVo$p=lH>PiL>Bi>qdCF^s-Oak@?&0&xOQvx{%iMajs?M zwxTM5a;38rf>tPu702;1<*W~6;g|RcalXm&%06ZSP$0Zc(n)}bUlG7^2@YBa1<>2C zd{%kqt=|mvr;~RdmALYsMx7Tn=YJ+Rt!tiJ->da(A+`x2BO(bRvIxkSMxv_;SpcjK z&FBz_FgJ{IQt@Pn;EU(b6m=Y*RAtE8y1gJ=$TC|$hi&`qNR*P#EiGKoq9ZT$e1by*1ZYQ*hgyay#~^l4Z7>%ra3_SjIOq znMJn~64l+cN4K`loxGXrmo&7aYEqVoOG}tse$#2^IE#w5iwePgTt<8w?IgFxwHmz@ zSA%O}tZn)wylS=~2GR-@sedE|kw6rI3Inz%JLFh<;=p{g*ttiN$a+ z2_%9^W9D>2mhtSk&3`tQ9^imMJaF#BHt8`Sv8AnFUKLu{KRc#{5z8<_76`5%Pz_%^ZV1-I4oC@cO=|9cS_nTc$~`XZS{ud9QC;}v}o7q!r-*8 zm#LfEb)0jE%xf!|mYI(>o7T=<<5{aqbvH_VhKDUtV=bavRe!eAb28gRu|!m-2ORr5 zLkoSbIax%ftT23UuU8=S_S@Z=&HA)O{M1UE7_tPyCt-Et();J8UGDyU>Nl<1!uzU^ zJ$dw=?>*i0t?pHgQAUc?n`25yECmIS50|e)=gVob!yB!3nWIhC{3X}t&3|ch^R4ji zZcQ6^4KqDZlT&H=EpuCJ=Ae%ZM6%N&z|$z^UG6$QCy)- zC9h^913P4!$s2g(xsREL1* z9-RnJ)4pO0yWcTu)I?Z&k9og`Nym_hb+0nBZ4yDvwtEo<3NN+YKF@d3b68Oqa<309 zv7<6?V1;7NHKi69p>eBkHJe$E@|;c|eGOYT6}}as$qX$#mc{2h z2E@I@Zhz}#P7e7Nd)?^f^R3W*&Fu->79)ZS6E%q6UYv6FjyU+yZ7!WJ7xr)Hw;Ro} zUpH_8F{99Hru5dvlh)cF1Gv?3&acL-2Dvty~MOo0nZU z+%Gw4v8F23rTidPx_Y;2t0lM6VybZr7+{#2aGcXH^~>C4=351e2TF>C+eW1jT@wtxsa(8aFEb!G zTAPjaxlAwB<`}Z@=AJV=vpd|6Yra{YO6gY`l;Ro{*X+_`1r{tLZs3J$ zFM-Q%GG85fY0o#gM0GQ#b8RPbhh{8+UVp8+ENebIzbBq!&3`%5 z>d?A0Q6E-axZ$z;Z1kSIJoF}uig{Sg^_#@co4{`+K6d}|ij#Oa2H#~8F4xax0uKEwb9NBbPnB$1v`1kjk zBLKHlf>tj-8ShVt^qp#Wm?3lF6F9&%oNn30eIzv(h@>p&*-&|P#D6n1-Iea<1z=)6 zSv3Vjn5^Gy!Y=trlNQldd6r`np8b^bwCK9!&C9m5 z)bpHha)7*{nL{T4i!l^Msbqy$a^Bx}(TEqnjy(G<>z(>zsOVo7p?bn(3#MS^iGk;0c%Z?JYqF~YWPhPlQ z=fAMBvYuQ;%+HeOcGjs!;FNIuBPE2@ttMui;x0ii#mm~r~1W1yKT1VQ>?G5@a2ODz5UFF~+BuM)s z=WtPLpp5fw3v6>YF0#BS6ePqsf#QZpBpokDuEUZCk$;;VpMv=0B>Z<@e#@m7+eG1& z54Z+kVj-jrSUI_XB0yyx4}h%W=IBM2sTB)n;f=6$FdaN z3NtW0v$Mk%z@YSjsuSTMPG#Z5F8J+WC>Gys+$|Ic5QS{kaWad!bc47@Mfazbhm-Bz zHe2V73xAOevxa6|Gv#wdejKlNa_h?T3>Hkj!OJ95zY{eUvJ!?}w+;dz-6IyK#7dB` zWvM_hLsp$gxFQO{Wf2(8NUaKpC@Nl1(!?KC|2pFJpKUqL?lZdO1%;HJ(@%7=u3;#E znF7h{iD0O~p!k$rknZf~tq3T3BNun@A~v+`ihtg4`IZp-JM5!;-{ZGUEu^U+K>(ND z=s|7Gsen?5BR%_H&dp~*0zsq6#0)qT{i01b&onia6mr}yI^d$j($qY)#HLc?G{kL# z!!{a`!yP ziGQB6)6KJU4CONnwRv&TnC=Uy%dbttmQt1TGC5A+a!Q+U^>;dY++4EBhXko8Z`KI1 zJ#v&gfrrJz;9WGZqAa8}9A4espj@#dHraz%+_MtMw3I-@r<4##6R1#F3M>K^L7JrnJN>wTz`D);?59rXQx4kF@y*r(TA`iIpSlZ$)P(y<1*Z=OMepq z!aP~*M)_0?S!N#4GAx!58K=D7vxFrgEUySb3JvWJXo(e?5YP#HI|m1BUGuk(tE7RA zSl_28SVUR}2uO6+fS}AwJit(87rVN!B^p8pU!9)VmpxZW3N#&_j!+zLB5W-VU6N$!!h4q} zZ!A2>4XLICi6*AF)+xL5%IgZpWtgsdwZ~AwI^uKTyoT#|+_rpgtTDhrYJWY?GMm)k zbd-oaVeN!272U@5GsD%P`wbBAp(039O;EQX9s*-2ndD+3(ndl=lF*p0DaW~;=%ON1 z<_%hF_PBpuu{TTv!uo`M%cH4GSI=hkm$6j(w)T*<)#n`g3I@|m7< zo9}$xlj6?#La|{KEAvqegMY;172-g=-LnW6K!8F73VpThc1&qktEIMq{*+3d0CMn7X zMNRWbZkBAxA|;S=i3M$oyvuCi2i(CQihA{%E4!zrd1dBT1>;@!nSWODpkX#+!ve9Y3S;2!xV1~c0mu+Tg1{F*V|64z!gos!~D-kY~OBTV_Db5HYfN&515hMTw z2qJ<5|Hz73YuSJvA%8hT)Sm(# zPhdXL>Ic+%k5GrH2f%nA1K@lJ_z^rF1XW)8tJ?|Tpaovob$`?f6%@Qt79fCmB8IbA z>j2iKunlgpGgLvyLJEpR7vb-JcPHK-p#wwm=RYj~{IQSUAAfNxQn&A@t4yG%5)~>+ zqdQbaO9@|<1Lz#lJ%Iem`%eY%7XJ+V2fz;m4+K0Dz+VHvN5DK3cDq6j&;hVE0k9Ut z8vt7ki!T=u$A6=#24^J|ME}$}C&q%IIu6iJwL$_Z=kinD0LUrvOWTzxzjfcYAWi&$ zjgerYR~NM}H||DOpn4Q3QgFM!4X*W+o*J z(Y-u*csGjh^UoNVUMH7>&pcCjyvxUslp!QfJUnka^z_~=QK=%6N)Jywl?^XEypzS` z#y~a{p)is>^Ii%JTgEq%ym;|Zw~ZTOo-YlO5jKouJZ}{v)5~~_dU@bzjS(761W~+4 zk0t3Wfc;Q3`93;SZq)e<-Eq=jWXB7>js;g@sB#&|TGl9t$h4#qwI!nqEU9f6pus?BTVrZf0kI41 zzJKVyI}n8`QWcpJ3G>DCX0E9T1#m?AF+hvvw;^P*XH%a=kJ<23EY z4p12H4K6wuaLhQ(5qQxw8pXL}DI8%@+<(ln(B_69LjYkQNhF6N0stW5+abdSzSzaO zd%J5+3rZRkO$sSD-_vjn()g=dFXk+wrEx@5Fu}wjBK_cS0=Y^CtA(IQ3wLu%52!@M zz59IBvY}#<%%-=>D=C&%CmM;Tgs&3DK$6ZZqzO-kx@nsf3KlgQWLZVmqh(5&8-KRr z2Q9oWbF09Jf%#yfFC(GR9*XoApf5#w1E>HWQNaAR6j9q4K#|=L0ueGuLixPC9{Zcy z?XNbT_g{C1c8&;ev+Ow<6LH&NRL?~)Ba9&jI{=ESodTjAl#p2qLpVU>p;oTmqQ52c z^><6T)78>|^9p|01+=q-7GOTA7Jt+#L(NNZA$jJ|TTQ6ik+mbpq2zpn#nZBp9fvj4Qya!=4r$n14NBL;P@a!XEepqQ#h0jGN)?guSGDl|9d;_bKi};P(f( zJ<5B4_bJ`(4{!&#PjDU)9v=62?+d(*{_;nAUw949r&3;c?l+$ZG3Zgsz|s=w)$O;V zJU)wfX~O);eXMYpetHLp0wMSCpMXKI!2&=~SfZ;@P(eu)Tw7}uTYnX8C2MOIwkv8) zt(At8T1I5WWgBUYrcIeM6-=8lBurF`Nt%La%`|99OqQ9WMva-M(@a5vl+$QfG*M=R zV;d~dpprCb(Z4-!230Io8qC&dLP1oUXt9lBYY`=rH40LojTXj+RwB`) zB8s%A6*R1EVl_r;kbhP-!8H^uV^L(bmK7C7(Y7LsY+8{mqO?<63mX>OBpYfr)+=Vn z+Zxnu7A%+wEfmVdM%!rBERu~;wMD4K6>MW=O{m7(7AtI38dqh ztH!pNZH>0Ztl1P=*{MdbFERZ1qcsMgf1Dvesrv^LRe zYWTL&@olY?HpR7BwGA6psI{t%s?C9|s>-3Y8r7+VQL3tWth^s*;tvnu`eE$;Z^1Z( zFDej_(|D*wAAfb|1SF|{twYgA=lH;;j~o#~Ylo}ku>{4Ro=B`hodkc`0xTU?+()X- z>sFc@MNDBg?M31i92uG0J#xZ2(aZ`0po}x-gXvKIh-}ML+p1XSzjVMzP_YacY9-hc zw(v0+ntXC^R;oh)FkloDGcp?U*Uz1cPJ3``zQh4G+kYbatgDnHSP)nSC7FRNND)&a zN*2UU)ciUMGrW4ai#VHgQVyGi6MAQrv5gIUluvj3svq1`MS_V@T|z_wn;aR9%-9a@ z*JF~5mRUN8bD#IygB3DaRYp0FC34Ym{0KVL zE(+&<$qXeKim+yS7@+|$kO1aj0?Ex&Bz{}%1Wu$sbad;_B@1xtMGXWT0wGF=i4lwI zfQG?E&{g08vIL2xR<2re`rOpYuUI+D0E1MhntxxY0HqCXvn^TFhBBML1o3op6x4z}mrdq8mlepQ7oDT&8l_@~hGY?m%zb zesf-lF3e5ZwQJ%pay`oTDt8ZZ9msbMV(n26U$EcT*_SFAT)E|*ciVnBT!4Yjf){h= ziGOUc&M0E20Ebp8~O&NH-6y)R`!16+^BHaztG+)0WOaJ}S59 z!wisls2bSY3nK8wP^xM7E~#XV5fBCuY=06LTK7AvUG;GzjkY^OMcwc~nMcp4>2_>q zkQfhzhQ{p45Glo|sUb)KrhK>Lwv0>h1SMP4%q0r8V%M$!2JTnVtO{^k)V5c1K~%v%XzI0pT-!C@%EF6SSAQssii0AJ zBGiBa!EswAG^KSYdrU7cDidA-gE!*iy@asI7JgQHJ#AnFmS7=Zk_Qq1qXLp-07QdI zFGTvL3?>0tjdBBAYZvN_voK>YzyM+0xIjJ`s8=1i>34jvRdUm5V{OfDo48D9Y*Y}~ zyWK1Z23cpa#j~d6f+CqjynhpVg&-CTa8%haQCDz?rjr@kJJk%d;FBaaiCn}3eH^vi z1|~S0ldw|yBD;Z7$Okb%iV`uLvX_vi5Ugv=Fq+6^vdGhr5a0!ndTT&H?g8CM6)`}9 z%j{@XkP@0Wq>HYWLi*H-eAV2Ns#Ky_Z0XlElTJN$-fia#Yu&4eCV$W#B@SUjdMUjI zkac8i(X&k3#)uz4LCXAr3~J9Q%22gj1-6^TS_O9~k7Dcq*>ik>B9bx%wA*u*$0pk5 z++tAV{L5 zin0nUfJJ#deR*s;@P8=k?{>LN?o0?l_D{HWebJAE{clj{`$&-IrcO#BKSPy#LWRi8 zhZ2MfjS9cr9SlVS^g|w@l@rS&9=e#}Z?|(hwdr;F=S_q5>WdD8>eT*0#!_HC6T;jHu2(4h0H{Hc~;Sv91?u;^WWO4rkXgpx2pBj>xt?@fVy zElJqV??s5~RDV-1$x9+I=_$DN6Ba6VK-!Y%GQ@PCciG6Y3`#p3YtU2F*n62%q` zBy3|*Nez*+HVsBhX_|=4w3#B4Mxe<|#!N&}q_G+)3XE+U2(o008j{fyG+GM?VlZgM zvmmAfMMa|&V#PBSAtN9WMl@0*Drrfu5rQHs6AXbFNRmoS%84@q68HT-rEk6bY4kO% zubre^gkuAVX!NMoKoDEIE||~=16F4Vn`0!!lE=bt=i<T6-}j585%~|EsG>sG`zgq#1>5#i+C+a zYbK*6!B8ZUtgF>XN}N?~@o-A>Pah4F0L0mP!UFVy;4b1tKs4|BX{<8G9={p07}v-Z zY`TMVL1cC<8#ZIM^zTzI=Vy)jUp`%F#c}|7xPNJQ`cAYFaYx9R_3P&1DhKEG2a@J` zDMZY0UTo%FCax|XP3tb~EUn2@?2Y&oO3Ufi0@oo5C7BF>j*t-M&~s)X+Z3o^3bRvo zdU}pq7Yr9G7SS-s&G`*piy(mUhbGMgcth|&Fv&&l5=yxNkpOJp)ticbsMRt0-uPHgWN$f=gm@@$iVQZz;~42c4w z&`D8fQ^`uaUTQ8tLvd zQWcUSkr5{;^;||Kp;?ApvfSnF-c~tAOMfxJnB12!$&9qYMoN{55*4IE_DwU0b&dxd z1}b%>u_(0=UdjQZE{P(*2Jj8LYa!}x2Y-Nvw76ig(U~MzXn{=pd)JuxA)+Y>aKn5YX9nR^KeOppnf5*N4AJg=(+F3c#yj{>p%;fA$KXRuXn zQ5~up^5U{P3K7fiaAYU>5cF|KD1UJPs7VZlQh0y{!ERI_^-FOa2Hyx`F5CKV5XJ<7 zwGmA=3C<%RA$TchA!q?2r9gwmv9{Q)SvF0!jkT86yzrzVs0YZ1r|DVb>c3f6Xv*g4 zbOQUkF1CxND6usPdW_mICDk2T=>a4}v_-0=B$A+71*M2WQw`cEoLVwe-+#D~Y;tW5 zEr0>pkn=p4f)u%2p|ui4RYMx=s(t>WidhGc37LBeoPLtWeHAZI`6^G3g*}`W8*7}l z%aK+KoW#o}QEKllD2h9v#YPA#5L8tlf|7+SP#6k9h9sFqGZ`q6GDwVy3W%x#VXW3k z>6oY-oOUgcF(HC9M1+K9Xn(Pyiv$HI7^JX~V?n6cw3{UgV-c~f7BLvCXviikZ5taH zh>TKfSwf_vV5UKdlqHhUL=f}hzAIiPYB6YtFjye5f{82C(v9oEQ5a4#)vsI(AainL zV4caRuvjd(a+#76=D2;TY8a5$5*{R%x5$oAfqbZl;};ox3`n3BhJQ#I3rTn=+@Jsq z(y0&(ATSjRCKknu1Azn+!L%o2QYol>ya@F_MT-SxdFg-ogW-US2_OA|&aEY5*~Ujn=0eud2@az`Kp;gVXKYt^c}XuY>8og&{_j^)usi}5RgL{Y=4HWN212fv@>1!T>O6f z=6n4-=$|DM#G=4ef_d*iKEolsw%)%dny-;i=j)|IN*xv0)WUOLd)~|AG6i71NmbVGN zR)%_otV-XQNq-guQ=Im1zlT^p9z^0>l`Qc6Wbpr(Fy zJ3;k3i6z@YDfUI|1Ou&mlL94faW`>6ZFo zTj!TgPPA2ShNI3{P<)jN9$HqELmR*nE5AGtmv-#Bt2Fk@!%DbWue?bvL&t7~gWHgA z0h0t0K!5Fs$RLAg?yd5&5FN;`JWvOMB9Ro>sC8q;VbLlqj+pC!8jdrlRSTz_52_4` zM*SFN;CS}{gU7tDS>hiIB+W;%=pE>Uh)6pii%+{vFxw8hboOfgv`lL3-|O4r$A=F{ z2t(!iHrrS1(o!KRNi3w&5)9A~2LAE8>)ZH2^MB81P!A9T+N?VIiL|j9TM9yOB@1K| zftSbU(-52e7iORFQRQkQUJKQ1{%BPMz@~~ zl@%tOjP#CqL6d-u6r;!6+GPPDs%sSY3)1sfgcKw~KnD<1(Aj+tV)j(PzsM=)=iOo9 z%LqV!!;2)siU4@x1|TA_Nf1F{ z7^qQ|liQh6oln1uUV&c8kUZ^X%m(*)h*wFH)fKCtjPO(R^Y9%=?WsR4a!7}Pzf8l5LSF9L*U;oHRVJAcbxmV5CXS?E%nOZ zYGp>4sR*O=L>AEnLeW8TK_(=LA!rtacyZ47*Ew6atuwIa2*@e2idVA2(O@+Sp~zs1 z;@^3y2pCoNL|a{^nGh5#pf;6dQsQgy1g0J!ny#Old zS8ef%r^`xMe=y4c02@qoDk^iR57>kDFWA3g2iPI@57~$uIl+HAp-hPgq6CPJsFfK4 z3j#SvM%fC0O8#w?#E=Sv7|03`P=KKkI6yGsrfOmaR-sIRY?%fA<8N^I%zw@xs^yEI zxaHmOlTLsN9m^sBQv;KOlXz7X3?`h@tj7h&USeHPGD9>R^8HO0VWT#xAO~MAlLJgI z3KX&AuqxkIavpFbgn%tQc<%B`A3y z5Nkpe-Th{<;PC`EIXFNVvwb@-xjs;U}}r1O$<)AM7Z()fB9itL*Q&diY$BLcriA%DAZr%5yi1<)iS zfmJ7McQ_!JaEUGF&|U@su+o4ZfxEWxR6DI+Q>lnkq9__Jp@g`)p$QZUiWFI33ADt3 z7=cKArNJUdgM}lwbO21y$m#9ANM!X_-KTyf9rHkLXoh+ahzVb(TNx;!A>`yqu{My zj(JN?u7SuTIWT+miY0RbE>H!*D4BOC)fhfT)b+-Elf$fNaL(J+4^)|l6Dp`yYAyx& z3J7&>r*{}VPzXUC{|VvoTbr_|6IdV{`|rPx0=uj-5Fq(w(SN?(R;#+LzI~47o-cwO z;0B<{E8P|h``r&*EM|DN)`8_=(nuRGL1-v!iQd~tm&n(XjX=3;76Ri1!~jUUS_@Tz zMj3=qqo!@GN;}(RI{0$1$b0&@b(J7qY6%|_pl8B>FH#(`dgp{_q9!@$dESYi6WbpS zB*Uy+Me8%qZhvvYf;;MVN$eA}!?Q*kw%TfW<2@FSo_L`e%$A*q@ZYb4UhUFXGSjy{ za5Qi^3Ce(%#8-3yIv~gdfHFu32FQg#Btk)XMG$BZ7>tOKKyreHX@2DmfUD7b$45Y@ z6leitVIgc|H9%Sy9HiVpg`jO?DzElRH?!=LGDb!Rmw%s9Y3$IW&lQmdK?j;3bG~&J zZ^$r42*VIo38NCYH=+45+(@^w7dL_phOsx9#XqKbeKKtC#}0}#eY8I}Qz zMeKU7Hh!7U6p*W(c0nOOubAucB$u5y0CD8Z5-2%D zI6$;i4sjCN_t+@CDrLCF9P@M1R``l}w@+drIDbI(B$iGLGy{kl+|GR3afmab+X-L^ zkyp1m;BXnN)+iO_;#n$EWQ#R4Q&Yv|6{r{0DJD;VgYfun9W%~vE#X*6BaPWx7HGD> zSGPzeL`E^0Mx{z{&A#UA<11Dy*+%9l<%VZITQPu%&K$WlL}8W8*J_}QCgXRo(){^^ z?SC%Vb}2Cx%2i|?u4ZkaRl7`OXA@C~?HO!K3vD#3n5HCBvMd$199bNtTM(E;LB?FT z$Yw}4DkbvpKp2iy#W2-IW(p-lT*0bPEJRk?z}S#X%o{7+aycm&q|0P%*tAs^+Eli; z$3Ii_e@rRBa@*)NMck7;`vp!bUTFiKz<=U>N=gJnH9#}(NF5`p$qLDX`>+!G0xj2QI=X<>_waY!e_`&XDntx@N92FyJlaL@5GXCi|06GvrVH8pX)N$EDhN?;L z_5RzO`+$TvdGYPbFAAconee5KYU)kVYQk&KmKX!<4ZK@8)f*jVerQH^6}>Y%#|77{^5)RiK1>jhl$#n2F+l>IW#19POyOl2g2T2w7! zSc^-Y6$vE*HE(rys@wqlDaNm87}1uDxu9yi<1|EaRa7o76cDV5@0a#nq6XnW#woM_ zty;1i=nYkU;SMxXHkK3%)NNr+xXC`;jb>7f#)W_g2c>WAF+XQD=vP&_SvBYNK- zp3~JpNF*SV88H}&iX#==H%Y0;fm+C*RT}l%*=W(RV#TU0ExuRK^!Iyvhq+9^fg2E# zMld4<(S(iI>gga$lFT*_k?Emgpp`sLn2=4Y`AEg7C+ip$K& z2_?`8EGp&~6eUoaGNe=s>Y>S-mo*7IoTLGF$Ox$mSxBr8i=5Q3?H-VsbN8lojd zvr^a_RBJ*=YM?BWH5QiG)kd+b(>B=BTN`4uRa(8iU!iB4nyBW0*cGET7MO0&X;T)+ zqGYRm+v?PX*05b}T{f}4T}7;#q1ig1K2Sy8g7qpYXkA3KK}ZH5g=+6jK>5IHhEN6~ z3tFfJLZT8KTyJS`ILHuxsGvYawJ3zGf+CcOHiD~mK`t*2H~<#;HO-Q^B54#%A2cCl z#ZU;teYS8^#xaQ*7(nVejKh4$kjk=5y6t%_Sej`nRCMO8!3<=Af1yJ?9FWy~Gi3X!U!L<>cKMxra{g7Lvlh>xNwUkA$) zKvPsj4L4A>h)Alqf+`lvAh6Mu<$<=l9yL}X64Dwf$$labvay}5-_oSPB`LQ^8 z-%V>ijtKLAzET5k-8R$KIJ~-54jJxKHvl2??c|c^iOz!?@xLh`@rr#H{*v-O~RH21R)TYQA$Ka zg29O)Atp-Ie^3ME4$@FP9ZH#wzQ*@8qS-3ZP|+Acs4uD(uQsmJIA-anKm*t^Hj1hm z41FIx8IUv}2D}dBwyA__U4+d9{83USpl?18ix!I^AbrwpF-Y>T&4?R7eE8HTFW4oP z@gP3dcvg>ShJ!4j;hdCw!Kc2|gAoW#%K$%oW~c_=J;J#hn^hP55KuXtxf-||Oa&1= zgy69f9A!wA2Qw(yAfT}d0#w~k^!E3ZfgKnw{d?xK=$vAsxY@Sh>_ zaa{Y(z#7pMU7sctSZ1MR`4N8({AZ>|2TT(%V8x2^a#xfPiU}l;ND@e(scHiEqVTGm zrj=C?2^2J5#Z47HKuhfIRPlzJh5m3EMny>wK4{5sAK-4x&fjmZ&-uSwqem}M)zpIs zDnN{Yl0@t49YzX)3B(~HJNiA2+3lLO@o2d5hsZz@1^1zQbPw9lsaT z2_mVis99!fQ)^8r7!ZF+AqT6YS?L|-fk-_81)EWVBUUV|wT{xuPykCwdZ7#XZQCz~ z03k#uk)k?)OKH!|+ldfBbta`u^uPzhAx>1Vg6;tUG%>x@18F3bT<&P{hfCFoS=*bDHgYxq-pnP~O*_ zyN9?^} z;9prjJAv%WZxZ$ad_^^{4+Ks^*R-q@Saa8h1J8~4`xDzc>vCss1JXs3DGsCvpjJW^ zAVq+(MGs~HSV@QyTS-1FF^b9Sm(%ZMs{C*>2AS?j#(RHy?{&Op2(d4Y(cAF6Q*~Yt zUvCXJO`gaKcX(iiAvxtMd9$V0K-O54V7(l$+{Tp-GUqTRxRnX(DDsl0JFl5vDMdMI z9C~RgAb{?GNR@qF(@yN#tq{#>H_1lDoRUFV=(jzco^B^4ro8g=YVO->@7Hj|qG$_( zb1>jEP}F}balA`2If=$r@XjV4vo$+Lsg$O3GITU&)FD6hzM(#A)JE4r@e^T10Y<#C zn5XZ2z87nF^sHo%2m~P`2_UBnotn^k;Dv-XfvPAusJ-P1y!YraQB63RE@gQWJZ(Tg z&LwcV09Y;xu04|CZ z(%b=EReJ}p3qU?;EixXeZ8 zIAedgRQk;)qZ(13iK-e;QeRerVtqCnyy(Mb zoOz?GQl}4f?A|paWF=BsZ zFD$8>Tt?SZ-~i9T$VX?}N9qs8bNVzNbmLd$c{rmYOR$6*jFJ*X1|$hsimWf&*YX}<*p@~})QP$nW zHP;#%$1^cfL{2)#TP0+Ig;v(i7Q#*h2?SjXQ!ugu!&>*5sfV4iE_P#@m5zS^$b6Z? zMvXHS)1J3Z5GgR-5*=wzcNWkaAQ=gVSwbS4jRbGc2Hl}oj0D08nlsPQfQf!o7{F7C z2$dECBEk@aBvFt^gc%{96Jkh=;v=5K)@l<9siwB_$0%lsBKsl9Q9WGvSr9%$zKK6y z*;T{|`aX`L1(Z3F{EF@u$CrPk1mU9)DLMrZ*S3&SqU>@F*IFLkLYj2pqzqk?QM>@# zz0Yj-`$bMlfPF1_K8LsI4zuV4T)cDH+w0H(ZG?=73kXOmHXO^uu9J~Bhy`-;aL^qx zb=$E_v)1D~0P+_KsviVoA*;%PZ0Jw}i9l>@M;;zs?%4>(MS@)QbU}afzJBFAbC8ay z2?l$KvSdjHjHeMkWsm?a5u z1w{MKdEJ!*@E-uA#8SP=t9{?K@p?v+6J;X#W%(2d)(}_=B=M6xN+y2=#1OO=Nfo&b zAYvAu{Phzdxc z#Dc|AVc&mws3OQnNCb*_U@ZIE^@<-FL=BsZlSkW%f#`ZJ@eNFNP>;fRzTHIA`ZZtD zdVDZQG;=oCW`>poS-5{`490c=Zq5gr&izxX9v{%GLKg+M=ITrdOfZI;=Xj|0%;KY( z&ps9ml=b3%EuTJaID#TSSL#=%Uw*|;(twmdFUq6IPY5Trp8@fsu{lGl!QUh6&DSTN zV>&~L-H|l^ao~6f-e@gAb(ru`;7VpUev0NolOB_Hg(Al%l`4P8TK)1)FQJL&--q97 z;)SD`3Pc=l7_4G4zwZGHtPy%9`O2;O0q_mLS@Ljb3oG;zJD#Y3w_iupNv3yz>^m*@ zx2fl)j7iyq{Jjb(+d)xPVtYiR3WZATcs8Fo;NI#1{UGKJ$Wnux5zYa}z3z&=JiN!I zm#7&z#E$s5z21L-Jyoxv9yO1QUNLjA<6bn8(vi}1qooMx7f1`FM_BbYvTF6?0xiLp z&5wQ&=i@pfFFMhtc0>MHUFH^h7S&l9R5ev{Pc_V8>&BL+#qE2DVI(90);(Z#r&>K= z2U@*g{?>hMno!8{by2ZHPQACQ0OPKTimj)S01gCwLv;hkAkV0p9nW;CHFsCwTXx-Vb=4>OKAbUajR73ht6NvH6Wd zsdWfy6HmrV>pH>f5bFRs!>tam+-@DmD(*va?grX- zf1fZ6!!r!iG&BG2%6dOJ4O6xUx);Oil2_uSs6S2Am`Mxd57R{uuujsIH}FX)_trt@ z1} zA1MzPiysv(LJ+AU^HD({Cq#T;uBbjModpF$ZB^abB zet(<9RxwmY*$ZO8ZARKHv{sF)#j5a|XY+jVjALjGMQE{6v7oCA$ZV@B$_7-HRAm-W z{#EdP_RWE@Y}mFWY+DlLN1(j~=qFB(N8EoCw0nC%J3#FNwR=|%2MS?a4iPX3>!bO< z51IAn!zWC>9I{8ti@s)`fgwJEr4@-$Z7D>nZERa=HlURT{n-2@CZB#2 z@8X#IBKbzVs(Do6Jrp_%)1vfHv(pzJej<6hvXcr2`2gg9%62gA!|` zcs)JFn*ORf{ndi$C&l#LY%h&+Lxw zO!`!k4>S7+HELc*y=6Zedllk25Fg7Q_eMUt%>~U99qRT=PHAN8994)zAfDCeY#jy( zRdnYo8U*ZrQW{#dBK5YMtW~oE8Id5i(q!v6@>n3sprDt$ zO7q6bi@$Py3sktZmx^#s_H4}> zyJ6cUcH3zFS%r83#1~rgNEO^V>-*mp;_p@=cIyi9Jymq7ru<0OQRKm@)+^JV1=qdx zvD!HN46OB6oL%*4u%@46(}%~94LhgwN(>L#)$ll)C!&UHDrpHRt)*eCeTaW3+Kv2Q zl^aDcfDD#Z8cc9{W`QiqIRP2dz#Jsr%wf<@Og-VV2%l3jq1;l&G!%T0rUt$sfiKH6 z9iQsJjN|y6UE)}>DaTO~jux8`eQDO_uP+WIAAm11IIai zo%phBaptSy4!k55EW}dvEDC>%`tH9@Xq=fce0&rV!Tl>d<1Cq%W4EIO()8ETGHB1k zLLwQM%<(%pZ0K+Nz^?rz(6R6+u>v~WQyG(C>Qa@l0gQVj-v9>M0LJn|%?haKo9Bs7 z>)0FExJU90Y@quN8^&Lirc&R!%^&TWJJJ?fd?yOJ+s}D8+^g-3%#MGVim?1O|Hw%) z5BWO};-9F%UI<>p4o^M>Vo@HVmi-@H+|7c;Z8GC_nPEDmkLE?CFXFicqqv#vsn#v= zI_mApZhjm4({Ct!4t{u>w?BW6@@L^?&4YlAW5MzGjmYk~uR+iLFZrzfU(d1!>BqPr z-%hVUh!A8P$T&E=YIA>$D#(W%DY0XTooTwp)Mn$ru%UOy1$ z%Dpt*<}!+$d6syf#Vi)N+%N}8=&Ge@1UKz>LAy$%LR;nD%UKjGrA2-tDECXVv>#jG zuS(kNvZ?glcvR+>zr5Q@Q2JNbSFDfJdiOWg6E!Cex>f%VFy>^MD9~jZ|fBzy8ati_E{$t9RL9K0!qRF delta 1183 zcmV;Q1YrBF3AG7-ABzY80000000ZqLI^cc%W0ryTac)IcKZB-PXupQbTZ*U4nVGdXt!e;GcqS0ClkebP-2Y~ zucyaY(_dDnzg#f=q?o>&PnX_w#JiKp_uruWf%X7dZO>{4W~g%pGNbLaIms<7GDq+Oar}`-Vuy2HMafG zOF*GEGxdB zNX<$C^^5{(E=}V~SB9Z!?RjoUSK?#Yew!Qa{;1^xC4bMBHy7y4!rQR7@E>H2PJ_Eh zl;(|<7k^293sktZ7m9FB_H4}> zyJ6b}cH3zFS%r8G#1~rgNEO^V>-*mp;_p@=cIyi9T~&0drh-`1QS8I2)+^JV1=qdx zvD!HN46OB6oL%*4u%@5n(}%~94LhggiVqLz)$ll;r@V%1Drs>ct)*eCeTaW3+Kv2Q zl^aDcfD9H@8cuL_W`Qh{oX{JS&>X~H&tcF`LVO<37@rewLYSqDYAAR=OAUPCg@Gv3 zY<#8zQ-+gsdWjRkCJe`EG}bzH?HN%J*NVI=uq+hCJcAt2(;qWYyyrnY!y%moJ~+!`OYy7D&mr{7Ta9Q^P`wm*N5$Dv(2tl-RMv&NN$NX0vf%*w8!bz+Om2(3=FafG4FOgU0@x zFh5JTxrid8z9k-LF-^FX8|EMhU9~ig;HLd9Xjh3;Xsg_NIg5g&w1{s6VL@q@_G1hD zRY{v)HkG~`kIMY=mv>tUO8@HmiWL#=mDmrKHadj?e*;rNrkfib006dIMuh+X diff --git a/tests/testthat/test-labelled.R b/tests/testthat/test-labelled.R index 54661abf..0f9d66e6 100644 --- a/tests/testthat/test-labelled.R +++ b/tests/testthat/test-labelled.R @@ -307,3 +307,9 @@ test_that("make_labelled errors with bad inputs", { expect_error(make_labelled(missing_col_supertbl), class = "missing_req_cols") expect_error(make_labelled(missing_list_col_supertbl), class = "missing_req_list_cols") }) + +test_that("make_labelled preserves S3 class", { + out <- make_labelled(superheroes_supertbl) + + expect_s3_class(out, "redcap_supertbl") +}) diff --git a/tests/testthat/test-read_redcap.R b/tests/testthat/test-read_redcap.R index 7947f0db..62275fde 100644 --- a/tests/testthat/test-read_redcap.R +++ b/tests/testthat/test-read_redcap.R @@ -441,5 +441,5 @@ test_that("read_redcap returns S3 object", { out <- read_redcap(redcap_uri, longitudinal_token) }) - expect_s3_class(out, "redcaptidier_supertbl") + expect_s3_class(out, "redcap_supertbl") }) From 335634d0ba05fba4ef7cfd0acb2c3e1b98be8a99 Mon Sep 17 00:00:00 2001 From: Ezra Porter <60618324+ezraporter@users.noreply.github.com> Date: Tue, 20 Dec 2022 13:14:26 -0500 Subject: [PATCH 14/14] add example error messages --- utility/cli_message_examples.R | 75 +++++++++++ utility/cli_message_examples_reprex.md | 167 +++++++++++++++++++++++++ 2 files changed, 242 insertions(+) create mode 100644 utility/cli_message_examples.R create mode 100644 utility/cli_message_examples_reprex.md diff --git a/utility/cli_message_examples.R b/utility/cli_message_examples.R new file mode 100644 index 00000000..a84b1307 --- /dev/null +++ b/utility/cli_message_examples.R @@ -0,0 +1,75 @@ +devtools::load_all() + +options(rlang_backtrace_on_error_report = "none") + +# read_redcap + +classic_token <- "123456789ABCDEF123456789ABCDEF01" +redcap_uri <- "www.google.com" + +## redcap_uri + +read_redcap(123, classic_token) + +read_redcap(letters[1:3], classic_token) + +## token + +read_redcap(redcap_uri, 123) + +read_redcap(redcap_uri, letters[1:3]) + +## raw_or_label + +read_redcap(redcap_uri, classic_token, raw_or_label = "bad option") + +## forms + +read_redcap(redcap_uri, classic_token, forms = 123) + +## export_survey_fields + +read_redcap(redcap_uri, classic_token, export_survey_fields = 123) + +read_redcap(redcap_uri, classic_token, export_survey_fields = c(TRUE, TRUE)) + +## suppress_redcapr_messages + +read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = 123) + +read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = c(TRUE, TRUE)) + +# bind_tibbles + +bind_tibbles(123) + +supertbl <- tibble(redcap_data = list()) +bind_tibbles(supertbl, environment = "abc") + +bind_tibbles(supertbl, tbls = 123) + +# extract_tibbles + +extract_tibbles(letters[1:10]) + +# extract_tibble + +extract_tibble(123, "my_tibble") + +supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() +extract_tibble(supertbl, tbl = 123) + +extract_tibble(supertbl, tbl = letters[1:3]) + +# make_labelled + +make_labelled(123) + +missing_col_supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() +make_labelled(missing_col_supertbl) + +missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) %>% + as_supertbl() +make_labelled(missing_list_col_supertbl) diff --git a/utility/cli_message_examples_reprex.md b/utility/cli_message_examples_reprex.md new file mode 100644 index 00000000..8466f00a --- /dev/null +++ b/utility/cli_message_examples_reprex.md @@ -0,0 +1,167 @@ +``` r +devtools::load_all() +#> ℹ Loading REDCapTidieR + +options(rlang_backtrace_on_error_report = "none") + +# read_redcap + +classic_token <- "123456789ABCDEF123456789ABCDEF01" +redcap_uri <- "www.google.com" + +## redcap_uri + +read_redcap(123, classic_token) +#> Error in `read_redcap()`: +#> ✖ You've supplied `123` for `redcap_uri` which is not a valid value +#> ! Must be of type 'character', not 'double' + +read_redcap(letters[1:3], classic_token) +#> Error in `read_redcap()`: +#> ✖ You've supplied `a`, `b`, `c` for `redcap_uri` which is not a valid +#> value +#> ! Must have length 1, but has length 3 + +## token + +read_redcap(redcap_uri, 123) +#> Error in `read_redcap()`: +#> ✖ You've supplied `123` for `token` which is not a valid value +#> ! Must be of type 'character', not 'double' + +read_redcap(redcap_uri, letters[1:3]) +#> Error in `read_redcap()`: +#> ✖ You've supplied `a`, `b`, `c` for `token` which is not a valid value +#> ! Must have length 1, but has length 3 + +## raw_or_label + +read_redcap(redcap_uri, classic_token, raw_or_label = "bad option") +#> Error in `read_redcap()`: +#> ✖ You've supplied `bad option` for `raw_or_label` which is not a valid +#> value +#> ! Must be element of set {'label','raw'}, but is 'bad option' + +## forms + +read_redcap(redcap_uri, classic_token, forms = 123) +#> Error in `read_redcap()`: +#> ✖ You've supplied `123` for `forms` which is not a valid value +#> ! Must be of type 'character' (or 'NULL'), not 'double' + +## export_survey_fields + +read_redcap(redcap_uri, classic_token, export_survey_fields = 123) +#> Error in `read_redcap()`: +#> ✖ You've supplied `123` for `export_survey_fields` which is not a valid +#> value +#> ! Must be of type 'logical', not 'double' + +read_redcap(redcap_uri, classic_token, export_survey_fields = c(TRUE, TRUE)) +#> Error in `read_redcap()`: +#> ✖ You've supplied `TRUE`, `TRUE` for `export_survey_fields` which is not +#> a valid value +#> ! Must have length 1, but has length 2 + +## suppress_redcapr_messages + +read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = 123) +#> Error in `read_redcap()`: +#> ✖ You've supplied `123` for `suppress_redcapr_messages` which is not a +#> valid value +#> ! Must be of type 'logical', not 'double' + +read_redcap(redcap_uri, classic_token, suppress_redcapr_messages = c(TRUE, TRUE)) +#> Error in `read_redcap()`: +#> ✖ You've supplied `TRUE`, `TRUE` for `suppress_redcapr_messages` which +#> is not a valid value +#> ! Must have length 1, but has length 2 + +# bind_tibbles + +bind_tibbles(123) +#> Error in `bind_tibbles()`: +#> ✖ You've supplied `123` for `supertbl` which is not a valid value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +supertbl <- tibble(redcap_data = list()) +bind_tibbles(supertbl, environment = "abc") +#> Error in `bind_tibbles()`: +#> ✖ You've supplied `` for `supertbl` which is not a valid +#> value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +bind_tibbles(supertbl, tbls = 123) +#> Error in `bind_tibbles()`: +#> ✖ You've supplied `` for `supertbl` which is not a valid +#> value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +# extract_tibbles + +extract_tibbles(letters[1:10]) +#> Error in `extract_tibbles()`: +#> ✖ You've supplied `a`, `b`, `c`, …, `i`, `j` for `supertbl` which is not +#> a valid value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +# extract_tibble + +extract_tibble(123, "my_tibble") +#> Error in `extract_tibble()`: +#> ✖ You've supplied `123` for `supertbl` which is not a valid value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() +extract_tibble(supertbl, tbl = 123) +#> Error in `extract_tibble()`: +#> ✖ You've supplied `123` for `tbl` which is not a valid value +#> ! Must be of type 'character', not 'double' + +extract_tibble(supertbl, tbl = letters[1:3]) +#> Error in `extract_tibble()`: +#> ✖ You've supplied `a`, `b`, `c` for `tbl` which is not a valid value +#> ! Must have length 1, but has length 3 + +# make_labelled + +make_labelled(123) +#> Error in `make_labelled()`: +#> ✖ You've supplied `123` for `supertbl` which is not a valid value +#> ! Must be of class +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +missing_col_supertbl <- tibble(redcap_data = list()) %>% + as_supertbl() +make_labelled(missing_col_supertbl) +#> Error in `make_labelled()`: +#> ✖ You've supplied `` for `supertbl` which is not a +#> valid value +#> ! Must contain `supertbl$redcap_metadata` +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` + +missing_list_col_supertbl <- tibble(redcap_data = list(), redcap_metadata = 123) %>% + as_supertbl() +make_labelled(missing_list_col_supertbl) +#> Error in `make_labelled()`: +#> ✖ You've supplied `` for `supertbl` which is not a +#> valid value +#> ! `supertbl$redcap_metadata` must be of type 'list' +#> ℹ `supertbl` must be a REDCapTidieR supertibble, generated using +#> `read_redcap()` +``` + +Created on 2022-12-20 with [reprex v2.0.2](https://reprex.tidyverse.org)