diff --git a/NAMESPACE b/NAMESPACE index 9efe8a4e..7dc0131a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,6 +87,7 @@ importFrom(readr,parse_integer) importFrom(readr,parse_logical) importFrom(readr,parse_time) importFrom(rlang,"!!!") +importFrom(rlang,":=") importFrom(rlang,.data) importFrom(rlang,abort) importFrom(rlang,as_closure) diff --git a/R/REDCapTidieR-package.R b/R/REDCapTidieR-package.R index 95358f4b..5f4105d5 100644 --- a/R/REDCapTidieR-package.R +++ b/R/REDCapTidieR-package.R @@ -18,6 +18,7 @@ #' check_installed cnd_muffle current_call current_env enexpr enquo env_poke #' eval_tidy get_env global_env is_atomic is_bare_formula is_bare_list quo_name #' is_installed new_environment quo_get_expr try_fetch zap as_label sym syms expr +#' := #' @importFrom stringi stri_split_fixed #' @importFrom stringr str_detect str_replace str_replace_all str_squish str_trunc #' str_trim str_ends diff --git a/R/checks.R b/R/checks.R index bf3ef7f4..e763c864 100644 --- a/R/checks.R +++ b/R/checks.R @@ -669,7 +669,6 @@ check_extra_field_values_message <- function(extra_field_values, call = caller_e #' #' @keywords internal check_fields_exist <- function(fields, expr, call = caller_env()) { - expr <- quo_name(expr) if (length(fields) == 0) { @@ -694,15 +693,13 @@ check_fields_exist <- function(fields, expr, call = caller_env()) { #' #' @keywords internal -check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()){ - +check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()) { non_checkboxes <- metadata_tbl %>% - filter(field_type != "checkbox") + filter(.data$field_type != "checkbox") if (nrow(non_checkboxes) > 0) { - non_checkboxes <- non_checkboxes %>% - pull(field_name) + pull(.data$field_name) msg <- c( x = "Non-checkbox fields selected for {.code form_name}", @@ -714,5 +711,4 @@ check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()){ class = c("non_checkbox_fields", "REDCapTidieR_cond") ) } - } diff --git a/R/reduce_multi_to_single_column.R b/R/reduce_multi_to_single_column.R index facab7ff..1f3fe717 100644 --- a/R/reduce_multi_to_single_column.R +++ b/R/reduce_multi_to_single_column.R @@ -46,7 +46,6 @@ combine_checkboxes <- function(supertbl, values_fill = NA, raw_or_label = "label", keep = TRUE) { - # Save user cols to enquosure cols_exp <- enquo(cols) @@ -63,20 +62,23 @@ combine_checkboxes <- function(supertbl, record_id_field <- supertbl$redcap_metadata[supertbl$redcap_form_name == form_name][[1]]$field_name[1] # Combine record identifier with remaining possible project identifiers - instrument_identifiers <- c(record_id_field, - "redcap_form_instance", - "redcap_form_name", - "redcap_event", - "redcap_event_instance") + instrument_identifiers <- c( + record_id_field, + "redcap_form_instance", + "redcap_form_name", + "redcap_event", + "redcap_event_instance" + ) # Define values_to as the count of TRUEs/1s for the given checkbox field # Assign TRUE if multiple selections made, and FALSE if one or zero made data_tbl_mod <- data_tbl %>% select(any_of(instrument_identifiers), !!!eval_select(cols_exp, data_tbl)) %>% mutate( - !!values_to := case_when(rowSums(select(., eval_tidy(cols_exp))) > 1 ~ TRUE, - TRUE ~ FALSE) - + !!values_to := case_when( + rowSums(select(., eval_tidy(cols_exp))) > 1 ~ TRUE, + TRUE ~ FALSE + ) ) # Get metadata reference table, check that chosen fields are checkboxes @@ -84,21 +86,27 @@ combine_checkboxes <- function(supertbl, # Replace TRUEs/1s with raw/label values from metadata data_tbl_mod <- data_tbl_mod %>% - mutate(across(-c(any_of(instrument_identifiers), !!values_to), ~ replace_true(.x, - cur_column(), - metadata = metadata, - raw_or_label = raw_or_label))) - + mutate(across( + -c(any_of(instrument_identifiers), !!values_to), + ~ replace_true(.x, + cur_column(), + metadata = metadata, + raw_or_label = raw_or_label + ) + )) # Convert values_to from TRUE/FALSE to multi_value_label or identified single val data_tbl_mod <- data_tbl_mod %>% - mutate(across(field_names, as.character), # enforce to character strings - across(!!values_to, ~as.character(.))) %>% + mutate( + across(field_names, as.character), # enforce to character strings + across(!!values_to, ~ as.character(.)) + ) %>% rowwise() %>% mutate( !!values_to := ifelse(!!sym(values_to) == "TRUE", - multi_value_label, - coalesce(!!!syms(field_names))), + multi_value_label, + coalesce(!!!syms(field_names)) + ), !!values_to := ifelse(is.na(!!sym(values_to)), values_fill, !!sym(values_to)) ) %>% ungroup() %>% @@ -139,34 +147,36 @@ get_metadata_ref <- function(data, supertbl, form_name, instrument_identifiers) { - # Create a metadata reference table linking field name to raw and label values out <- supertbl$redcap_metadata[supertbl$redcap_form_name == form_name][[1]] %>% - filter(field_name %in% names(data)[!names(data) %in% instrument_identifiers]) + filter(.data$field_name %in% names(data)[!names(data) %in% instrument_identifiers]) # Make sure selection is checkbox metadata field type check_fields_are_checkboxes(out) out <- out %>% - select(field_name, select_choices_or_calculations) %>% + select(.data$field_name, .data$select_choices_or_calculations) %>% mutate( - original_field = sub("___.*$", "", field_name) + original_field = sub("___.*$", "", .data$field_name) ) %>% - mutate(pairs = strsplit(select_choices_or_calculations, " \\| "), - label_value = NA, - label_value = purrr::map2_chr(pairs, row_number(), \(.x, .y) .x[.y])) + mutate( + pairs = strsplit(.data$select_choices_or_calculations, " \\| "), + label_value = NA, + label_value = purrr::map2_chr(pairs, row_number(), \(.x, .y) .x[.y]) + ) out %>% - separate_wider_delim(label_value, delim = ", ", names = c("raw", "label")) %>% - select(field_name, raw, label) + separate_wider_delim(.data$label_value, delim = ", ", names = c("raw", "label")) %>% + select(.data$field_name, .data$raw, .data$label) } #' @noRd #' @keywords internal replace_true <- function(col, col_name, metadata, raw_or_label) { - # Replace TRUEs/1s with the appropriate raw or label value from the metadata - replacement <- metadata %>% filter(field_name == col_name) %>% pull(raw_or_label) + replacement <- metadata %>% + filter(.data$field_name == col_name) %>% + pull(raw_or_label) col <- ifelse(col == TRUE, replacement, NA) # col == TRUE works for raw or label because TRUE == 1 & 1 == TRUE # Convert non-TRUEs to NA, since values can be either "FALSE" or "0" for unchecked values return(col) diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index 558bc220..77435375 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -53,10 +53,10 @@ test_that("check_repeat_and_nonrepeat works", { ) expect_error(check_repeat_and_nonrepeat(db_data = test_data_longitudinal), - class = "repeat_nonrepeat_instrument" + class = "repeat_nonrepeat_instrument" ) expect_error(check_repeat_and_nonrepeat(db_data = test_data_not_longitudinal), - class = "repeat_nonrepeat_instrument" + class = "repeat_nonrepeat_instrument" ) expect_no_error(check_repeat_and_nonrepeat(db_data = test_repeating_event)) }) @@ -151,10 +151,10 @@ test_that("checkmate wrappers work", { # extension expect_warning(check_arg_is_valid_extension("temp.docx", valid_extensions = "xlsx"), - class = "invalid_file_extension" + class = "invalid_file_extension" ) expect_warning(check_arg_is_valid_extension("xlsx.", valid_extensions = "xlsx"), - class = "invalid_file_extension" + class = "invalid_file_extension" ) expect_true(check_arg_is_valid_extension("temp.xlsx", valid_extensions = "xlsx")) }) @@ -251,14 +251,14 @@ test_that("check_fields_exist works", { check_fields_exist(fields = character(0), expr = expr(starts_with("temp"))) %>% expect_error(class = "missing_checkbox_fields") - check_fields_exist(fields = c(1,2,3), expr = expr(starts_with("temp"))) %>% + check_fields_exist(fields = c(1, 2, 3), expr = expr(starts_with("temp"))) %>% expect_no_error() }) test_that("check_fields_are_checkboxes works", { metadata <- tibble::tribble( ~field_name, ~field_type, - "record_id", "text", + "record_id", "text", "text_field", "text", "calc_field", "calc", "checkbox___1", "checkbox", diff --git a/tests/testthat/test-reduce_multi_to_single_column.R b/tests/testthat/test-reduce_multi_to_single_column.R index 61aa00fc..7c807f30 100644 --- a/tests/testthat/test-reduce_multi_to_single_column.R +++ b/tests/testthat/test-reduce_multi_to_single_column.R @@ -37,10 +37,12 @@ supertbl <- tibble::tribble( class(supertbl) <- c("redcap_supertbl", class(supertbl)) test_that("combine_checkboxes returns an expected supertbl", { - out <- combine_checkboxes(supertbl = supertbl, - form_name = "nonrepeat_instrument", - cols = starts_with("multi"), - values_to = "new_col") # values_fill declared + out <- combine_checkboxes( + supertbl = supertbl, + form_name = "nonrepeat_instrument", + cols = starts_with("multi"), + values_to = "new_col" + ) # values_fill declared expect_setequal(class(out), c("redcap_supertbl", "tbl_df", "tbl", "data.frame")) expect_equal(nrow(out), 2) @@ -96,10 +98,12 @@ test_that("combine_checkboxes works for nonrepeat instrument and drop old values }) test_that("combine_checkboxes works for repeat instrument", { - out <- combine_checkboxes(supertbl = supertbl, - form_name = "repeat_instrument", - cols = starts_with("repeat"), - values_to = "new_col") %>% + out <- combine_checkboxes( + supertbl = supertbl, + form_name = "repeat_instrument", + cols = starts_with("repeat"), + values_to = "new_col" + ) %>% pull(redcap_data) %>% dplyr::nth(2) @@ -121,7 +125,12 @@ test_that("get_metadata_ref works", { select(study_id, contains("multi")) %>% mutate(new_data = c(FALSE, TRUE, FALSE)) - out <- get_metadata_ref(data = data, supertbl = supertbl, form_name = "nonrepeat_instrument", instrument_identifiers = "study_id") + out <- get_metadata_ref( + data = data, + supertbl = supertbl, + form_name = "nonrepeat_instrument", + instrument_identifiers = "study_id" + ) expected_out <- tibble::tribble( ~"field_name", ~"raw", ~"label",