From 9aad838562c059f106831e3af53738446869a45c Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Tue, 6 Oct 2020 13:12:57 -0400 Subject: [PATCH] added more tidyselect support #45 --- R/tidy_add_header_rows.R | 6 +++-- R/tidy_add_reference_rows.R | 25 ++++-------------- R/tidy_plus_plus.R | 6 ++--- R/tidy_select_variables.R | 6 +++-- man/tidy_add_header_rows.Rd | 3 ++- man/tidy_add_reference_rows.Rd | 9 +++---- tests/testthat/test-add_header_rows.R | 32 ++---------------------- tests/testthat/test-add_reference_rows.R | 9 +------ tests/testthat/test-tidy_plus_plus.R | 31 +++++++++++++++++++++++ 9 files changed, 55 insertions(+), 72 deletions(-) diff --git a/R/tidy_add_header_rows.R b/R/tidy_add_header_rows.R index 3f46e760..f413e4f9 100644 --- a/R/tidy_add_header_rows.R +++ b/R/tidy_add_header_rows.R @@ -20,7 +20,8 @@ #' [tidy_add_term_labels()] will be automatically applied. #' @param x a tidy tibble #' @param show_single_row a vector indicating the names of binary -#' variables that should be displayed on a single row +#' variables that should be displayed on a single row. +#' Accepts tidyselect notation. Default is `NULL` #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export @@ -80,7 +81,8 @@ tidy_add_header_rows <- function(x, # management of show_single_row -------------- # if reference_rows have been defined, removal of reference row variables_to_simplify <- NULL - show_single_row <- stats::na.omit(unique(show_single_row)) + # obtain character vector of selected variables + show_single_row <- .tidy_tidyselect(x, {{ show_single_row }}) has_reference_row <- "reference_row" %in% names(x) if (!has_reference_row) diff --git a/R/tidy_add_reference_rows.R b/R/tidy_add_reference_rows.R index cad5e8af..056af840 100644 --- a/R/tidy_add_reference_rows.R +++ b/R/tidy_add_reference_rows.R @@ -19,7 +19,8 @@ #' rather than before. #' @param x a tidy tibble #' @param no_reference_row a vector indicating the name of variables -#' for those no reference row should be added +#' for those no reference row should be added. Accepts tidyselect notation. +#' Default is `NULL` #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export @@ -55,7 +56,7 @@ tidy_add_reference_rows <- function( x, no_reference_row = NULL, model = tidy_get_model(x), - quiet = FALSE, strict = FALSE + quiet = FALSE ) { if (is.null(model)) { stop("'model' is not provided. You need to pass it or to use 'tidy_and_attach()'.") @@ -73,8 +74,6 @@ tidy_add_reference_rows <- function( .attributes <- .save_attributes(x) - - if ("label" %in% names(x)) { if (!quiet) usethis::ui_info(paste0( @@ -87,22 +86,8 @@ tidy_add_reference_rows <- function( x <- x %>% tidy_add_contrasts(model = model) } - # check if all elements of no_reference_row are in x - # show a message otherwise - not_found <- setdiff(no_reference_row, stats::na.omit(unique(x$variable))) - if (length(not_found) > 0 && !quiet) { - usethis::ui_oops(paste0( - usethis::ui_code(not_found), - " variables listed in ", - usethis::ui_code("no_reference_row"), - " have not been found in ", - usethis::ui_code("x"), - "." - )) - } - if (length(not_found) > 0 && strict) { - stop("Incorrect call with `no_reference_row`. Quitting execution.", call. = FALSE) - } + # obtain character vector of selected variables + no_reference_row <- .tidy_tidyselect(x, {{ no_reference_row }}) terms_levels <- model_list_terms_levels(model) diff --git a/R/tidy_plus_plus.R b/R/tidy_plus_plus.R index 9c267964..b12b1b45 100644 --- a/R/tidy_plus_plus.R +++ b/R/tidy_plus_plus.R @@ -113,8 +113,8 @@ tidy_plus_plus <- function( tidy_add_contrasts() if (add_reference_rows) { res <- res %>% tidy_add_reference_rows( - no_reference_row = no_reference_row, - quiet = quiet, strict = strict + no_reference_row = {{ no_reference_row }}, + quiet = quiet ) } if (add_reference_rows & add_estimate_to_reference_rows) { @@ -126,7 +126,7 @@ tidy_plus_plus <- function( tidy_add_term_labels(labels = term_labels, quiet = quiet) if (add_header_rows) { res <- res %>% - tidy_add_header_rows(show_single_row = show_single_row, + tidy_add_header_rows(show_single_row = {{ show_single_row }}, strict = strict, quiet = quiet) } if (!intercept) { diff --git a/R/tidy_select_variables.R b/R/tidy_select_variables.R index 39a71057..3389515b 100644 --- a/R/tidy_select_variables.R +++ b/R/tidy_select_variables.R @@ -38,7 +38,7 @@ tidy_select_variables <- function( } .attributes <- .save_attributes(x) - # obtain character vector fo selected variables + # obtain character vector of selected variables keep <- .tidy_tidyselect(x, {{ keep }}) x %>% @@ -52,6 +52,7 @@ tidy_select_variables <- function( .tidy_tidyselect <- function(x, keep) { keep <- rlang::enquo(keep) + # keeping variables and class df_vars <- x %>% @@ -81,7 +82,8 @@ tidy_select_variables <- function( # determine if selecting input begins with `var()` select_input_starts_var <- !rlang::quo_is_symbol(keep) && # if not a symbol (ie name) - identical(eval(as.list(rlang::quo_get_expr(keep))[[1]]), dplyr::vars) + identical(eval(as.list(rlang::quo_get_expr(keep)) %>% purrr::pluck(1)), + dplyr::vars) # performing selecting if (select_input_starts_var) { diff --git a/man/tidy_add_header_rows.Rd b/man/tidy_add_header_rows.Rd index a89034c1..4850242d 100644 --- a/man/tidy_add_header_rows.Rd +++ b/man/tidy_add_header_rows.Rd @@ -16,7 +16,8 @@ tidy_add_header_rows( \item{x}{a tidy tibble} \item{show_single_row}{a vector indicating the names of binary -variables that should be displayed on a single row} +variables that should be displayed on a single row. +Accepts tidyselect notation. Default is \code{NULL}} \item{model}{the corresponding model, if not attached to \code{x}} diff --git a/man/tidy_add_reference_rows.Rd b/man/tidy_add_reference_rows.Rd index a8332110..d3a1a36b 100644 --- a/man/tidy_add_reference_rows.Rd +++ b/man/tidy_add_reference_rows.Rd @@ -8,23 +8,20 @@ tidy_add_reference_rows( x, no_reference_row = NULL, model = tidy_get_model(x), - quiet = FALSE, - strict = FALSE + quiet = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{no_reference_row}{a vector indicating the name of variables -for those no reference row should be added} +for those no reference row should be added. Accepts tidyselect notation. +Default is \code{NULL}} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is FALSE} - -\item{strict}{logical argument whether broom.helpers should return an error -when requested output cannot be generated. Default is FALSE} } \description{ For categorical variables with a treatment contrast diff --git a/tests/testthat/test-add_header_rows.R b/tests/testthat/test-add_header_rows.R index 8adbfe9d..74be8a3d 100644 --- a/tests/testthat/test-add_header_rows.R +++ b/tests/testthat/test-add_header_rows.R @@ -29,7 +29,7 @@ test_that("tidy_add_header_rows() works as expected", { res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% - tidy_add_header_rows(show_single_row = .$variable, quiet = TRUE) + tidy_add_header_rows(show_single_row = everything(), quiet = TRUE) expect_equivalent( res$label, c("(Intercept)", "T Stage", "T2", "T3", "T4", "Grade", "I", "II", @@ -80,34 +80,6 @@ test_that("tidy_add_header_rows() works as expected", { ) ) - res <- mod %>% - tidy_and_attach() %>% - tidy_add_reference_rows() %>% - tidy_add_header_rows(show_single_row = c("trt", "unexist", "stage")) - expect_equivalent( - res$label, - c( - "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Grade", - "I", "II", "III", "Chemotherapy Treatment", "Grade * Chemotherapy Treatment", - "I * Drug A", "II * Drug A" - ) - ) - expect_equivalent( - res$term, - c( - "(Intercept)", NA, "stage1", "stage2", "stage3", "stage4", - NA, "grade1", "grade2", "grade3", "trt1", NA, "grade1:trt1", - "grade2:trt1" - ) - ) - expect_equivalent( - res$header_row, - c( - NA, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, - NA, TRUE, FALSE, FALSE - ) - ) - # no warning with an intercept only model mod <- lm(mpg ~ 1, mtcars) expect_warning( @@ -189,7 +161,7 @@ test_that("tidy_add_header_rows() works with nnet::multinom", { res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% - tidy_add_header_rows(show_single_row = .$variable, quiet = TRUE) + tidy_add_header_rows(show_single_row = everything(), quiet = TRUE) expect_equivalent( res$header_row, c( diff --git a/tests/testthat/test-add_reference_rows.R b/tests/testthat/test-add_reference_rows.R index f1e0a894..a520e107 100644 --- a/tests/testthat/test-add_reference_rows.R +++ b/tests/testthat/test-add_reference_rows.R @@ -95,15 +95,8 @@ test_that("test tidy_add_reference_rows() checks", { ) # message or error if non existing variable in no_reference_row - expect_message( - mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = "g") - ) - expect_message( - mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = "g", quiet = TRUE), - NA - ) expect_error( - mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = "g", strict = TRUE) + mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = "g") ) }) diff --git a/tests/testthat/test-tidy_plus_plus.R b/tests/testthat/test-tidy_plus_plus.R index 47c0f3b0..e3a909db 100644 --- a/tests/testthat/test-tidy_plus_plus.R +++ b/tests/testthat/test-tidy_plus_plus.R @@ -70,3 +70,34 @@ test_that("tidy_plus_plus() with mice objects", { NA ) }) + + +test_that("tidy_plus_plus() with tidyselect", { + # build regression model + mod <- lm(age ~ trt + marker + grade, gtsummary::trial) + + expect_error( + tidy_plus_plus( + mod, + add_header_rows = TRUE, + show_single_row = trt, + no_reference_row = grade + ), + NA + ) + + expect_equal( + tidy_plus_plus( + mod, + add_header_rows = TRUE, + show_single_row = "trt", + no_reference_row = "grade" + ), + tidy_plus_plus( + mod, + add_header_rows = TRUE, + show_single_row = trt, + no_reference_row = grade + ) + ) +})