Selecting function updates

.github/pull_request_template.md

@@ -13,7 +13,7 @@ Checklist for PR reviewer
 - [ ] If a new function was added, function included in `_pkgdown.yml`
 - [ ] If a bug was fixed, a unit test was added for the bug check
 - [ ] Run `pkgdown::build_site()`. Check the R console for errors, and review the rendered website.
-- [ ] Code coverage is suitable for any new functions/features. Review coverage with `covr::report()`. Before you run, set `Sys.setenv(NOT_CRAN=true)` and begin in a fresh R session without any packages loaded. 
+- [ ] Code coverage is suitable for any new functions/features. Review coverage with `covr::report()`. Before you run, set `Sys.setenv(NOT_CRAN="true")` and begin in a fresh R session without any packages loaded. 
 - [ ] R CMD Check runs without errors, warnings, and notes
 - [ ] NEWS.md has been updated with the changes from this pull request under the heading "`# gtsummary (development version)`". If there is an issue associated with the pull request, reference it in parantheses at the end update (see NEWS.md for examples).
 - [ ] `usethis::use_spell_check()` runs with no spelling errors in documentation

NAMESPACE

@@ -52,10 +52,13 @@ export(all_categorical)
 export(all_character)
 export(all_continuous)
 export(all_continuous2)
+export(all_contrasts)
 export(all_dichotomous)
 export(all_double)
 export(all_factor)
 export(all_integer)
+export(all_interaction)
+export(all_intercepts)
 export(all_logical)
 export(all_numeric)
 export(all_of)
@@ -123,6 +126,15 @@ export(theme_gtsummary_mean_sd)
 export(tidy_bootstrap)
 export(tidy_standardize)
 export(vars)
+importFrom(broom.helpers,.formula_list_to_named_list)
+importFrom(broom.helpers,.generic_selector)
+importFrom(broom.helpers,.select_to_varnames)
+importFrom(broom.helpers,all_categorical)
+importFrom(broom.helpers,all_continuous)
+importFrom(broom.helpers,all_contrasts)
+importFrom(broom.helpers,all_dichotomous)
+importFrom(broom.helpers,all_interaction)
+importFrom(broom.helpers,all_intercepts)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,all_of)
 importFrom(dplyr,any_of)

R/add_glance_source_note.R

@@ -46,8 +46,9 @@ add_glance_source_note <- function(x, include = everything(), label = NULL,
     stop("`x=` must be class 'tbl_regression'")
 
   # prepping table -------------------------------------------------------------
+  df_glance_orig <- broom::glance(x$model_obj, ...)
   df_glance <-
-    broom::glance(x$model_obj, ...) %>%
+    df_glance_orig %>%
     tidyr::pivot_longer(cols = everything(),
                         names_to = "statistic_name",
                         values_to = "statistic")
@@ -72,18 +73,27 @@ add_glance_source_note <- function(x, include = everything(), label = NULL,
     mutate(label = map_chr(.data$label, ~translate_text(.x, language)))
 
   # evaluating tidyselects -----------------------------------------------------
-  include <- var_input_to_string(
-    data = vctr_2_tibble(df_results$statistic_name), arg_name = "include",
-    select_single = FALSE, select_input = {{include}}
-  )
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      data = df_glance_orig,
+      arg_name = "include"
+    )
 
   label <-
-    tidyselect_to_list(vctr_2_tibble(df_results$statistic_name), label, arg_name = "label")
+    .formula_list_to_named_list(
+      x = label,
+      data = df_glance_orig,
+      arg_name = "label"
+    )
 
   if (rlang::is_function(fmt_fun)) fmt_fun <- everything() ~ fmt_fun
   fmt_fun <-
-    tidyselect_to_list(vctr_2_tibble(df_results$statistic_name), fmt_fun, arg_name = "fmt_fun")
-
+    .formula_list_to_named_list(
+      x = fmt_fun,
+      data = df_glance_orig,
+      arg_name = "fmt_fun"
+    )
 
   # updating df_results with new information -----------------------------------
   if (!is.null(label)) {

R/add_global_p.R

@@ -76,8 +76,12 @@ add_global_p.tbl_regression <- function(x,
   type <- type %||% get_theme_element("add_global_p-str:type", default = "III")
 
   # converting to character vector ---------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(unique(x$table_body$variable)),
-                                 select_input = !!rlang::enquo(include))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = x$table_body,
+      arg_name = "include"
+    )
 
   # if no terms are provided, stop and return x
   if (length(include) == 0) {
@@ -220,8 +224,12 @@ add_global_p.tbl_uvregression <- function(x, type = NULL, include = everything()
   type <- type %||% get_theme_element("add_global_p-str:type", default = "III")
 
   # converting to character vector ---------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(unique(x$table_body$variable)),
-                                 select_input = !!rlang::enquo(include))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = x$table_body,
+      arg_name = "include"
+    )
 
   # capturing dots in expression
   dots <- rlang::enexprs(...)

R/add_p.R

@@ -105,15 +105,28 @@ add_p.tbl_summary <- function(x, test = NULL, pvalue_fun = NULL,
     gts_mapper("add_p(pvalue_fun=)")
 
   # converting bare arguments to string ----------------------------------------
-  group <- var_input_to_string(data = x$inputs$data,
-                               select_input = !!rlang::enquo(group),
-                               arg_name = "group", select_single = TRUE)
-  include <- var_input_to_string(data = select(x$inputs$data, any_of(x$meta_data$variable)),
-                                 select_input = !!rlang::enquo(include),
-                                 arg_name = "include")
-  exclude <- var_input_to_string(data = select(x$inputs$data, any_of(x$meta_data$variable)),
-                                 select_input = !!rlang::enquo(exclude),
-                                 arg_name = "exclude")
+  group <-
+    .select_to_varnames(
+      select = {{ group }},
+      data = x$inputs$data,
+      var_info = x$table_body,
+      arg_name = "group",
+      select_single = TRUE
+    )
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      data = select(x$inputs$data, any_of(x$meta_data$variable)),
+      var_info = x$table_body,
+      arg_name = "include"
+    )
+  exclude <-
+    .select_to_varnames(
+      select = {{ exclude }},
+      data = select(x$inputs$data, any_of(x$meta_data$variable)),
+      var_info = x$table_body,
+      arg_name = "exclude"
+    )
 
   # group argument -------------------------------------------------------------
   if (!is.null(group)) {
@@ -139,10 +152,13 @@ add_p.tbl_summary <- function(x, test = NULL, pvalue_fun = NULL,
 
   # test -----------------------------------------------------------------------
   # parsing into a named list
-  test <- tidyselect_to_list(
-    select(x$inputs$data, any_of(x$meta_data$variable)),
-    test, .meta_data = x$meta_data, arg_name = "test"
-  )
+  test <-
+    .formula_list_to_named_list(
+      x = test,
+      data = select(x$inputs$data, any_of(x$meta_data$variable)),
+      var_info = meta_data_to_var_info(x$meta_data),
+      arg_name = "test"
+    )
 
   # checking pvalue_fun are functions
   if (!is.function(pvalue_fun)) {
@@ -400,6 +416,9 @@ add_p.tbl_cross <- function(x, test = NULL, pvalue_fun = NULL,
 add_p.tbl_survfit <- function(x, test = "logrank", test.args = NULL,
                               pvalue_fun = style_pvalue,
                               include = everything(), quiet = NULL, ...) {
+  # quoting inputs -------------------------------------------------------------
+  include <- rlang::enquo(include)
+
   # setting defaults -----------------------------------------------------------
   quiet <- quiet %||% get_theme_element("pkgwide-lgl:quiet") %||% FALSE
 
@@ -414,7 +433,7 @@ add_p.tbl_survfit <- function(x, test = "logrank", test.args = NULL,
     getOption("gtsummary.pvalue_fun", default = style_pvalue) %>%
     gts_mapper("add_p(pvalue_fun=)")
 
-  include <- select(vctr_2_tibble(x$meta_data$variable), {{ include }}) %>% names()
+  include <- .select_to_varnames(select = !!include, var_info = x$meta_data)
 
 
   # if user passed a string of the test name, convert it to a tidy select list
@@ -425,8 +444,19 @@ add_p.tbl_survfit <- function(x, test = "logrank", test.args = NULL,
   }
 
   # converting test and test.args to named list --------------------------------
-  test <- tidyselect_to_list(vctr_2_tibble(x$meta_data$variable), test, arg_name = "test")
-  test.args <- tidyselect_to_list(vctr_2_tibble(x$meta_data$variable), test.args, arg_name = "test.args")
+  test <-
+    .formula_list_to_named_list(
+      x = test,
+      var_info = x$table_body,
+      arg_name = "test"
+    )
+
+  test.args <-
+    .formula_list_to_named_list(
+      x = test.args,
+      var_info = x$table_body,
+      arg_name = "test.args"
+    )
 
   # adding pvalue to meta data -------------------------------------------------
   meta_data <-
@@ -677,9 +707,13 @@ add_p.tbl_svysummary <- function(x, test = NULL, pvalue_fun = NULL,
 
 
   # converting bare arguments to string ----------------------------------------
-  include <- var_input_to_string(data = select(x$inputs$data$variables, any_of(x$meta_data$variable)),
-                                 select_input = !!rlang::enquo(include),
-                                 arg_name = "include")
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      data = select(x$inputs$data$variables, any_of(x$meta_data$variable)),
+      var_info = x$table_body,
+      arg_name = "include"
+    )
 
   # checking that input x has a by var
   if (is.null(x$df_by)) {
@@ -691,10 +725,13 @@ add_p.tbl_svysummary <- function(x, test = NULL, pvalue_fun = NULL,
 
   # test -----------------------------------------------------------------------
   # parsing into a named list
-  test <- tidyselect_to_list(
-    select(x$inputs$data$variables, any_of(x$meta_data$variable)),
-    test, .meta_data = x$meta_data, arg_name = "test"
-  )
+  test <-
+    .formula_list_to_named_list(
+      x = test,
+      data = select(x$inputs$data$variables, any_of(x$meta_data$variable)),
+      var_info = x$table_body,
+      arg_name = "test"
+    )
 
   # checking pvalue_fun are functions
   if (!is.function(pvalue_fun)) {

R/add_stat.R

@@ -107,10 +107,13 @@ add_stat <- function(x, fns, fmt_fun = NULL, header = "**Statistic**",
   }
 
   # convert fns to named list --------------------------------------------------
-  fns <- tidyselect_to_list(
-    select(x$inputs$data, any_of(x$meta_data$variable)),
-    fns, .meta_data = x$meta_data, arg_name = "fns"
-  )
+  fns <-
+    .formula_list_to_named_list(
+      x = fns,
+      data = select(x$inputs$data, any_of(x$meta_data$variable)),
+      var_info = x$table_body,
+      arg_name = "fns"
+    )
 
   # setting new column name ----------------------------------------------------
   stat_col_name <-

R/add_stat_label.R

@@ -87,11 +87,22 @@ add_stat_label <- function(x, location = NULL, label = NULL) {
   stat_label <- as.list(x$meta_data$stat_label) %>% set_names(x$meta_data$variable)
   # converting input to named list
   if (!is_survey(x$inputs$data))
-    label <- tidyselect_to_list(x$inputs$data[x$meta_data$variable], label,
-                                .meta_data = x$meta_data, arg_name = "label")
+    label <-
+      .formula_list_to_named_list(
+        x = label,
+        data = x$inputs$data[x$meta_data$variable],
+        var_info = meta_data_to_var_info(x$meta_data),
+        arg_name = "label"
+      )
   else
-    label <- tidyselect_to_list(x$inputs$data$variables[x$meta_data$variable], label,
-                                .meta_data = x$meta_data, arg_name = "label")
+    label <-
+      .formula_list_to_named_list(
+        x = label,
+        data = x$inputs$data$variables[x$meta_data$variable],
+        var_info = meta_data_to_var_info(x$meta_data),
+        arg_name = "label"
+      )
+
   # updating the default values with values in label
   stat_label <- imap(stat_label, ~label[[.y]] %||% .x)
 

R/as_flex_table.R

@@ -77,9 +77,13 @@ as_flex_table <- function(x, include = everything(), return_calls = FALSE,
       .init = flextable_calls
     )
 
-  # converting to charcter vector ----------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(names(flextable_calls)),
-                                 select_input = !!rlang::enquo(include))
+  # converting to character vector ---------------------------------------------
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = names(flextable_calls),
+      arg_name = "include"
+    )
 
   # return calls, if requested -------------------------------------------------
   if (return_calls == TRUE) return(flextable_calls[include])

R/as_gt.R

@@ -82,10 +82,18 @@ as_gt <- function(x, include = everything(), return_calls = FALSE, exclude = NUL
     )
 
   # converting to charcter vector ----------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(names(gt_calls)),
-                                 select_input = !!rlang::enquo(include))
-  exclude <- var_input_to_string(data = vctr_2_tibble(names(gt_calls)),
-                                 select_input = !!rlang::enquo(exclude))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = names(gt_calls),
+      arg_name = "include"
+    )
+  exclude <-
+    .select_to_varnames(
+      select = {{ exclude }},
+      var_info = names(gt_calls),
+      arg_name = "exclude"
+    )
 
   # this ensures list is in the same order as names(x$gt_calls)
   include <- names(gt_calls) %>% intersect(include)

R/as_hux_table.R

@@ -64,8 +64,12 @@ as_hux_table <- function(x, include = everything(), return_calls = FALSE,
     )
 
   # converting to character vector ----------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(names(huxtable_calls)),
-                                 select_input = !!rlang::enquo(include))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = names(huxtable_calls),
+      arg_name = "include"
+    )
 
   # return calls, if requested -------------------------------------------------
   if (return_calls == TRUE) return(huxtable_calls[include])

R/as_kable.R

@@ -52,10 +52,18 @@ as_kable <- function(x, include = everything(), return_calls = FALSE,
   if (return_calls == TRUE) return(kable_calls)
 
   # converting to charcter vector ----------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(names(kable_calls)),
-                                 select_input = !!rlang::enquo(include))
-  exclude <- var_input_to_string(data = vctr_2_tibble(names(kable_calls)),
-                                 select_input = !!rlang::enquo(exclude))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = names(kable_calls),
+      arg_name = "include"
+    )
+  exclude <-
+    .select_to_varnames(
+      select = {{ exclude }},
+      var_info = names(kable_calls),
+      arg_name = "exclude"
+    )
 
   # making list of commands to include -----------------------------------------
   # this ensures list is in the same order as names(x$kable_calls)

R/as_kable_extra.R

@@ -55,8 +55,12 @@ as_kable_extra <- function(x, include = everything(), return_calls = FALSE,
     )
 
   # converting to charcter vector ----------------------------------------------
-  include <- var_input_to_string(data = vctr_2_tibble(names(kable_extra_calls)),
-                                 select_input = !!rlang::enquo(include))
+  include <-
+    .select_to_varnames(
+      select = {{ include }},
+      var_info = names(kable_extra_calls),
+      arg_name = "include"
+    )
 
   # making list of commands to include -----------------------------------------
   # this ensures list is in the same order as names(x$kable_calls)