diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index b57ac1c237..f6769238c6 100644 --- a/.github/pull_request_template.md +++ b/.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 diff --git a/DESCRIPTION b/DESCRIPTION index 99633ab812..b3388298a3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: gtsummary Title: Presentation-Ready Data Summary and Analytic Result Tables -Version: 1.3.5.9007 +Version: 1.3.5.9008 Authors@R: c(person(given = "Daniel D.", family = "Sjoberg", diff --git a/NAMESPACE b/NAMESPACE index 8a72cdddac..e2e8b8b888 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 93ed172c68..768f87b0b0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,16 @@ # gtsummary (development version) +* All select helper functions and the utility functions that make them possible, have been cleaned up and migrated to broom.helpers. THIS IS A HUGE UPDATE. #648 +* Migrated all selecting functionality from gtsummary to broom.helpers. Exporting functions the functions below. Each has been improved and streamlined compared to their original versions in gtsummary. #648 #680 +* .generic_selector(): this is a function that makes it easy to create selecting functions like all_continuous(). The internals allow for it to be used in broom.helpers and gtsummary seamlessly. #680 +* .select_to_varnames(): This function converts selecting syntax into character varnames #680 +* .formula_list_to_named_list(): this function takes the formula selecting syntax used widely in gtsummary, and converts it to a named list. +* Update to use #680 broom.helpers::tidy_plus_plus() instead of the individual broom.helpers::tidy_*() functions. #692 +* Theme element has been added for controlling the other tidy_plus_plus() arguments. #692 +tbl_regression(add_estimate_to_reference_rows=) argument has been added. Added to tbl_uvregression() as well. #692 +* Theme element for tbl_regression(add_estimate_to_reference_rows=) has been added. #677 +* The argument all_continuous(continuous2=) has been removed. No deprecation messages were added...it was just cut. + * Multiple imputation models created with {mice}, and multinomial regression models created with {nnet} are now supported in `tbl_regression()` (#645) * Added warning message to users when they pass a data frame to `tbl_uvregression(data=)` with column names containing spaces or special characters ( #686) diff --git a/R/add_glance_source_note.R b/R/add_glance_source_note.R index ab40f50271..ec38c4bb9d 100644 --- a/R/add_glance_source_note.R +++ b/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)) { diff --git a/R/add_global_p.R b/R/add_global_p.R index 0d036fd1ad..009f458df7 100644 --- a/R/add_global_p.R +++ b/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(...) diff --git a/R/add_p.R b/R/add_p.R index 869d9243fb..433673dad7 100644 --- a/R/add_p.R +++ b/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)) { diff --git a/R/add_stat.R b/R/add_stat.R index 995f6eee8b..d49bd83113 100644 --- a/R/add_stat.R +++ b/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 <- diff --git a/R/add_stat_label.R b/R/add_stat_label.R index 968edfce2e..8b03df0f55 100644 --- a/R/add_stat_label.R +++ b/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) diff --git a/R/as_flex_table.R b/R/as_flex_table.R index 4375ab4fad..b38e59adf1 100644 --- a/R/as_flex_table.R +++ b/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]) diff --git a/R/as_gt.R b/R/as_gt.R index 8805563460..9afab96c50 100644 --- a/R/as_gt.R +++ b/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) diff --git a/R/as_hux_table.R b/R/as_hux_table.R index 21f82ebaef..452a7752ba 100644 --- a/R/as_hux_table.R +++ b/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]) diff --git a/R/as_kable.R b/R/as_kable.R index 43d0abfa42..3c60f8019a 100644 --- a/R/as_kable.R +++ b/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) diff --git a/R/as_kable_extra.R b/R/as_kable_extra.R index e6b213d309..df4419885b 100644 --- a/R/as_kable_extra.R +++ b/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) diff --git a/R/as_tibble.R b/R/as_tibble.R index 0c4477d848..8320ebf2af 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -40,10 +40,18 @@ as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, tibble_calls <- table_header_to_tibble_calls(x = x, col_labels = col_labels) # converting to character vector --------------------------------------------- - include <- var_input_to_string(data = vctr_2_tibble(names(tibble_calls)), - select_input = !!rlang::enquo(include)) - exclude <- var_input_to_string(data = vctr_2_tibble(names(tibble_calls)), - select_input = !!rlang::enquo(exclude)) + include <- + .select_to_varnames( + select = {{ include }}, + var_info = names(tibble_calls), + arg_name = "include" + ) + exclude <- + .select_to_varnames( + select = {{ exclude }}, + var_info = names(tibble_calls), + arg_name = "exclude" + ) # making list of commands to include ----------------------------------------- # this ensures list is in the same order as names(x$kable_calls) diff --git a/R/deprecated.R b/R/deprecated.R index da3f604d6a..e8fdcfb3db 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -8,6 +8,11 @@ #' @keywords internal NULL +# tentative deprecation schedule +# "warn" for at least 9 month +# "stop" after 12 months +# "delete" after 18 months? + # v1.1.0 ----------------------------------------------------------------------- #' @rdname deprecated #' @export @@ -21,7 +26,7 @@ add_global <- function(...) { lifecycle::deprecate_stop("1.1.0", "gtsummary::add_global()", "add_global_p()") } -# v1.2.0 ----------------------------------------------------------------------- +# v1.2.0 (2019-08-19) ---------------------------------------------------------- #' @rdname deprecated #' @export @@ -53,7 +58,7 @@ tab_style_bold_levels <- function(...) { lifecycle::deprecate_stop("1.2.0", "gtsummary::tab_style_bold_levels()", "bold_levels()") } -# v1.2.5 ----------------------------------------------------------------------- +# v1.2.5 (2020-02-11) ---------------------------------------------------------- #' @rdname deprecated #' @export tbl_summary_ <- function(...) { @@ -68,7 +73,7 @@ add_p_ <- function(...) { add_p(...) } -# v1.3.3 ----------------------------------------------------------------------- +# v1.3.3 (2020-08-11) ---------------------------------------------------------- #' @rdname deprecated #' @export as_flextable <- function(...) { @@ -90,3 +95,116 @@ as_flextable <- function(...) { as_flex_table(...) } +# v1.3.6 ----------------------------------------------------------------------- +#' @rdname deprecated +#' @export +all_numeric <- function() { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::all_numeric()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.numeric)` instead." + ) + ) + + where(is.numeric) +} + + +#' @rdname deprecated +#' @export +all_character <- function() { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::all_character()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.character)` instead." + ) + ) + + where(is.character) +} + +#' @rdname deprecated +#' @export +all_integer <- function() { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::all_integer()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.integer)` instead." + ) + ) + + where(is.integer) +} + +#' @rdname deprecated +#' @export +all_double <- function() { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::all_double()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.double)` instead." + ) + ) + + where(is.double) +} + +#' @rdname deprecated +#' @export +all_logical <- function() { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::all_logical()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.logical)` instead." + ) + ) + + where(is.logical) +} + +#' @rdname deprecated +#' @export +all_factor <- function() { + lifecycle::deprecate_warn( + "1.3.6", "gtsummary::all_factor()", + details = paste0( + "The {tidyselect} and {dplyr} packages have implemented functions to ", + "select variables by class and type, and the {gtsummary} version is ", + "now deprecated.\n\n", + "Use `where(is.factor)` instead." + ) + ) + + where(is.factor) +} + +# this is a copy of the tidyselect where function. it can be deleted after the +# all_factor, all_character, etc. functions are fully deprecated +where <- function(fn) { + predicate <- rlang::as_function(fn) + + function(x, ...) { + out <- predicate(x, ...) + + if (!rlang::is_bool(out)) { + abort("`where()` must be used with functions that return `TRUE` or `FALSE`.") + } + + out + } +} diff --git a/R/gtsummary-package.R b/R/gtsummary-package.R index a7bf859007..fe208aca46 100644 --- a/R/gtsummary-package.R +++ b/R/gtsummary-package.R @@ -11,6 +11,8 @@ #' @importFrom glue glue as_glue glue_collapse #' @importFrom stringr fixed word str_extract_all str_remove_all str_starts #' str_split str_detect str_remove str_replace_all str_wrap str_sub str_locate +#' @importFrom broom.helpers .formula_list_to_named_list .select_to_varnames +#' .generic_selector #' @importFrom usethis ui_oops ui_code ui_code_block ui_value #' @keywords internal "_PACKAGE" diff --git a/R/inline_text.R b/R/inline_text.R index ce0ff78757..f3f7b167e2 100644 --- a/R/inline_text.R +++ b/R/inline_text.R @@ -53,9 +53,15 @@ inline_text.tbl_summary <- # checking variable input -------------------------------------------------- variable <- - var_input_to_string( - data = vctr_2_tibble(x$meta_data$variable), arg_name = "variable", - select_single = TRUE, select_input = !!variable + .select_to_varnames( + select = !!variable, + data = switch(class(x[1]), + "tbl_summary" = x$inputs$data, + "tbl_cross" = x$inputs$data, + "tbl_svysummary" = x$inputs$data$variables), + var_info = x$table_body, + arg_name = "variable", + select_single = TRUE ) # selecting variable row from meta_data @@ -90,9 +96,11 @@ inline_text.tbl_summary <- # selecting proper column name column <- - var_input_to_string( - data = vctr_2_tibble(col_lookup_table$input), arg_name = "column", - select_single = TRUE, select_input = !!column + .select_to_varnames( + select = !!column, + var_info = col_lookup_table$input, + arg_name = "column", + select_single = TRUE ) column <- col_lookup_table %>% @@ -126,10 +134,11 @@ inline_text.tbl_summary <- } else { level <- - var_input_to_string( - data = vctr_2_tibble(filter(result, .data$row_type != "label") %>% - pull(.data$label)), - arg_name = "level", select_single = TRUE, select_input = !!level + .select_to_varnames( + select = !!level, + var_info = filter(result, .data$row_type != "label")$label, + arg_name = "level", + select_single = TRUE ) result <- @@ -232,9 +241,12 @@ inline_text.tbl_regression <- # select variable ---------------------------------------------------------- variable <- - var_input_to_string( - data = vctr_2_tibble(unique(x$table_body$variable)), arg_name = "variable", - select_single = TRUE, select_input = !!variable + .select_to_varnames( + select = !!variable, + data = NULL, + var_info = x$table_body, + arg_name = "variable", + select_single = TRUE ) # grabbing rows matching variable @@ -249,10 +261,11 @@ inline_text.tbl_regression <- } else { level <- - var_input_to_string( - data = vctr_2_tibble(filter(result, .data$row_type != "label") %>% - pull(.data$label)), - arg_name = "level", select_single = TRUE, select_input = !!level + .select_to_varnames( + select = !!level, + var_info = filter(result, .data$row_type != "label")$label, + arg_name = "level", + select_single = TRUE ) result <- @@ -502,6 +515,10 @@ inline_text.tbl_survfit <- function(x, time = NULL, prob = NULL, variable = NULL, level = NULL, pattern = x$inputs$statistic, estimate_fun = x$inputs$estimate_fun, pvalue_fun = NULL, ...) { + # quoting inputs ------------------------------------------------------------- + variable <- rlang::enquo(variable) + level <- rlang::enquo(level) + # setting defaults --------------------------------------------------------- pvalue_fun <- pvalue_fun %||% @@ -518,9 +535,9 @@ inline_text.tbl_survfit <- } # selecting variable ------------------------------------------------------- - variable <- dplyr::select(vctr_2_tibble(unique(x$meta_data$variable)), {{ variable }}) %>% names() + variable <- .select_to_varnames(select = !!variable, var_info = x$meta_data) if (length(variable) == 0) - variable <- dplyr::select(vctr_2_tibble(unique(x$meta_data$variable)), 1) %>% names() + variable <- .select_to_varnames(select = 1, var_info = x$meta_data) result <- dplyr::filter(x$meta_data, .data$variable == .env$variable) %>% @@ -528,9 +545,9 @@ inline_text.tbl_survfit <- purrr::flatten_dfc() # selecting level ---------------------------------------------------------- - level <- dplyr::select(vctr_2_tibble(unique(result$label)), {{ level }}) %>% names() + level <- .select_to_varnames(select = !!level, var_info = unique(result$label)) if (length(level) == 0) - level <- dplyr::select(vctr_2_tibble(unique(result$label)), 1) %>% names() + level <- .select_to_varnames(select = 1, var_info = unique(result$label)) result <- dplyr::filter(result, .data$label == .env$level) @@ -590,11 +607,13 @@ inline_text.tbl_cross <- # row_level ---------------------------------------------------------------- # converting row_level to a string - row_level <- var_input_to_string( - data = vctr_2_tibble(unique(x$table_body$label)), - select_input = {{ row_level }}, - arg_name = "row_level", select_single = TRUE - ) + row_level <- + .select_to_varnames( + select = {{ row_level }}, + var_info = x$table_body$label, + arg_name = "row_level", + select_single = TRUE + ) # assessing if user selected total row if (!is.null(row_level) && row_level == x$inputs$margin_text && "..total.." %in% x$meta_data$variable) { @@ -626,9 +645,11 @@ inline_text.tbl_cross <- # selecting proper column name col_level <- - var_input_to_string( - data = vctr_2_tibble(col_lookup_table$input), arg_name = "col_level", - select_single = TRUE, select_input = {{ col_level }} + .select_to_varnames( + select = {{ col_level }}, + var_info = col_lookup_table$input, + arg_name = "col_level", + select_single = TRUE ) col_level <- col_lookup_table %>% @@ -636,6 +657,9 @@ inline_text.tbl_cross <- slice(1) %>% pull(.data$column_name) + # replacing passed data with, tbl_data (only data used in table) ----------- + x$inputs$data <- x$tbl_data + # evaluating inline_text for tbl_summary ----------------------------------- expr( inline_text.tbl_summary(x, variable = !!variable, level = !!row_level, diff --git a/R/modify.R b/R/modify.R index 2a7de4c48c..a7997644ad 100644 --- a/R/modify.R +++ b/R/modify.R @@ -94,9 +94,12 @@ modify_header <- function(x, update = NULL, stat_by = NULL, # converting update arg to a tidyselect list --------------------------------- update <- - tidyselect_to_list(x$table_body, {{ update }}, arg_name = "update") %>% - # adding the ... to the update list - c(list(...)) + .formula_list_to_named_list( + x = update, + var_info = x$table_header$column, + arg_name = "update" + ) %>% + c(list(...)) # adding the ... to the update list # running modify_header_internal function ------------------------------------ rlang::call2( @@ -122,7 +125,12 @@ modify_footnote <- function(x, update, abbreviation = FALSE) { x$table_header <- table_header_fill_missing(x$table_header, x$table_body) # converting update arg to a tidyselect list --------------------------------- - update <- tidyselect_to_list(x$table_body, {{ update }}, arg_name = "update") + update <- + .formula_list_to_named_list( + x = {{ update }}, + var_info = x$table_header$column, + arg_name = "update" + ) # updating footnote ---------------------------------------------------------- footnote_column_name <- ifelse(abbreviation == TRUE, "footnote_abbrev", "footnote") @@ -163,7 +171,12 @@ modify_spanning_header <- function(x, update) { x$table_header <- table_header_fill_missing(x$table_header, x$table_body) # converting update arg to a tidyselect list --------------------------------- - update <- tidyselect_to_list(x$table_body, {{ update }}, arg_name = "update") + update <- + .formula_list_to_named_list( + x = {{ update }}, + var_info = x$table_header$column, + arg_name = "update" + ) # updating footnote ---------------------------------------------------------- # convert named list to a tibble diff --git a/R/modify_table_header.R b/R/modify_table_header.R index 73a6cd7e72..a454c9e9b3 100644 --- a/R/modify_table_header.R +++ b/R/modify_table_header.R @@ -60,10 +60,12 @@ modify_table_header <- function(x, column, label = NULL, hide = NULL, align = NU # convert column input to string --------------------------------------------- column <- - var_input_to_string( - data = vctr_2_tibble(x$table_header$column), arg_name = "column", - select_single = FALSE, select_input = {{ column }} + .select_to_varnames( + select = {{ column }}, + var_info = x$table_header$column, + arg_name = "column" ) + # if no columns selected, returning unaltered if (is.null(column)) return(x) diff --git a/R/reexport.R b/R/reexport.R index 2e39285eaa..c2e66b90a4 100644 --- a/R/reexport.R +++ b/R/reexport.R @@ -8,6 +8,31 @@ tibble::as_tibble #' @importFrom knitr knit_print knitr::knit_print +# broom.helpers ---------------------------------------------------------------- +#' @export +#' @importFrom broom.helpers all_continuous +broom.helpers::all_continuous + +#' @export +#' @importFrom broom.helpers all_categorical +broom.helpers::all_categorical + +#' @export +#' @importFrom broom.helpers all_dichotomous +broom.helpers::all_dichotomous + +#' @export +#' @importFrom broom.helpers all_interaction +broom.helpers::all_interaction + +#' @export +#' @importFrom broom.helpers all_intercepts +broom.helpers::all_intercepts + +#' @export +#' @importFrom broom.helpers all_contrasts +broom.helpers::all_contrasts + # dplyr ------------------------------------------------------------------------ #' @export #' @importFrom dplyr %>% diff --git a/R/select_helpers.R b/R/select_helpers.R index 963fcc93c2..ae107e3883 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -1,17 +1,15 @@ #' Select helper functions #' -#' Set of functions to supplement the {tidyselect} set of functions for selecting -#' columns of data frames. `all_continuous()`, `all_continuous2()`, `all_categorical()`, and -#' `all_dichotomous()` may only be used with `tbl_summary()`, where each variable -#' has been classified into one of these three groups. All other helpers -#' are available throughout the package. +#' @description Set of functions to supplement the {tidyselect} set of +#' functions for selecting columns of data frames (and other items as well). +#' - `all_continuous()` selects continuous variables +#' - `all_continuous2()` selects only type `"continuous2"` +#' - `all_categorical()` selects categorical (including `"dichotomous"`) variables +#' - `all_dichotomous()` selects only type `"dichotomous"` +#' - `all_interaction()` selects interaction terms from a regression model +#' - `all_intercepts()` selects intercept terms from a regression model +#' - `all_contrasts()` selects variables in regression model based on their type of contrast #' @name select_helpers -#' @rdname select_helpers -#' @param dichotomous Logical indicating whether to include dichotomous variables. -#' Default is `TRUE` -#' @param continuous2 Logical indicating whether to include continuous2 variables. -#' Default is `TRUE` -#' @export #' @return A character vector of column names selected #' @examples #' select_ex1 <- @@ -21,84 +19,16 @@ #' statistic = all_continuous() ~ "{mean} ({sd})", #' type = all_dichotomous() ~ "categorical" #' ) - -# THE ENVIRONMENTS ARE CREATED IN `utils-gtsummary_core.R` -all_continuous <- function(continuous2 = TRUE) { - if (continuous2) con_types <- c("continuous", "continuous2") - else con_types <- "continuous" - - meta_data_env$summary_type %>% - keep(meta_data_env$summary_type %in% con_types) %>% - names() -} +#' @section Example Output: +#' \if{html}{Example 1} +#' +#' \if{html}{\figure{select_ex1.png}{options: width=55\%}} +NULL #' @rdname select_helpers #' @export all_continuous2 <- function() { - meta_data_env$summary_type %>% - keep(meta_data_env$summary_type %in% "continuous2") %>% - names() -} - -#' @rdname select_helpers -#' @export -all_categorical <- function(dichotomous = TRUE) { - # return variable names if dichotomous included - if (dichotomous) { - x <- - keep(meta_data_env$summary_type, ~ . %in% c("categorical", "dichotomous")) %>% - names() - return(x) - } - - # return variable names if dichotomous NOT included - meta_data_env$summary_type %>% - keep(meta_data_env$summary_type == "categorical") %>% - names() + .generic_selector("variable", "var_type", + .data$var_type %in% "continuous2", + fun_name = "all_continuous") } - -#' @rdname select_helpers -#' @export -all_dichotomous <- function() { - meta_data_env$summary_type %>% - keep(meta_data_env$summary_type == "dichotomous") %>% - names() -} - -#' @rdname select_helpers -#' @export -all_numeric <- function() { - which(data_env$numeric) -} - -#' @rdname select_helpers -#' @export -all_character <- function() { - which(data_env$character) -} - -#' @rdname select_helpers -#' @export -all_integer <- function() { - which(data_env$integer) -} - -#' @rdname select_helpers -#' @export -all_double <- function() { - which(data_env$double) -} - -#' @rdname select_helpers -#' @export -all_logical <- function() { - which(data_env$logical) -} - -#' @rdname select_helpers -#' @export -all_factor <- function() { - which(data_env$factor) -} - - diff --git a/R/sysdata.rda b/R/sysdata.rda index 5fcc62f6d4..273c685815 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/tbl_cross.R b/R/tbl_cross.R index 507a498eb7..268974b1a9 100644 --- a/R/tbl_cross.R +++ b/R/tbl_cross.R @@ -68,15 +68,21 @@ tbl_cross <- function(data, data <- data %>% ungroup() # converting inputs to string ------------------------------------------------ - row <- var_input_to_string( - data = data, select_input = !!rlang::enquo(row), - arg_name = "row", select_single = TRUE - ) + row <- + .select_to_varnames( + select = {{ row }}, + data = data, + arg_name = "row", + select_single = TRUE + ) - col <- var_input_to_string( - data = data, select_input = !!rlang::enquo(col), - arg_name = "col", select_single = TRUE - ) + col <- + .select_to_varnames( + select = {{ col }}, + data = data, + arg_name = "col", + select_single = TRUE + ) # matching arguments --------------------------------------------------------- missing <- match.arg(missing) @@ -114,7 +120,7 @@ tbl_cross <- function(data, } # get labels ----------------------------------------------------------------- - label <- tidyselect_to_list(data, label) + label <- .formula_list_to_named_list(x = label, data = data) new_label <- list() new_label[[row]] <- label[[row]] %||% attr(data[[row]], "label") %||% row diff --git a/R/tbl_regression.R b/R/tbl_regression.R index 15799c2cdd..61423aa320 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -55,6 +55,7 @@ #' @param tidy_fun Option to specify a particular tidier function if the #' model is not a [vetted model][vetted_models] or you need to implement a #' custom method. Default is `NULL` +#' @param add_estimate_to_reference_rows add a reference value. Default is FALSE #' @param ... Not used #' @param exclude DEPRECATED #' @param show_yesno DEPRECATED @@ -106,6 +107,7 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, conf.level = NULL, intercept = FALSE, estimate_fun = NULL, pvalue_fun = NULL, tidy_fun = broom::tidy, + add_estimate_to_reference_rows = FALSE, show_yesno = NULL, exclude = NULL, ...) { # deprecated arguments ------------------------------------------------------- if (!is.null(show_yesno)) { @@ -116,7 +118,7 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, } if (!rlang::quo_is_null(rlang::enquo(exclude))) { - lifecycle::deprecate_warn( + lifecycle::deprecate_stop( "1.2.5", "gtsummary::tbl_regression(exclude = )", "tbl_regression(include = )", @@ -147,6 +149,10 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, conf.level %||% get_theme_element("tbl_regression-arg:conf.level") %||% getOption("gtsummary.conf.level", default = 0.95) + add_estimate_to_reference_rows <- + add_estimate_to_reference_rows %||% + get_theme_element("tbl_regression-arg:add_estimate_to_reference_rows", default = FALSE) + # checking estimate_fun and pvalue_fun are functions if (!purrr::every(list(estimate_fun, pvalue_fun, tidy_fun %||% pvalue_fun), is.function)) { @@ -155,7 +161,6 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, } include <- rlang::enquo(include) - exclude <- rlang::enquo(exclude) show_single_row <- rlang::enquo(show_single_row) # will return call, and all object passed to in tbl_regression call @@ -165,32 +170,26 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, table_body <- tidy_prep(x, tidy_fun = tidy_fun, exponentiate = exponentiate, conf.level = conf.level, intercept = intercept, - label = label, show_single_row = !!show_single_row) + label = label, show_single_row = !!show_single_row, + include = !!include, + add_estimate_to_reference_rows = add_estimate_to_reference_rows) - # saving evaluated `label`, and `show_single_row` + # saving evaluated `label`, `show_single_row`, and `include` ----------------- func_inputs$label <- - unique(table_body$variable) %>% - vctr_2_tibble() %>% - tidyselect_to_list(x = {{ label }}, arg_name = "label") - func_inputs$show_single_row <- - unique(table_body$variable) %>% - vctr_2_tibble() %>% - var_input_to_string(arg_name = "show_single_row", select_input = {{show_single_row}}) - - # including and excluding variables indicated - include <- var_input_to_string(data = vctr_2_tibble(unique(table_body$variable)), - arg_name = "include", select_input = !!include) - exclude <- var_input_to_string(data = vctr_2_tibble(unique(table_body$variable)), - arg_name = "exclude", select_input = !!exclude) - - include <- include %>% setdiff(exclude) + .formula_list_to_named_list( + x = label, + var_info = table_body, + arg_name = "label" + ) - # saving the evaluated lists (named lists) as the function inputs - func_inputs$include <- include - func_inputs$exclude <- NULL # making this NULL since it's deprecated + func_inputs$show_single_row <- + .select_to_varnames( + select = !!show_single_row, + var_info = table_body, + arg_name = "show_single_row" + ) - # keeping variables indicated in `include` - table_body <- table_body %>% filter(.data$variable %in% include) + func_inputs$include <- unique(table_body$variable) # model N n <- pluck(table_body, "N", 1) @@ -243,7 +242,7 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE, # setting default table_header values results <- - .tbl_reression_default_table_header( + .tbl_regression_default_table_header( results, exponentiate = exponentiate, tidy_columns_to_report = tidy_columns_to_report, diff --git a/R/tbl_summary.R b/R/tbl_summary.R index da22292329..da5b39a9de 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -207,8 +207,10 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, data <- data %>% ungroup() # converting bare arguments to string ---------------------------------------- - by <- var_input_to_string(data = data, select_input = !!rlang::enquo(by), - arg_name = "by", select_single = TRUE) + by <- .select_to_varnames(select = {{ by }}, + data = data, + arg_name = "by", + select_single = TRUE) # matching arguments --------------------------------------------------------- missing <- match.arg(missing, choices = c("ifany", "always", "no")) @@ -284,10 +286,12 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, df_stats = df_stats, missing = missing, missing_text = missing_text ) } - ) + ), + var_class = map_chr(.data$class, pluck, 1) ) %>% - pull(.data$tbl_stats) %>% - purrr::reduce(bind_rows) + select(var_type = .data$summary_type, .data$var_class, .data$var_label, .data$tbl_stats) %>% + unnest(.data$tbl_stats) %>% + select(.data$variable, .data$var_type, .data$var_class, .data$var_label, everything()) # table of column headers ---------------------------------------------------- table_header <- @@ -365,7 +369,7 @@ removing_variables_with_unsupported_types <- function(data, include, classes_exp # for survey objects pass the full survey object to `survey` argument, and `design$variables` to `data` argument generate_metadata <- function(data, value, by, classes_expected, type, label, statistic, digits, percent, sort, survey = NULL) { # converting tidyselect formula lists to named lists ------------------------- - value <- tidyselect_to_list(data, value, arg_name = "value") + value <- .formula_list_to_named_list(x = value, data = data, arg_name = "value") # creating a table with meta data about each variable ------------------------ meta_data <- tibble( @@ -386,7 +390,10 @@ generate_metadata <- function(data, value, by, classes_expected, type, label, st # updating type of user supplied one if (!is.null(type)) { # converting tidyselect formula lists to named lists - type <- tidyselect_to_list(data, type, .meta_data = meta_data, arg_name = "type") + type <- .formula_list_to_named_list(x = type, + data = data, + var_info = meta_data_to_var_info(meta_data) , + arg_name = "type") # updating meta data object with new types meta_data <- @@ -400,10 +407,22 @@ generate_metadata <- function(data, value, by, classes_expected, type, label, st } # converting tidyselect formula lists to named lists ------------------------- - label <- tidyselect_to_list(data, label, .meta_data = meta_data, arg_name = "label") - statistic <- tidyselect_to_list(data, statistic, .meta_data = meta_data, arg_name = "statistic") - digits <- tidyselect_to_list(data, digits, .meta_data = meta_data, arg_name = "digits") - sort <- tidyselect_to_list(data, sort, .meta_data = meta_data) + label <- .formula_list_to_named_list(x = label, + data = data, + var_info = meta_data_to_var_info(meta_data) , + arg_name = "label") + statistic <- .formula_list_to_named_list(x = statistic, + data = data, + var_info = meta_data_to_var_info(meta_data) , + arg_name = "statistic") + digits <- .formula_list_to_named_list(x = digits, + data = data, + var_info = meta_data_to_var_info(meta_data) , + arg_name = "digits") + sort <- .formula_list_to_named_list(x = sort, + data = data, + var_info = meta_data_to_var_info(meta_data) , + arg_name = "sort") # assigning variable characteristics ----------------------------------------- if (is.null(survey)) { diff --git a/R/tbl_survfit.R b/R/tbl_survfit.R index 31a7e03798..93b2352ccf 100644 --- a/R/tbl_survfit.R +++ b/R/tbl_survfit.R @@ -242,10 +242,13 @@ tbl_survfit.list <- function(x, times = NULL, probs = NULL, ) # apply labels - label <- tidyselect_to_list( - .data = vctr_2_tibble(unique(meta_data$variable)), - x = label, arg_name = "label" - ) + label <- + .formula_list_to_named_list( + x = label, + var_info = meta_data_to_var_info(meta_data), + arg_name = "label" + ) + meta_data <- meta_data %>% mutate( @@ -267,7 +270,11 @@ tbl_survfit.list <- function(x, times = NULL, probs = NULL, } # table_header --------------------------------------------------------------- - table_body <- map_dfr(meta_data$table_body, ~.x) + table_body <- + meta_data %>% + select(.data$var_label, .data$table_body) %>% + unnest(.data$table_body) %>% + select(.data$variable, .data$var_label, everything()) table_header <- tibble(column = names(table_body)) %>% table_header_fill_missing() diff --git a/R/tbl_svysummary.R b/R/tbl_svysummary.R index 35cddb77c1..edcf2cfb6e 100644 --- a/R/tbl_svysummary.R +++ b/R/tbl_svysummary.R @@ -150,8 +150,13 @@ tbl_svysummary <- function(data, by = NULL, label = NULL, statistic = NULL, get_theme_element("tbl_summary-arg:percent", default = "column") # converting bare arguments to string ---------------------------------------- - by <- var_input_to_string(data = data$variables, select_input = !!rlang::enquo(by), - arg_name = "by", select_single = TRUE) + by <- + .select_to_varnames( + select = {{ by }}, + data = data$variables, + arg_name = "by", + select_single = TRUE + ) # matching arguments --------------------------------------------------------- missing <- match.arg(missing, choices = c("ifany", "always", "no")) @@ -221,10 +226,12 @@ tbl_svysummary <- function(data, by = NULL, label = NULL, statistic = NULL, df_stats = df_stats, missing = missing, missing_text = missing_text ) } - ) + ), + var_class = map_chr(.data$class, pluck, 1) ) %>% - pull(.data$tbl_stats) %>% - purrr::reduce(bind_rows) + select(var_type = .data$summary_type, .data$var_class, .data$var_label, .data$tbl_stats) %>% + unnest(.data$tbl_stats) %>% + select(.data$variable, .data$var_type, .data$var_class, .data$var_label, everything()) # table of column headers ---------------------------------------------------- table_header <- diff --git a/R/tbl_uvregression.R b/R/tbl_uvregression.R index 249b700b40..693a1a2455 100644 --- a/R/tbl_uvregression.R +++ b/R/tbl_uvregression.R @@ -83,6 +83,7 @@ tbl_uvregression <- function(data, method, y = NULL, x = NULL, method.args = NUL include = everything(), tidy_fun = NULL, hide_n = FALSE, show_single_row = NULL, conf.level = NULL, estimate_fun = NULL, pvalue_fun = NULL, formula = "{y} ~ {x}", + add_estimate_to_reference_rows = NULL, show_yesno = NULL, exclude = NULL) { # deprecated arguments ------------------------------------------------------- if (!is.null(show_yesno)) { @@ -148,14 +149,14 @@ tbl_uvregression <- function(data, method, y = NULL, x = NULL, method.args = NUL y <- rlang::enexpr(y) x <- tryCatch({ - var_input_to_string(data = data, select_input = !!x, arg_name = "x") + .select_to_varnames(select = !!x, data = data, arg_name = "x") }, error = function(e) { rlang::expr_text(x) }) y <- tryCatch({ - var_input_to_string(data = data, select_input = !!y, arg_name = "y") + .select_to_varnames(select = !!y, data = data, arg_name = "y") }, error = function(e) { rlang::expr_text(y) }) @@ -170,13 +171,24 @@ tbl_uvregression <- function(data, method, y = NULL, x = NULL, method.args = NUL stop("Select only a single column in argument `x=` or `y=`.", call. = FALSE) } - include <- var_input_to_string(data = data, select_input = !!rlang::enquo(include), - arg_name = "include") - exclude <- var_input_to_string(data = data, select_input = !!rlang::enquo(exclude), - arg_name = "exclude") - show_single_row <- var_input_to_string(data = data, - select_input = !!rlang::enquo(show_single_row), - arg_name = "show_single_row") + include <- + .select_to_varnames( + select = {{ include }}, + data = data, + arg_name = "include" + ) + exclude <- + .select_to_varnames( + select = {{ exclude }}, + data = data, + arg_name = "exclude" + ) + show_single_row <- + .select_to_varnames( + select = {{ show_single_row }}, + data = data, + arg_name = "show_single_row" + ) # checking formula correctly specified --------------------------------------- if (!rlang::is_string(formula)) { @@ -201,8 +213,14 @@ tbl_uvregression <- function(data, method, y = NULL, x = NULL, method.args = NUL } # converting tidyselect formula lists to named lists ------------------------- - label <- tidyselect_to_list(data, label, .meta_data = NULL, arg_name = "label") - # all sepcifed labels must be a string of length 1 + label <- + .formula_list_to_named_list( + x = label, + data = data, + arg_name = "label" + ) + + # all specified labels must be a string of length 1 if (!every(label, ~ rlang::is_string(.x))) { stop("Each `label` specified must be a string of length 1.", call. = FALSE) } @@ -239,7 +257,7 @@ tbl_uvregression <- function(data, method, y = NULL, x = NULL, method.args = NUL # building regression models ------------------------------------------------- tbl_reg_args <- c("exponentiate", "conf.level", "label", "include", "show_single_row", - "tidy_fun", "estimate_fun", "pvalue_fun") + "tidy_fun", "estimate_fun", "pvalue_fun", "add_estimate_to_reference_rows") df_model <- tibble( diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 6d43a272ef..af45689d81 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -244,212 +244,9 @@ modify_header_internal <- function(x, stat_by = NULL, ..., x } -#' Convert tidyselect to variable list -#' -#' Functions takes a list of tidyselect formulas, e.g. `list(starts_with("age") ~ "continuous")`, -#' and returns a named list, e.g. `list(age = "continuous")`. -#' -#' @param .data data with variables to select from -#' @param x list of tidyselect formulas -#' @param .meta_data meta data from tbl_summary. Default is NULL -#' @param arg_name name of argument where selector is called -#' (aids in error messaging). Default is NULL -#' @param select_single Logical indicating if only a single column can be selected -#' @noRd -#' @keywords internal - -tidyselect_to_list <- function(.data, x, .meta_data = NULL, - arg_name = NULL, select_single = FALSE) { - # if NULL provided, return NULL ---------------------------------------------- - if (is.null(x)) { - return(NULL) - } - - # converting to list if single element passed -------------------------------- - if (inherits(x, "formula")) { - x <- list(x) - } - - # returning named list if passed --------------------------------------------- - if (!is.null(names(x)) && # names are non-null - length(names(x)) == length(x) && # name of every element of list - sum(names(x) == "") == 0) { # no names are blank - return(x) - } - - # check class of input ------------------------------------------------------- - # each element must be a formula - is_formula <- purrr::map_lgl(x, ~ inherits(.x, "formula")) - - if (!all(is_formula)) { - example_text <- - switch( - arg_name %||% "not_specified", - "type" = paste("type = list(age ~ \"continuous\", all_integer() ~ \"categorical\")", - collapse = "\n"), - "label" = paste("label = list(age ~ \"Age, years\", response ~ \"Tumor Response\")", - collapse = "\n"), - "statistic" = paste(c("statistic = list(all_continuous() ~ \"{mean} ({sd})\", all_categorical() ~ \"{n} / {N} ({p}%)\")", - "statistic = list(age ~ \"{median}\")"), - collapse = "\n"), - "digits" = paste(c("digits = list(age ~ 2)", - "digits = list(all_continuous() ~ 2)"), - collapse = "\n"), - "value" = paste(c("value = list(grade ~ \"III\")", - "value = list(all_logical() ~ FALSE)"), - collapse = "\n"), - "test" = paste(c("test = list(all_continuous() ~ \"t.test\")", - "test = list(age ~ \"kruskal.test\")"), - collapse = "\n") - ) %||% - paste(c("label = list(age ~ \"Age, years\")", - "statistic = list(all_continuous() ~ \"{mean} ({sd})\")", - "type = list(c(response, death) ~ \"categorical\")"), - collapse = "\n") - - # printing error for argument input - error_text <- ifelse( - !is.null(arg_name), - glue::glue("There was a problem with the `{arg_name}=` argument input. "), - glue::glue("There was a problem with one of the function argument inputs. ") - ) - stop(glue::glue( - "{error_text}", - "Below is an example of correct syntax.\n\n", - "{example_text}" - ), call. = FALSE) - } - - # converting all inputs to named list ---------------------------------------- - named_list <- - purrr::map( - x, - function(x) { - # for each formula extract lhs and rhs --------------------------------- - lhs <- var_input_to_string(data = .data, # convert lhs selectors to character - select_input = !!rlang::f_lhs(x), - meta_data = .meta_data, - arg_name = arg_name, - select_single = select_single, - env = rlang::f_env(x)) - - # evaluate RHS of formula in the original formula environment - rhs <- eval_rhs(x) - - # converting rhs and lhs into a named list - purrr::map(lhs, ~ list(rhs) %>% rlang::set_names(.x)) %>% - purrr::flatten() - } - ) %>% - purrr::flatten() - - # removing duplicates (using the last one listed if variable occurs more than once) - tokeep <- - names(named_list) %>% - rev() %>% - purrr::negate(duplicated)() %>% - rev() - named_list[tokeep] -} -#' Convert NSE or SE selectors to character -#' -#' The function accepts a mix of bare (aka symbol input), tidyselect, -#' multiple tidyselectors wrapped in vars(), -#' gtsummary selectors, string, or character vector inputs. NULL inputs -#' return NULL. -#' @param data a data frame from which columns are selected -#' @param var_input selector statement -#' @param meta_data optional argument for use with `all_categorical()`, -#' `all_dichotomous()`, and `all_continuous()` -#' -#' @return character vector of selected variable names -#' @keywords internal -#' @noRd -#' @examples -#' var_input_to_string(mtcars, select_input = vars(hp, mpg)) -#' var_input_to_string(mtcars, select_input = mpg) -#' var_input_to_string(mtcars, select_input = "mpg") -#' var_input_to_string(mtcars, select_input = c("hp", "mpg")) -#' var_input_to_string(mtcars, select_input = c(hp, mpg)) -#' var_input_to_string(mtcars, select_input = NULL) -#' var_input_to_string(mtcars, select_input = vars(everything(), -mpg)) -#' var_input_to_string(mtcars, select_input = c(everything(), -mpg)) -var_input_to_string <- function(data, meta_data = NULL, arg_name = NULL, - select_single = FALSE, select_input, env = NULL) { - - select_input <- rlang::enquo(select_input) - # if NULL passed, return NULL - if (rlang::quo_is_null(select_input)) { - return(NULL) - } - if (!is.null(env)) attr(select_input, ".Environment") <- env - - # converting to list before passing along to next function - select_input_list <- as.list(rlang::quo_get_expr(select_input)) - - # checking if the passed enquo begins with the vars() function - if (!rlang::quo_is_symbol(select_input) && # if not a symbol (ie name) - identical(eval(select_input_list[[1]]), dplyr::vars)) # and function is dplyr::vars - { - # first item of the list is vars(), removing and passing to tidyselect_to_string() - return(tidyselect_to_string(...data... = data, ...meta_data... = meta_data, - arg_name = arg_name, select_single = select_single, - !!!select_input_list[-1])) - } - - tidyselect_to_string(...data... = data, ...meta_data... = meta_data, - arg_name = arg_name, select_single = select_single, - !!select_input) -} - -# this function handles a single tidyselect function, or bare input -# do not call this function directly. do not pass a vars() -tidyselect_to_string <- function(...data..., ...meta_data... = NULL, - arg_name = NULL, select_single = FALSE, ...) { - - dots_enquo <- rlang::enquos(...) - - # scoping data to use gtsummary select functions - scoped_data(...data...) - if(!is.null(...meta_data...)) scoped_meta_data(...meta_data...) - - tryCatch({ - result <- - rlang::call2(dplyr::select, .data = ...data...[0, , drop = FALSE], !!!dots_enquo) %>% - rlang::eval_tidy() %>% - colnames() - - # if `!!!dots_enquo` resolves to a NULL object, the above call will return - # `character(0)`. If this occurs, return a NULL object - if (identical(result, character(0))) return(NULL) - }, - error = function(e) { - if (!is.null(arg_name)) - error_msg <- glue::glue("Error in `{arg_name}=` argument input. Select from ", - "{paste(sQuote(names(...data...)), collapse = ', ')}") - else error_msg <- as.character(e) - stop(error_msg, call. = FALSE) - }) - - # assuring only a single column is selected - if (select_single == TRUE && length(result) != 1) { - stop(glue::glue( - "Error in `{arg_name}=` argument input--select only a single column. ", - "The following columns were selected, ", - "{paste(sQuote(result), collapse = ', ')}" - ), call. = FALSE) - } - result -} - -# simple function to evaluate the RHS of a formula in the formula's environment -eval_rhs <- function(x) { - rlang::f_rhs(x) %>% rlang::eval_tidy(env = rlang::f_env(x)) -} - # select helpers environments -------------------------------------------------- # setting environments data_env <- rlang::new_environment() diff --git a/R/utils-tbl_regression.R b/R/utils-tbl_regression.R index 4008df961a..e6459189a4 100644 --- a/R/utils-tbl_regression.R +++ b/R/utils-tbl_regression.R @@ -1,87 +1,43 @@ -#' Takes a vector and transforms to data frame with those column names -#' -#' This will be used for tidyselect to used those functions to select from -#' the vector -#' @noRd -#' @keywords internal -vctr_2_tibble <- function(x) { - n <- length(x) - df <- matrix(ncol = n) %>% - tibble::as_tibble(.name_repair = "minimal") - - names(df) <- x - df[0, , drop = FALSE] -} - # prepares the tidy object to be printed with broom.helpers tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, - show_single_row) { - # run initial tidy ----------------------------------------------------------- - df_tidy_1 <- tryCatch({ - tidy_fun(x, exponentiate = exponentiate, conf.level = conf.level, conf.int = TRUE) - }, - error = function(e) { - ui_oops(paste0( - "There was an error calling {ui_code('tidy_fun')}.\n", - "Most likely, this is because the argument passed in {ui_code('tidy_fun=')} \n", - "was misspelled, does not exist, is not compatible with your object, \n", - "or was missing necessary arguments. See error message below. \n" + show_single_row, include, add_estimate_to_reference_rows) { + # quoting inputs + label <- rlang::enquo(label) + show_single_row <- rlang::enquo(show_single_row) + include <- rlang::enquo(include) + + # getting the default `tidy_plus_plus()` args + tidy_plus_plus_args <- + get_theme_element("tbl_regression-lst:tidy_plus_plus", default = list()) %>% + c(list( + conf.int = TRUE, + add_header_rows = TRUE )) - stop(as.character(e), call. = FALSE) - }) - - # checking reserved names in the tidy data frame - if (any(c("rowname", "groupname_col") %in% names(df_tidy_1))) { - paste("The resulting tibble from the initial tidying of the model", - "(likely from the tidier passed in `tidy_fun=`)", - "contains a column named 'rowname' or 'groupname_col'.", - "These column names result in special print behavior in the", - "{gt} package, and may cause errors or malformed tables.") %>% - stringr::str_wrap() %>% - rlang::inform() - } - - # attach model object to tidy tibble ----------------------------------------- - df_tidy_2 <- broom.helpers::tidy_attach_model(x = df_tidy_1, model = x) - # remove intercept from output ----------------------------------------------- - if (!intercept) df_tidy_2 <- broom.helpers::tidy_remove_intercept(df_tidy_2) - - # identify variables in model ------------------------------------------------ - df_tidy_3 <- broom.helpers::tidy_identify_variables(df_tidy_2) %>% - # if intercept remains filling in the variable name withe intercept - dplyr::mutate(variable = dplyr::coalesce(.data$variable, .data$term)) - if (all(is.na(df_tidy_3$variable))) { # when variables are all missing, print this - ui_oops("Review the GitHub issue linked below for a possible solution.") - ui_code_block("https://github.com/ddsjoberg/gtsummary/issues/231") - } - - # creating label and show_single_row named lists ----------------------------- - label <- unique(df_tidy_3$variable) %>% vctr_2_tibble() %>% - tidyselect_to_list(x = {{ label }}, arg_name = "label") - show_single_row <- unique(df_tidy_3$variable) %>% vctr_2_tibble() %>% - var_input_to_string(arg_name = "show_single_row", select_input = {{show_single_row}}) - - # add reference row ---------------------------------------------------------- - df_tidy_4 <- broom.helpers::tidy_add_reference_rows(df_tidy_3) - - # add header rows to categorical variables - df_tidy_5 <- - broom.helpers::tidy_add_variable_labels(df_tidy_4, labels = label) - - # add header rows to categorical variables ----------------------------------- - df_tidy_6 <- - broom.helpers::tidy_add_header_rows(df_tidy_5, strict = TRUE, - show_single_row = show_single_row) - - # add reference row value, requested ----------------------------------------- - if (get_theme_element("tbl_regression-lgl:add_ref_est", default = FALSE)) { - df_tidy_6 <- - broom.helpers::tidy_add_estimate_to_reference_rows(df_tidy_6, exponentiate = exponentiate) - } + # keeping the first arg listed if duplicated (first is the user-specified one) + tidy_plus_plus_args <- + tidy_plus_plus_args[names(tidy_plus_plus_args) %>% {!duplicated(.)}] + + # tidying up the tidy data frame with `broom.helpers::tidy_plus_plus()` + df_tidy <- + rlang::expr( + broom.helpers::tidy_plus_plus( + model = !!x, + tidy_fun = !!tidy_fun, + exponentiate = !!exponentiate, + variable_labels = !!label, + show_single_row = !!show_single_row, + intercept = !!intercept, + include = !!include, + conf.level = !!conf.level, + add_estimate_to_reference_rows = !!add_estimate_to_reference_rows, + strict = TRUE, + !!!tidy_plus_plus_args + ) + ) %>% rlang::eval_tidy() # final tidying before returning --------------------------------------------- - df_tidy_6 %>% + df_tidy %>% mutate( N = nrow(gtsummary_model_frame(x)), row_type = ifelse(.data$header_row | is.na(.data$header_row), "label", "level") @@ -105,7 +61,7 @@ gtsummary_model_frame <- function(x) { ) } -.tbl_reression_default_table_header <- function(x, exponentiate, +.tbl_regression_default_table_header <- function(x, exponentiate, tidy_columns_to_report, estimate_fun, pvalue_fun, diff --git a/R/utils-tbl_summary.R b/R/utils-tbl_summary.R index ed8caef7b9..3f62944767 100644 --- a/R/utils-tbl_summary.R +++ b/R/utils-tbl_summary.R @@ -1290,3 +1290,26 @@ has_na <- function(data, variable) { sum(is.na(data[[variable]])) > 0 } } + +# convert a tbl_summary meta_data object to a var_info tibble +meta_data_to_var_info <- function(meta_data) { + var_info <- + meta_data %>% + select(any_of(c("variable", "summary_type", "class", "var_label"))) + + if ("class" %in% names(var_info)){ + var_info <- + var_info %>% + mutate(var_class = map_chr(.data$class, pluck, 1)) %>% + select(-.data$class) + } + if ("summary_type" %in% names(var_info)) + var_info <- select(var_info, var_type = .data$summary_type, everything()) + + var_info +} + +# simple function to evaluate the RHS of a formula in the formula's environment +eval_rhs <- function(x) { + rlang::f_rhs(x) %>% rlang::eval_tidy(env = rlang::f_env(x)) +} diff --git a/R/where.R b/R/where.R deleted file mode 100644 index 6b67fc7aee..0000000000 --- a/R/where.R +++ /dev/null @@ -1,19 +0,0 @@ -#' Copy of tidyselect's unexported `where()` function -#' -#' Need this function when we do checks if the select helpers are wrapped in `var()`. -#' If it is not present, users cannot use `where(is.numeric)` type selectors. -#' @noRd - -where <- function(fn) { - predicate <- rlang::as_function(fn) - - function(x, ...) { - out <- predicate(x, ...) - - if (!rlang::is_bool(out)) { - abort("`where()` must be used with functions that return `TRUE` or `FALSE`.") - } - - out - } -} diff --git a/data-raw/gtsummary_theme_elements.csv b/data-raw/gtsummary_theme_elements.csv index d076e06d47..0059908f2c 100644 --- a/data-raw/gtsummary_theme_elements.csv +++ b/data-raw/gtsummary_theme_elements.csv @@ -1,67 +1,68 @@ fn,name,argument,desc,example -Package-wide,pkgwide-str:theme_name,FALSE,optional name of theme; name is printed when theme loaded,"""My Personal Theme""" -Package-wide,pkgwide-str:print_engine,FALSE,"string indicating the default print engine; default is `""gt""`","""flextable""" -Package-wide,pkgwide-fn:pvalue_fun,FALSE,function to style p-values throughout package; default is `style_pvalue`,"function(x) style_pvalue(x, digits = 2)" +add_global_p,add_global_p-str:type,FALSE,set argument default for `add_global_p.tbl_regression(type=)` and `add_global_p.tbl_uvregression(type=)`,"""II""" +add_global_p,add_global_p-str:type,FALSE,"set argument default for `add_global_p.tbl_regression(type=)` and `add_global_p.tbl_uvregression(type=)`; default is `""III""`","""II""" +add_p.tbl_cross,add_p.tbl_cross-arg:pvalue_fun,TRUE,, +add_p.tbl_cross,add_p.tbl_cross-arg:source_note ,TRUE,, +add_p.tbl_cross,add_p.tbl_cross-arg:test,TRUE,, +add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical,FALSE,default test for categorical/dichotomous variables,"""chisq.test""" +add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical.group_by2,FALSE,default test for categorical/dichotomous grouped/correlated variables with a 2-level by variable,"""lme4""" +add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical.low_count,FALSE,default test for categorical/dichotomous variables with minimum expected count <5,"""fisher.test""" +add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous,FALSE,default test for continuous variables with a 3- or more level by variable,"""aov""" +add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous.group_by2,FALSE,default test for continuous grouped/correlated variables with a 2-level by variable,"""lme4""" +add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous_by2,FALSE,default test for continuous variables with a 2-level by variable,"""t.test""" +add_p.tbl_summary,add_p.tbl_summary-arg:pvalue_fun,TRUE,, +add_p.tbl_summary,add_p.tbl_summary-arg:test,TRUE,, +add_p.tbl_svysummary,add_p.tbl_svysummary-attr:test.categorical,FALSE,default test for categorical/dichotomous variables,"""svy.chisq.test""" +add_p.tbl_svysummary,add_p.tbl_svysummary-attr:test.continuous,FALSE,default test for continuous variables,"""svy.wilcox.test""" +add_p.tbl_svysummary,add_p.tbl_svysummary-arg:pvalue_fun,TRUE,, +add_p.tbl_svysummary,add_p.tbl_svysummary-arg:test,TRUE,, +add_q,add_q-arg:method,TRUE,, +add_q,add_q-arg:pvalue_fun,TRUE,, +add_stat_label,add_stat_label-arg:location,TRUE,, +as_flex_table,as_flex_table-lst:addl_cmds,FALSE,"named list of expressions of {flextable} package commands inserted in the `as_flex_table()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_flex_table(x, return_calls = TRUE)` and check the names.","list(autofit = list(rlang::expr(flextable::font(fontname = ""Bodoni 72"", part = ""all"")), rlang::expr(flextable::fontsize(size = 8, part = ""all""))))" +as_gt,as_gt-lst:addl_cmds,FALSE,"named list of expressions of {gt} package commands inserted in the `as_gt()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_gt(x, return_calls = TRUE)` and check the names.",list(tab_spanner = rlang::expr(gt::tab_options(table.font.size = 'small'))) +as_hux_table,as_hux_table.gtsummary-lst:addl_cmds,FALSE,"named list of expressions of {huxtable} package commands inserted in the `as_hux_table()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_hux_table(x, return_calls = TRUE)` and check the names.", +as_kable_extra,as_kable_extra-lst:addl_cmds,FALSE,"named list of expressions of {kableExtra} package commands inserted in the `as_kable_extra()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_kable_extra(x, return_calls = TRUE)` and check the names.", Package-wide,pkgwide-fn:prependpvalue_fun,FALSE,"function to style p-values throughout package that include a ""p"" prefix, e.g. ""p<0.001"" or ""p=0.12""; this is common in the `inline_text()` functions; default is `function(x) style_pvalue(x, prepend_p = TRUE)`","function(x) style_pvalue(x, digits = 2, prepend_p = TRUE)" +Package-wide,pkgwide-fn:pvalue_fun,FALSE,function to style p-values throughout package; default is `style_pvalue`,"function(x) style_pvalue(x, digits = 2)" Package-wide,pkgwide-lgl:quiet,FALSE,logical indicating whether to suppress messages or not; default is `FALSE`, -Package-wide,pkgwide-str:language,FALSE,"string indicating language; default is `""en""`","""es""" Package-wide,pkgwide-str:ci.sep,FALSE,"string indicating separator between upper and lower bounds of confidence intervals. Default is `"", ""`",""" to """ +Package-wide,pkgwide-str:language,FALSE,"string indicating language; default is `""en""`","""es""" +Package-wide,pkgwide-str:print_engine,FALSE,"string indicating the default print engine; default is `""gt""`","""flextable""" +Package-wide,pkgwide-str:theme_name,FALSE,optional name of theme; name is printed when theme loaded,"""My Personal Theme""" +style_number,style_number-arg:big.mark,TRUE,, +style_number,style_number-arg:decimal.mark,TRUE,, +tbl_regression,tbl_regression-chr:tidy_columns,FALSE,"character vector of columns from `tidy_fun=` tibble to print. 'estimate' column will always be printed. Select among columns 'conf.low', 'conf.high', 'std.error', 'statistic', or 'p.value'.","c(""std.error"", ""p.value"")" +tbl_regression,tbl_regression-lst:tidy_plus_plus,FALSE,"Additional `tidy_plus_plus()` arguments. Cannot be one of `model=`, `tidy_fun=`, `exponentiate=`, `variable_labels=`, `show_single_row=`, `intercept=`, `include=`, `conf.level=`, or `strict=` as these are controlled by `tbl_summary()`. The default value for the additional arguments is `list(conf.int = TRUE, add_header_rows = TRUE, add_estimate_to_reference_rows = FALSE)`.","list(conf.int = TRUE, add_header_rows = TRUE, add_estimate_to_reference_rows = TRUE)" +tbl_regression,tbl_regression-str:coef_header,FALSE,"string setting the default term for the beta coefficient column header; default is `""Beta""`","ifelse(exponentiate == TRUE, ""exp(coef)"", ""coef"")" +tbl_regression,tbl_regression-str:ref_row_text,FALSE,string indicating the text to print on reference rows (default is an em-dash),"""Reference""" +tbl_regression,tbl_regression-arg:conf.level,TRUE,, +tbl_regression,tbl_regression-arg:estimate_fun ,TRUE,, +tbl_regression,tbl_regression-arg:pvalue_fun ,TRUE,, +tbl_regression,tbl_regression-arg:add_estimate_to_reference_rows,TRUE,, +tbl_regression,tbl_regression-arg:tidy_fun ,TRUE,, tbl_stack,tbl_stack-str:group_header,FALSE,"string indicating the group column header used in `as_tibble()`, `as_flex_table()`, etc. where row headers are not supported; default is `""**Group**""`","""**Group Status**""" -as_gt,as_gt-lst:addl_cmds,FALSE,"named list of expressions of {gt} package commands inserted in the `as_gt()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_gt(x, return_calls = TRUE)` and check the names.",list(tab_spanner = rlang::expr(gt::tab_options(table.font.size = 'small'))) -as_flex_table,as_flex_table-lst:addl_cmds,FALSE,"named list of expressions of {flextable} package commands inserted in the `as_flex_table()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_flex_table(x, return_calls = TRUE)` and check the names.","list(autofit = list(rlang::expr(flextable::font(fontname = ""Bodoni 72"", part = ""all"")), rlang::expr(flextable::fontsize(size = 8, part = ""all""))))" -as_kable_extra,as_kable_extra-lst:addl_cmds,FALSE,"named list of expressions of {kableExtra} package commands inserted in the `as_kable_extra()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_kable_extra(x, return_calls = TRUE)` and check the names.", -as_hux_table,as_hux_table.gtsummary-lst:addl_cmds,FALSE,"named list of expressions of {huxtable} package commands inserted in the `as_hux_table()` call; do not include the `data=` argument; the list of expressions is inserted after the named call, e.g. if the named list element is `""tab_spanner""` the expressions will be inserted after expressions named `""tab_spanner""`; to see the names of the expressions run `as_hux_table(x, return_calls = TRUE)` and check the names.", -tbl_summary,tbl_summary-arg:label,TRUE,, -tbl_summary,tbl_summary-arg:statistic,TRUE,, +tbl_summary,tbl_summary-fn:N_fun,FALSE,function to style integers. Currently questioning...THIS MAY BE REMOVED IN A FUTURE RELEASE. Use `style_number-arg:big.mark` and `style_number-arg:decimal.mark` instead.,"function(x) sprintf(""%.0f"", x)" +tbl_summary,tbl_summary-fn:percent_fun,FALSE,function to style percentages; default is `style_percent`,function(x) style_percent(x) +tbl_summary,tbl_summary-str:categorical_stat,FALSE,"glue string defining the default categorical and dichotomous summary statistics to display; default is `""{n} ({p}%)""`","""{n} / {N} ({p}%)""" +tbl_summary,tbl_summary-str:continuous_stat,FALSE,"glue string defining the default continuous summary statistics to display; default is `""{median} ({p25}, {p75})""`","""{mean} ({sd})""" +tbl_summary,tbl_summary-str:default_con_type,FALSE,"string indicating the default summary type for continuous variables; default is `""continuous""`; update to `""continuous2""` for multi-line summaries of continuous variables","""continuous2""" tbl_summary,tbl_summary-arg:digits,TRUE,, -tbl_summary,tbl_summary-arg:type,TRUE,, -tbl_summary,tbl_summary-arg:value,TRUE,, +tbl_summary,tbl_summary-arg:label,TRUE,, tbl_summary,tbl_summary-arg:missing,TRUE,, tbl_summary,tbl_summary-arg:missing_text,TRUE,, tbl_summary,tbl_summary-arg:percent,TRUE,, tbl_summary,tbl_summary-arg:sort,TRUE,, -tbl_summary,tbl_summary-fn:percent_fun,FALSE,function to style percentages; default is `style_percent`,function(x) style_percent(x) -tbl_summary,tbl_summary-fn:N_fun,FALSE,function to style integers. Currently questioning...THIS MAY BE REMOVED IN A FUTURE RELEASE. Use `style_number-arg:big.mark` and `style_number-arg:decimal.mark` instead.,"function(x) sprintf(""%.0f"", x)" -tbl_summary,tbl_summary-str:continuous_stat,FALSE,"glue string defining the default continuous summary statistics to display; default is `""{median} ({p25}, {p75})""`","""{mean} ({sd})""" -tbl_summary,tbl_summary-str:categorical_stat,FALSE,"glue string defining the default categorical and dichotomous summary statistics to display; default is `""{n} ({p}%)""`","""{n} / {N} ({p}%)""" -tbl_summary,tbl_summary-str:default_con_type,FALSE,"string indicating the default summary type for continuous variables; default is `""continuous""`; update to `""continuous2""` for multi-line summaries of continuous variables","""continuous2""" -tbl_svysummary,tbl_svysummary-arg:label,TRUE,, -tbl_svysummary,tbl_svysummary-arg:statistic,TRUE,, +tbl_summary,tbl_summary-arg:statistic,TRUE,, +tbl_summary,tbl_summary-arg:type,TRUE,, +tbl_summary,tbl_summary-arg:value,TRUE,, +tbl_survfit,tbl_survfit-arg:statistic,TRUE,, tbl_svysummary,tbl_svysummary-arg:digits,TRUE,, -tbl_svysummary,tbl_svysummary-arg:type,TRUE,, -tbl_svysummary,tbl_svysummary-arg:value,TRUE,, +tbl_svysummary,tbl_svysummary-arg:label,TRUE,, tbl_svysummary,tbl_svysummary-arg:missing,TRUE,, tbl_svysummary,tbl_svysummary-arg:missing_text,TRUE,, tbl_svysummary,tbl_svysummary-arg:percent,TRUE,, tbl_svysummary,tbl_svysummary-arg:sort,TRUE,, -add_p.tbl_summary,add_p.tbl_summary-arg:test,TRUE,, -add_p.tbl_summary,add_p.tbl_summary-arg:pvalue_fun,TRUE,, -add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous_by2,FALSE,default test for continuous variables with a 2-level by variable,"""t.test""" -add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous,FALSE,default test for continuous variables with a 3- or more level by variable,"""aov""" -add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical,FALSE,default test for categorical/dichotomous variables,"""chisq.test""" -add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical.low_count,FALSE,default test for categorical/dichotomous variables with minimum expected count <5,"""fisher.test""" -add_p.tbl_summary,add_p.tbl_summary-attr:test.categorical.group_by2,FALSE,default test for categorical/dichotomous grouped/correlated variables with a 2-level by variable,"""lme4""" -add_p.tbl_summary,add_p.tbl_summary-attr:test.continuous.group_by2,FALSE,default test for continuous grouped/correlated variables with a 2-level by variable,"""lme4""" -add_p.tbl_svysummary,add_p.tbl_svysummary-arg:test,TRUE,, -add_p.tbl_svysummary,add_p.tbl_svysummary-arg:pvalue_fun,TRUE,, -add_p.tbl_svysummary,add_p.tbl_svysummary-attr:test.continuous,FALSE,default test for continuous variables,"""svy.wilcox.test""" -add_p.tbl_svysummary,add_p.tbl_svysummary-attr:test.categorical,FALSE,default test for categorical/dichotomous variables,"""svy.chisq.test""" -add_stat_label,add_stat_label-arg:location,TRUE,, -add_q,add_q-arg:method,TRUE,, -add_q,add_q-arg:pvalue_fun,TRUE,, -add_p.tbl_cross,add_p.tbl_cross-arg:test,TRUE,, -add_p.tbl_cross,add_p.tbl_cross-arg:pvalue_fun,TRUE,, -add_p.tbl_cross,add_p.tbl_cross-arg:source_note ,TRUE,, -tbl_survfit,tbl_survfit-arg:statistic,TRUE,, -tbl_regression,tbl_regression-arg:conf.level,TRUE,, -tbl_regression,tbl_regression-arg:estimate_fun ,TRUE,, -tbl_regression,tbl_regression-arg:pvalue_fun ,TRUE,, -tbl_regression,tbl_regression-arg:tidy_fun ,TRUE,, -tbl_regression,tbl_regression-lgl:add_ref_est,FALSE,logical indicating whether the reference estimate should be added to regression model tables with caetgorical covariates,TRUE -tbl_regression,tbl_regression-str:ref_row_text,FALSE,string indicating the text to print on reference rows (default is an em-dash),"""Reference""" -tbl_regression,tbl_regression-chr:tidy_columns,FALSE,"character vector of columns from `tidy_fun=` tibble to print. 'estimate' column will always be printed. Select among columns 'conf.low', 'conf.high', 'std.error', 'statistic', or 'p.value'.","c(""std.error"", ""p.value"")" -tbl_regression,tbl_regression-str:coef_header,FALSE,"string setting the default term for the beta coefficient column header; default is `""Beta""`","ifelse(exponentiate == TRUE, ""exp(coef)"", ""coef"")" -add_global_p,add_global_p-str:type,FALSE,set argument default for `add_global_p.tbl_regression(type=)` and `add_global_p.tbl_uvregression(type=)`,"""II""" -add_global_p,add_global_p-str:type,FALSE,"set argument default for `add_global_p.tbl_regression(type=)` and `add_global_p.tbl_uvregression(type=)`; default is `""III""`","""II""" -style_number,style_number-arg:big.mark,TRUE,, -style_number,style_number-arg:decimal.mark,TRUE,, +tbl_svysummary,tbl_svysummary-arg:statistic,TRUE,, +tbl_svysummary,tbl_svysummary-arg:type,TRUE,, +tbl_svysummary,tbl_svysummary-arg:value,TRUE,, diff --git a/inst/WORDLIST b/inst/WORDLIST index 943315c733..1531dde8fc 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,6 +1,18 @@ Anova -ci Codecov +JAMA +Kaplan +Lifecycle +NEJM +ORCID +README +RStudio +RTF +Rao +SHA +Waerden's +Wainberg +ci conf coxph crosstab @@ -16,30 +28,21 @@ geepack glm glmer huxtable -JAMA kable kableExtra -Kaplan knitr labelled lifecycle -Lifecycle lm lme logLik mL -NEJM nevent ng -ORCID +nnet pre pvalue -Rao -README -RStudio -RTF saddlepoint -SHA sig survfit svychisq @@ -56,5 +59,3 @@ tidyselect tidyselect's tidyverse uvregression -Waerden's -Wainberg diff --git a/man/deprecated.Rd b/man/deprecated.Rd index 285f23ccb2..95ad5c7d21 100644 --- a/man/deprecated.Rd +++ b/man/deprecated.Rd @@ -12,6 +12,12 @@ \alias{tbl_summary_} \alias{add_p_} \alias{as_flextable} +\alias{all_numeric} +\alias{all_character} +\alias{all_integer} +\alias{all_double} +\alias{all_logical} +\alias{all_factor} \title{Deprecated functions} \usage{ add_comparison(...) @@ -33,6 +39,18 @@ tbl_summary_(...) add_p_(...) as_flextable(...) + +all_numeric() + +all_character() + +all_integer() + +all_double() + +all_logical() + +all_factor() } \description{ \Sexpr[results=rd, stage=render]{lifecycle::badge("deprecated")} diff --git a/man/reexports.Rd b/man/reexports.Rd index 8e86f83d0e..61d25e1223 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -5,6 +5,12 @@ \alias{reexports} \alias{as_tibble} \alias{knit_print} +\alias{all_continuous} +\alias{all_categorical} +\alias{all_dichotomous} +\alias{all_interaction} +\alias{all_intercepts} +\alias{all_contrasts} \alias{\%>\%} \alias{vars} \alias{select} @@ -25,6 +31,8 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ + \item{broom.helpers}{\code{\link[broom.helpers:select_helpers]{all_categorical}}, \code{\link[broom.helpers:select_helpers]{all_continuous}}, \code{\link[broom.helpers:select_helpers]{all_contrasts}}, \code{\link[broom.helpers:select_helpers]{all_dichotomous}}, \code{\link[broom.helpers:select_helpers]{all_interaction}}, \code{\link[broom.helpers:select_helpers]{all_intercepts}}} + \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{contains}}, \code{\link[dplyr:reexports]{ends_with}}, \code{\link[dplyr:reexports]{everything}}, \code{\link[dplyr:reexports]{last_col}}, \code{\link[dplyr:reexports]{matches}}, \code{\link[dplyr:reexports]{num_range}}, \code{\link[dplyr:reexports]{one_of}}, \code{\link[dplyr]{select}}, \code{\link[dplyr:reexports]{starts_with}}, \code{\link[dplyr]{vars}}} \item{knitr}{\code{\link[knitr]{knit_print}}} diff --git a/man/select_helpers.Rd b/man/select_helpers.Rd index b55f654387..6a374edd28 100644 --- a/man/select_helpers.Rd +++ b/man/select_helpers.Rd @@ -2,55 +2,34 @@ % Please edit documentation in R/select_helpers.R \name{select_helpers} \alias{select_helpers} -\alias{all_continuous} \alias{all_continuous2} -\alias{all_categorical} -\alias{all_dichotomous} -\alias{all_numeric} -\alias{all_character} -\alias{all_integer} -\alias{all_double} -\alias{all_logical} -\alias{all_factor} \title{Select helper functions} \usage{ -all_continuous(continuous2 = TRUE) - all_continuous2() - -all_categorical(dichotomous = TRUE) - -all_dichotomous() - -all_numeric() - -all_character() - -all_integer() - -all_double() - -all_logical() - -all_factor() -} -\arguments{ -\item{continuous2}{Logical indicating whether to include continuous2 variables. -Default is \code{TRUE}} - -\item{dichotomous}{Logical indicating whether to include dichotomous variables. -Default is \code{TRUE}} } \value{ A character vector of column names selected } \description{ -Set of functions to supplement the {tidyselect} set of functions for selecting -columns of data frames. \code{all_continuous()}, \code{all_continuous2()}, \code{all_categorical()}, and -\code{all_dichotomous()} may only be used with \code{tbl_summary()}, where each variable -has been classified into one of these three groups. All other helpers -are available throughout the package. +Set of functions to supplement the {tidyselect} set of +functions for selecting columns of data frames (and other items as well). +\itemize{ +\item \code{all_continuous()} selects continuous variables +\item \code{all_continuous2()} selects only type \code{"continuous2"} +\item \code{all_categorical()} selects categorical (including \code{"dichotomous"}) variables +\item \code{all_dichotomous()} selects only type \code{"dichotomous"} +\item \code{all_interaction()} selects interaction terms from a regression model +\item \code{all_intercepts()} selects intercept terms from a regression model +\item \code{all_contrasts()} selects variables in regression model based on their type of contrast +} } +\section{Example Output}{ + +\if{html}{Example 1} + +\if{html}{\figure{select_ex1.png}{options: width=55\%}} +} + \examples{ select_ex1 <- trial \%>\% diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd index cb11e864a8..7c762b6303 100644 --- a/man/tbl_regression.Rd +++ b/man/tbl_regression.Rd @@ -18,6 +18,7 @@ tbl_regression(x, ...) estimate_fun = NULL, pvalue_fun = NULL, tidy_fun = broom::tidy, + add_estimate_to_reference_rows = FALSE, show_yesno = NULL, exclude = NULL, ... @@ -64,6 +65,8 @@ and return a string that is the rounded/formatted p-value (e.g. model is not a \link[=vetted_models]{vetted model} or you need to implement a custom method. Default is \code{NULL}} +\item{add_estimate_to_reference_rows}{add a reference value. Default is FALSE} + \item{show_yesno}{DEPRECATED} \item{exclude}{DEPRECATED} diff --git a/man/tbl_uvregression.Rd b/man/tbl_uvregression.Rd index c095033477..3e9f0eff78 100644 --- a/man/tbl_uvregression.Rd +++ b/man/tbl_uvregression.Rd @@ -20,6 +20,7 @@ tbl_uvregression( estimate_fun = NULL, pvalue_fun = NULL, formula = "{y} ~ {x}", + add_estimate_to_reference_rows = NULL, show_yesno = NULL, exclude = NULL ) @@ -83,6 +84,8 @@ Uses \link[glue:glue]{glue::glue} syntax. Default is \code{"{y} ~ {x}"}, where \ is the dependent variable, and \code{{x}} represents a single covariate. For a random intercept model, the formula may be \code{formula = "{y} ~ {x} + (1 | gear)"}.} +\item{add_estimate_to_reference_rows}{add a reference value. Default is FALSE} + \item{show_yesno}{DEPRECATED} \item{exclude}{DEPRECATED} diff --git a/tests/testthat/test-select_helpers.R b/tests/testthat/test-select_helpers.R index 956c4687d5..5a400f242d 100644 --- a/tests/testthat/test-select_helpers.R +++ b/tests/testthat/test-select_helpers.R @@ -3,42 +3,37 @@ testthat::skip_on_cran() test_that("test-select helpers", { expect_equal( - var_input_to_string(mtcars, select_input = vars(hp, mpg)), + .select_to_varnames(select = vars(hp, mpg), data = mtcars), dplyr::select(mtcars, hp, mpg) %>% colnames() ) expect_equal( - var_input_to_string(mtcars, select_input = mpg), + .select_to_varnames(select = mpg, data = mtcars), dplyr::select(mtcars, mpg) %>% colnames() ) expect_equal( - var_input_to_string(mtcars, select_input = "mpg"), + .select_to_varnames(select = "mpg", data = mtcars), dplyr::select(mtcars, "mpg") %>% colnames() ) expect_equal( - var_input_to_string(mtcars, select_input = "mpg"), - dplyr::select(mtcars, "mpg") %>% colnames() - ) - - expect_equal( - var_input_to_string(mtcars, select_input = c("hp", "mpg")), + .select_to_varnames(select = c("hp", "mpg"), data = mtcars), dplyr::select(mtcars, c("hp", "mpg")) %>% colnames() ) expect_equal( - var_input_to_string(mtcars, select_input = c(hp, mpg)), + .select_to_varnames(select = c(hp, mpg), data = mtcars), dplyr::select(mtcars, c(hp, mpg)) %>% colnames() ) expect_equal( - var_input_to_string(mtcars, select_input = NULL), + .select_to_varnames(select = NULL, data = mtcars), NULL ) expect_equal( - var_input_to_string(mtcars, select_input = vars(dplyr::everything(), -mpg)), + .select_to_varnames(select = vars(dplyr::everything(), -mpg), data = mtcars), dplyr::select(mtcars, dplyr::everything(), -mpg) %>% colnames() ) @@ -56,20 +51,6 @@ test_that("test-select helpers", { {.$summary_type == .$var_label} %>% all() ) - expect_true( - tbl_summary( - trial, - label = list( - all_character() ~ "character", - all_factor() ~ "factor", - all_numeric() ~ "numeric", - all_integer() ~ "integer" - ) - ) %>% - purrr::pluck("meta_data") %>% - {.$class == .$var_label} %>% - all() - ) stage_variable = "stage" expect_equal( @@ -80,23 +61,6 @@ test_that("test-select helpers", { c("trt", "grade", stage_variable) ) - # var_input_to_string(mtcars, select_input = vars(everything(), -mpg) - expect_error( - tbl_summary(trial, type = all_character() ~ "categorical"), NA - ) - - expect_error( - tbl_summary(trial, type = all_double() ~ "continuous"), NA - ) - - expect_error( - tbl_summary(trial, type = all_factor() ~ "categorical"), NA - ) - - expect_error( - tbl_summary(trial, type = all_integer() ~ "categorical"), NA - ) - expect_error( tbl_summary(trial, statistic = all_continuous() ~ "{mean}"), NA ) diff --git a/tests/testthat/test-set_gtsummary_theme.R b/tests/testthat/test-set_gtsummary_theme.R index 9b388b54ad..c80a521bce 100644 --- a/tests/testthat/test-set_gtsummary_theme.R +++ b/tests/testthat/test-set_gtsummary_theme.R @@ -10,6 +10,26 @@ test_that("setting themes", { set_gtsummary_theme(theme_gtsummary_journal("jama")), NA) + expect_error( + set_gtsummary_theme(theme_gtsummary_journal("nejm")), + NA) + + expect_error( + set_gtsummary_theme(theme_gtsummary_journal("lancet")), + NA) + + expect_error( + theme_gtsummary_continuous2(), + NA) + + expect_error( + theme_gtsummary_printer(), + NA) + + expect_error( + theme_gtsummary_mean_sd(), + NA) + expect_error( theme_gtsummary_compact(), NA)