added more tidyselect support #45

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)

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)
 

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) {

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) {

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(

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")
   )
 })
 

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
+    )
+  )
+})