From 3dd3f1eaa2d7cd39319c27735e966bac1f51f1c9 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 21 Nov 2023 10:13:04 -0800 Subject: [PATCH 01/74] progress --- .Rbuildignore | 1 + .Rprofile | 5 - DESCRIPTION | 162 +-- LICENSE | 4 +- LICENSE.md | 2 +- NAMESPACE | 280 +--- NEWS.md | 4 +- R/as_gt.R | 56 +- R/bridge_tbl_summary.R | 357 +++++ R/construct_table_body.R | 68 + R/gtsummary-package.R | 38 +- R/modify_column_hide.R | 6 - R/modify_header.R | 40 + R/modify_table_styling.R | 30 +- R/print.R | 108 +- R/reexport.R | 18 +- R/select_helpers.R | 6 - R/standalone-purrr.R | 236 ++++ R/tbl_summary.R | 547 ++------ R/utils-as.R | 170 +-- R/utils-gtsummary.R | 32 + R/utils-gtsummary_core.R | 129 +- README.md | 267 +--- CITATION.cff => _archive/CITATION.cff | 0 _archive/DESCRIPTION | 137 ++ _archive/LICENSE | 2 + _archive/LICENSE.md | 21 + _archive/NAMESPACE | 318 +++++ _archive/NEWS.md | 1218 +++++++++++++++++ _archive/R/aaa.R | 2 + {R => _archive/R}/add_ci.R | 0 {R => _archive/R}/add_difference.R | 0 {R => _archive/R}/add_glance.R | 0 {R => _archive/R}/add_global_p.R | 0 {R => _archive/R}/add_n.R | 0 {R => _archive/R}/add_nevent.R | 0 {R => _archive/R}/add_overall.R | 0 {R => _archive/R}/add_p.R | 0 {R => _archive/R}/add_q.R | 0 {R => _archive/R}/add_significance_stars.R | 0 {R => _archive/R}/add_stat.R | 0 {R => _archive/R}/add_stat_label.R | 0 {R => _archive/R}/add_vif.R | 0 {R => _archive/R}/as_flex_table.R | 0 _archive/R/as_gt.R | 341 +++++ {R => _archive/R}/as_hux_table.R | 0 {R => _archive/R}/as_kable.R | 0 {R => _archive/R}/as_kable_extra.R | 0 {R => _archive/R}/as_tibble.R | 0 {R => _archive/R}/assert_package.R | 0 .../R}/bold_italicise_labels_levels.R | 0 {R => _archive/R}/bold_p.R | 0 {R => _archive/R}/combine_terms.R | 0 {R => _archive/R}/custom_tidiers.R | 0 {R => _archive/R}/data.R | 0 {R => _archive/R}/deprecated.R | 0 _archive/R/gtsummary-package.R | 41 + {R => _archive/R}/inline_text.R | 0 {R => _archive/R}/modify.R | 0 {R => _archive/R}/modify_column_alignment.R | 0 _archive/R/modify_column_hide.R | 59 + {R => _archive/R}/modify_column_indent.R | 0 {R => _archive/R}/modify_column_merge.R | 0 {R => _archive/R}/modify_fmt_fun.R | 0 {R => _archive/R}/modify_table_body.R | 0 {R => _archive/R}/modify_table_header.R | 0 _archive/R/modify_table_styling.R | 313 +++++ {R => _archive/R}/plot.R | 0 _archive/R/print.R | 118 ++ _archive/R/reexport.R | 66 + {R => _archive/R}/remove_row_type.R | 0 _archive/R/select_helpers.R | 124 ++ {R => _archive/R}/separate_p_footnotes.R | 0 {R => _archive/R}/set_gtsummary_theme.R | 0 {R => _archive/R}/sort_filter_p.R | 0 {R => _archive/R}/style_number.R | 0 {R => _archive/R}/style_percent.R | 0 {R => _archive/R}/style_pvalue.R | 0 {R => _archive/R}/style_ratio.R | 0 {R => _archive/R}/style_sigfig.R | 0 {R => _archive/R}/syntax.R | 0 {R => _archive/R}/sysdata.rda | Bin {R => _archive/R}/tbl_butcher.R | 0 {R => _archive/R}/tbl_continuous.R | 0 {R => _archive/R}/tbl_cross.R | 0 {R => _archive/R}/tbl_custom_summary.R | 0 {R => _archive/R}/tbl_merge.R | 0 {R => _archive/R}/tbl_regression.R | 0 {R => _archive/R}/tbl_regression_methods.R | 0 {R => _archive/R}/tbl_split.R | 0 {R => _archive/R}/tbl_stack.R | 0 {R => _archive/R}/tbl_strata.R | 0 _archive/R/tbl_summary.R | 484 +++++++ {R => _archive/R}/tbl_survfit.R | 0 {R => _archive/R}/tbl_survfit_errors.R | 0 {R => _archive/R}/tbl_survival.R | 0 {R => _archive/R}/tbl_svysummary.R | 0 {R => _archive/R}/tbl_uvregression.R | 0 {R => _archive/R}/tests.R | 0 {R => _archive/R}/theme_gtsummary.R | 0 {R => _archive/R}/tidy_plus_plus_dots.R | 0 {R => _archive/R}/utils-add_p.R | 0 {R => _archive/R}/utils-add_p_tests.R | 0 _archive/R/utils-as.R | 307 +++++ _archive/R/utils-gtsummary_core.R | 154 +++ {R => _archive/R}/utils-man_images.R | 0 _archive/R/utils-misc.R | 150 ++ {R => _archive/R}/utils-tbl_custom_summary.R | 0 {R => _archive/R}/utils-tbl_regression.R | 0 {R => _archive/R}/utils-tbl_summary.R | 0 {R => _archive/R}/zzz.R | 0 README.Rmd => _archive/README.Rmd | 0 _archive/README.md | 266 ++++ {benchmark => _archive/benchmark}/README.md | 0 {benchmark => _archive/benchmark}/README_.Rmd | 0 .../figure-gfm/unnamed-chunk-1-1.png | Bin .../unnamed-chunk-1-1.png | Bin .../benchmark}/benchmark_gts.R | 0 .../benchmark}/results/benchmark_current.csv | 0 .../benchmark}/results/benchmark_master.csv | 0 .../benchmark}/results/benchmark_v1.2.0.csv | 0 .../benchmark}/results/benchmark_v1.2.1.csv | 0 .../benchmark}/results/benchmark_v1.2.2.csv | 0 .../benchmark}/results/benchmark_v1.2.3.csv | 0 .../benchmark}/results/benchmark_v1.2.4.csv | 0 .../benchmark}/results/benchmark_v1.2.5.csv | 0 .../benchmark}/results/benchmark_v1.2.6.csv | 0 .../benchmark}/results/benchmark_v1.3.0.csv | 0 .../benchmark}/results/benchmark_v1.3.1.csv | 0 .../benchmark}/results/benchmark_v1.3.2.csv | 0 .../benchmark}/results/benchmark_v1.3.3.csv | 0 .../benchmark}/results/benchmark_v1.3.4.csv | 0 .../benchmark}/results/benchmark_v1.3.5.csv | 0 .../benchmark}/results/benchmark_v1.3.6.csv | 0 .../benchmark}/results/benchmark_v1.3.7.csv | 0 .../benchmark}/results/benchmark_v1.4.0.csv | 0 .../benchmark}/results/benchmark_v1.4.1.csv | 0 .../benchmark}/results/benchmark_v1.4.2.csv | 0 .../benchmark}/results/benchmark_v1.5.0.csv | 0 .../benchmark}/results/benchmark_v1.5.1.csv | 0 .../benchmark}/results/benchmark_v1.5.2.csv | 0 .../benchmark}/results/benchmark_v1.6.0.csv | 0 codecov.yml => _archive/codecov.yml | 0 codemeta.json => _archive/codemeta.json | 0 cran-comments.md => _archive/cran-comments.md | 0 .../data-raw}/RJ-2021-053.pdf | Bin .../crayon_images/Dan-SummaryTables.ai | 0 .../crayon_images/crayon-selectors-min.png | Bin .../crayon_images/crayon-selectors.png | Bin .../crayon_images/crayon-tbl_merge.png | Bin .../crayon_images/crayon-tbl_regression.png | Bin .../crayon_images/crayon-tbl_summary-args.png | Bin .../crayon_images/crayon-tbl_summary-fns.png | Bin .../data-raw}/gt_doc_images.R | 0 .../data-raw}/gtsummary_tests.csv | 0 .../data-raw}/gtsummary_theme_elements.csv | 0 .../data-raw}/gtsummary_translated.xlsx | Bin .../data-raw}/internal_data.R | 0 .../misc_files/gtsummary-HexSticker.jpg | Bin .../misc_files/gtsummary-HexSticker.pdf | Bin .../misc_files/gtsummary-HexSticker.png | Bin .../misc_files/inline_text_demo1.png | Bin .../data-raw}/misc_files/inlinetext_demo.gif | Bin .../misc_files/model_sanity_check.Rmd | 0 .../misc_files/model_sanity_check.html | 0 .../misc_files/tbl_mvregression_demo.gif | Bin .../misc_files/tbl_regression_demo2.gif | Bin .../misc_files/tbl_regression_demo4.gif | Bin .../misc_files/tbl_summary_demo1.gif | Bin .../misc_files/tbl_summary_demo3.gif | Bin .../misc_files/tbl_summary_demo4.gif | Bin .../misc_files/tbl_summary_demo_fast.gif | Bin {data-raw => _archive/data-raw}/trial.R | 0 {data => _archive/data}/trial.rda | Bin {inst => _archive/inst}/CITATION | 0 {inst => _archive/inst}/WORDLIST | 0 .../inst}/rmarkdown_example/.gitignore | 0 .../gtsummary_rmarkdown_html.Rmd | 0 .../man-images}/add_ci_ex1.png | Bin .../man-images}/add_ci_ex2.png | Bin .../man-images}/add_ci_ex3.png | Bin .../man-images}/add_difference_ex1.png | Bin .../man-images}/add_difference_ex2.png | Bin .../man-images}/add_glance_ex1.png | Bin .../man-images}/add_glance_ex2.png | Bin .../man-images}/add_n.tbl_regression_ex1.png | Bin .../man-images}/add_n.tbl_regression_ex2.png | Bin .../man-images}/add_n.tbl_survfit_ex1.png | Bin .../add_nevent.tbl_regression_ex1.png | Bin .../add_nevent.tbl_regression_ex2.png | Bin .../add_nevent.tbl_survfit_ex1.png | Bin .../man-images}/add_p_continuous_ex1.png | Bin .../man-images}/add_p_cross_ex1.png | Bin .../man-images}/add_p_cross_ex2.png | Bin .../man-images}/add_p_ex1.png | Bin .../man-images}/add_p_ex2.png | Bin .../man-images}/add_p_svysummary_ex1.png | Bin .../man-images}/add_p_svysummary_ex2.png | Bin .../man-images}/add_p_svysummary_ex3.png | Bin .../man-images}/add_p_tbl_survfit_ex1.png | Bin .../man-images}/add_p_tbl_survfit_ex2.png | Bin .../man-images}/add_q_ex1.png | Bin .../man-images}/add_q_ex2.png | Bin .../add_significance_stars_ex1.png | Bin .../add_significance_stars_ex2.png | Bin .../add_significance_stars_ex3.png | Bin .../add_significance_stars_ex4.png | Bin .../man-images}/add_stat_ex1.png | Bin .../man-images}/add_stat_ex2.png | Bin .../man-images}/add_stat_ex3.png | Bin .../man-images}/add_stat_label_ex1.png | Bin .../man-images}/add_stat_label_ex2.png | Bin .../man-images}/add_stat_label_ex3.png | Bin .../man-images}/add_vif_ex1.png | Bin .../man-images}/add_vif_ex2.png | Bin .../man-images}/as_flex_table_ex1.png | Bin .../man-images}/as_gt_ex1.png | Bin .../man-images}/as_kable_extra_ex1_pdf.png | Bin .../man-images}/as_kable_extra_ex2_pdf.png | Bin .../man-images}/bold_p_ex1.png | Bin .../man-images}/bold_p_ex2.png | Bin .../man-images}/combine_terms_ex1.png | Bin .../man-images}/continuous_summary_ex1.png | Bin .../man-images}/inline_text_ex1.png | Bin .../man-images}/modify_column_hide_ex1.png | Bin .../man-images}/modify_column_indent_ex1.png | Bin .../man-images}/modify_column_merge_ex1.png | Bin .../man-images}/modify_column_merge_ex2.png | Bin .../man-images}/modify_ex1.png | Bin .../man-images}/modify_ex2.png | Bin .../man-images}/modify_ex3.png | Bin .../man-images}/modify_fmt_fun_ex1.png | Bin .../man-images}/modify_table_body_ex1.png | Bin .../man-images}/pool_and_tidy_mice_ex3.png | Bin .../man-images}/proportion_summary_ex1.png | Bin .../man-images}/ratio_summary_ex1.png | Bin .../man-images}/remove_row_type_ex1.png | Bin .../man-images}/select_ex1.png | Bin .../man-images}/separate_p_footnotes_ex1.png | Bin .../man-images}/set_gtsummary_theme_ex1.png | Bin .../man-images}/sort_filter_p_ex1.png | Bin .../man-images}/sort_p_ex2.png | Bin .../man-images}/survfit_cr_ex4.png | Bin .../man-images}/tbl_bold_ital_ex1.png | Bin .../man-images}/tbl_continuous_ex1.png | Bin .../man-images}/tbl_continuous_ex2.png | Bin .../man-images}/tbl_cross_ex1.png | Bin .../man-images}/tbl_cross_ex2.png | Bin .../man-images}/tbl_custom_summary_ex1.png | Bin .../man-images}/tbl_custom_summary_ex2.png | Bin .../man-images}/tbl_custom_summary_ex3.png | Bin .../man-images}/tbl_lm_global_ex1.png | Bin .../man-images}/tbl_merge_ex1.png | Bin .../man-images}/tbl_merge_ex2.png | Bin .../man-images}/tbl_n_ex.png | Bin .../man-images}/tbl_overall_ex1.png | Bin .../man-images}/tbl_overall_ex2.png | Bin .../man-images}/tbl_overall_ex3.png | Bin .../man-images}/tbl_regression_ex1.png | Bin .../man-images}/tbl_regression_ex2.png | Bin .../man-images}/tbl_regression_ex3.png | Bin .../man-images}/tbl_stack_ex1.png | Bin .../man-images}/tbl_stack_ex2.png | Bin .../man-images}/tbl_strata_ex1.png | Bin .../man-images}/tbl_strata_ex2.png | Bin .../man-images}/tbl_summary_ex1.png | Bin .../man-images}/tbl_summary_ex2.png | Bin .../man-images}/tbl_summary_ex3.png | Bin .../man-images}/tbl_summary_ex4.png | Bin .../man-images}/tbl_survfit_ex1.png | Bin .../man-images}/tbl_survfit_ex2.png | Bin .../man-images}/tbl_survfit_ex3.png | Bin .../man-images}/tbl_svysummary_ex1.png | Bin .../man-images}/tbl_svysummary_ex2.png | Bin .../man-images}/tbl_uv_ex1.png | Bin .../man-images}/tbl_uv_ex2.png | Bin .../man-images}/tbl_uv_global_ex2.png | Bin .../man-images}/tidy_standardize_ex1.png | Bin .../man-images}/tidy_standardize_ex2.png | Bin {man => _archive/man}/add_ci.Rd | 0 {man => _archive/man}/add_difference.Rd | 0 {man => _archive/man}/add_glance.Rd | 0 {man => _archive/man}/add_global_p.Rd | 0 {man => _archive/man}/add_n.Rd | 0 {man => _archive/man}/add_n.tbl_summary.Rd | 0 {man => _archive/man}/add_n.tbl_survfit.Rd | 0 {man => _archive/man}/add_n_regression.Rd | 0 {man => _archive/man}/add_nevent.Rd | 0 .../man}/add_nevent.tbl_survfit.Rd | 0 .../man}/add_nevent_regression.Rd | 0 {man => _archive/man}/add_overall.Rd | 0 {man => _archive/man}/add_p.Rd | 0 {man => _archive/man}/add_p.tbl_continuous.Rd | 0 {man => _archive/man}/add_p.tbl_cross.Rd | 0 {man => _archive/man}/add_p.tbl_summary.Rd | 0 {man => _archive/man}/add_p.tbl_survfit.Rd | 0 {man => _archive/man}/add_p.tbl_svysummary.Rd | 0 {man => _archive/man}/add_q.Rd | 0 .../man}/add_significance_stars.Rd | 0 {man => _archive/man}/add_stat.Rd | 0 {man => _archive/man}/add_stat_label.Rd | 0 {man => _archive/man}/add_vif.Rd | 0 {man => _archive/man}/as_flex_table.Rd | 0 _archive/man/as_gt.Rd | 67 + {man => _archive/man}/as_hux_table.Rd | 0 {man => _archive/man}/as_kable.Rd | 0 {man => _archive/man}/as_kable_extra.Rd | 0 {man => _archive/man}/as_tibble.gtsummary.Rd | 0 .../man}/bold_italicize_labels_levels.Rd | 0 {man => _archive/man}/bold_p.Rd | 0 {man => _archive/man}/combine_terms.Rd | 0 {man => _archive/man}/continuous_summary.Rd | 0 {man => _archive/man}/custom_tidiers.Rd | 0 {man => _archive/man}/deprecated.Rd | 0 .../man}/dot-create_gtsummary_object.Rd | 0 .../dot-table_styling_expr_to_row_number.Rd | 26 + .../man}/figures/README-tbl_merge_ex1-1.png | Bin .../README-tbl_regression_printa-1.png | Bin .../README-tbl_summary_print_extra-1.png | Bin .../README-tbl_summary_print_simple-1.png | Bin .../man}/figures/gt_output_formats.PNG | Bin .../man}/figures/gtsummary_logo.PNG | Bin .../man}/figures/lifecycle-archived.svg | 0 .../man}/figures/lifecycle-defunct.svg | 0 .../man}/figures/lifecycle-deprecated.svg | 0 .../man}/figures/lifecycle-experimental.svg | 0 .../man}/figures/lifecycle-maturing.svg | 0 .../man}/figures/lifecycle-questioning.svg | 0 .../man}/figures/lifecycle-retired.svg | 0 .../figures/lifecycle-soft-deprecated.svg | 0 .../man}/figures/lifecycle-stable.svg | 0 {man => _archive/man}/figures/logo.png | Bin _archive/man/gtsummary-package.Rd | 47 + {man => _archive/man}/inline_text.Rd | 0 .../man}/inline_text.gtsummary.Rd | 0 .../man}/inline_text.tbl_cross.Rd | 0 .../man}/inline_text.tbl_regression.Rd | 0 .../man}/inline_text.tbl_summary.Rd | 0 .../man}/inline_text.tbl_survfit.Rd | 0 .../man}/inline_text.tbl_survival.Rd | 0 .../man}/inline_text.tbl_uvregression.Rd | 0 {man => _archive/man}/kableExtra_utils.Rd | 0 {man => _archive/man}/modify.Rd | 0 .../man}/modify_column_alignment.Rd | 0 _archive/man/modify_column_hide.Rd | 52 + {man => _archive/man}/modify_column_indent.Rd | 0 {man => _archive/man}/modify_column_merge.Rd | 0 {man => _archive/man}/modify_fmt_fun.Rd | 0 {man => _archive/man}/modify_table_body.Rd | 0 {man => _archive/man}/modify_table_header.Rd | 0 _archive/man/modify_table_styling.Rd | 133 ++ {man => _archive/man}/plot.Rd | 0 _archive/man/print_gtsummary.Rd | 30 + {man => _archive/man}/proportion_summary.Rd | 0 {man => _archive/man}/ratio_summary.Rd | 0 _archive/man/reexports.Rd | 35 + {man => _archive/man}/remove_row_type.Rd | 0 _archive/man/select_helpers.Rd | 87 ++ {man => _archive/man}/separate_p_footnotes.Rd | 0 {man => _archive/man}/set_gtsummary_theme.Rd | 0 {man => _archive/man}/sort_filter_p.Rd | 0 {man => _archive/man}/style_number.Rd | 0 {man => _archive/man}/style_percent.Rd | 0 {man => _archive/man}/style_pvalue.Rd | 0 {man => _archive/man}/style_ratio.Rd | 0 {man => _archive/man}/style_sigfig.Rd | 0 {man => _archive/man}/syntax.Rd | 0 {man => _archive/man}/tbl_butcher.Rd | 0 {man => _archive/man}/tbl_continuous.Rd | 0 {man => _archive/man}/tbl_cross.Rd | 0 {man => _archive/man}/tbl_custom_summary.Rd | 0 {man => _archive/man}/tbl_merge.Rd | 0 {man => _archive/man}/tbl_regression.Rd | 0 .../man}/tbl_regression_methods.Rd | 0 {man => _archive/man}/tbl_split.Rd | 0 {man => _archive/man}/tbl_stack.Rd | 0 {man => _archive/man}/tbl_strata.Rd | 0 _archive/man/tbl_summary.Rd | 271 ++++ {man => _archive/man}/tbl_survfit.Rd | 0 {man => _archive/man}/tbl_survfit_errors.Rd | 0 {man => _archive/man}/tbl_survival.Rd | 0 {man => _archive/man}/tbl_svysummary.Rd | 0 {man => _archive/man}/tbl_uvregression.Rd | 0 {man => _archive/man}/tests.Rd | 0 {man => _archive/man}/theme_gtsummary.Rd | 0 {man => _archive/man}/tidy_plus_plus_dots.Rd | 0 {man => _archive/man}/trial.Rd | 0 {pkgdown => _archive/pkgdown}/_pkgdown.yml | 0 .../favicon/apple-touch-icon-120x120.png | Bin .../favicon/apple-touch-icon-152x152.png | Bin .../favicon/apple-touch-icon-180x180.png | Bin .../favicon/apple-touch-icon-60x60.png | Bin .../favicon/apple-touch-icon-76x76.png | Bin .../pkgdown}/favicon/apple-touch-icon.png | Bin .../pkgdown}/favicon/favicon-16x16.png | Bin .../pkgdown}/favicon/favicon-32x32.png | Bin .../pkgdown}/favicon/favicon.ico | Bin {tests => _archive/tests}/spelling.R | 0 _archive/tests/testthat.R | 5 + .../tests}/testthat/_snaps/add_ci.md | 0 .../tests}/testthat/_snaps/add_difference.md | 0 .../tests}/testthat/_snaps/add_glance.md | 0 .../tests}/testthat/_snaps/add_global_p.md | 0 .../tests}/testthat/_snaps/add_n.md | 0 .../tests}/testthat/_snaps/add_nevent.md | 0 .../tests}/testthat/_snaps/add_overall.md | 0 .../testthat/_snaps/add_p.tbl_continuous.md | 0 .../tests}/testthat/_snaps/add_p.tbl_cross.md | 0 .../testthat/_snaps/add_p.tbl_summary.md | 0 .../testthat/_snaps/add_p.tbl_survfit.md | 0 .../testthat/_snaps/add_p.tbl_svysummary.md | 0 .../tests}/testthat/_snaps/add_p_test_safe.md | 0 .../tests}/testthat/_snaps/add_q.md | 0 .../testthat/_snaps/add_significance_stars.md | 0 .../tests}/testthat/_snaps/add_stat_label.md | 0 .../tests}/testthat/_snaps/add_vif.md | 0 .../tests}/testthat/_snaps/as_flex_table.md | 0 .../tests}/testthat/_snaps/as_gt.md | 0 .../tests}/testthat/_snaps/as_hux_table.md | 0 .../tests}/testthat/_snaps/as_kable.md | 0 .../tests}/testthat/_snaps/as_kable_extra.md | 0 .../tests}/testthat/_snaps/as_tibble.md | 0 .../_snaps/bold_italicize_labels_levels.md | 0 .../tests}/testthat/_snaps/bold_p.md | 0 .../tests}/testthat/_snaps/combine_terms.md | 0 .../tests}/testthat/_snaps/custom_tidiers.md | 0 .../tests}/testthat/_snaps/filter_p.md | 0 .../tests}/testthat/_snaps/modify_caption.md | 0 .../_snaps/modify_column_alignment.md | 0 .../testthat/_snaps/modify_column_hide.md | 0 .../testthat/_snaps/modify_column_indent.md | 0 .../testthat/_snaps/modify_column_merge.md | 0 .../tests}/testthat/_snaps/modify_fmt_fun.md | 0 .../tests}/testthat/_snaps/modify_footnote.md | 0 .../tests}/testthat/_snaps/modify_header.md | 0 .../testthat/_snaps/modify_spanning_header.md | 0 .../testthat/_snaps/modify_table_body.md | 0 .../testthat/_snaps/modify_table_styling.md | 0 .../tests}/testthat/_snaps/remove_row_type.md | 0 .../tests}/testthat/_snaps/select_helpers.md | 0 .../testthat/_snaps/separate_p_footnotes.md | 0 .../testthat/_snaps/set_gtsummary_theme.md | 0 .../tests}/testthat/_snaps/sort_p.md | 0 .../tests}/testthat/_snaps/tbl_butcher.md | 0 .../tests}/testthat/_snaps/tbl_continuous.md | 0 .../tests}/testthat/_snaps/tbl_cross.md | 0 .../testthat/_snaps/tbl_custom_summary.md | 0 .../tests}/testthat/_snaps/tbl_merge.md | 0 .../tests}/testthat/_snaps/tbl_regression.md | 0 .../tests}/testthat/_snaps/tbl_split.md | 0 .../tests}/testthat/_snaps/tbl_stack.md | 0 .../tests}/testthat/_snaps/tbl_strata.md | 0 .../tests}/testthat/_snaps/tbl_summary.md | 0 .../tests}/testthat/_snaps/tbl_survfit.md | 0 .../tests}/testthat/_snaps/tbl_svysummary.md | 0 .../testthat/_snaps/tbl_uvregression.md | 0 .../tests}/testthat/helper-dplyr_storms.R | 0 .../tests}/testthat/helper-render_as_html.R | 0 .../tests}/testthat/helper-vetted_models.R | 0 .../tests}/testthat/test-add_ci.R | 0 .../tests}/testthat/test-add_difference.R | 0 .../tests}/testthat/test-add_glance.R | 0 .../tests}/testthat/test-add_global_p.R | 0 .../tests}/testthat/test-add_n.R | 0 .../tests}/testthat/test-add_nevent.R | 0 .../tests}/testthat/test-add_overall.R | 0 .../testthat/test-add_p.tbl_continuous.R | 0 .../tests}/testthat/test-add_p.tbl_cross.R | 0 .../tests}/testthat/test-add_p.tbl_summary.R | 0 .../tests}/testthat/test-add_p.tbl_survfit.R | 0 .../testthat/test-add_p.tbl_svysummary.R | 0 .../tests}/testthat/test-add_p_test_safe.R | 0 .../tests}/testthat/test-add_q.R | 0 .../testthat/test-add_significance_stars.R | 0 .../tests}/testthat/test-add_stat.R | 0 .../tests}/testthat/test-add_stat_label.R | 0 .../tests}/testthat/test-add_vif.R | 0 .../tests}/testthat/test-as_flex_table.R | 0 .../tests}/testthat/test-as_gt.R | 0 .../tests}/testthat/test-as_hux_table.R | 0 .../tests}/testthat/test-as_hux_xlsx.R | 0 .../tests}/testthat/test-as_kable.R | 0 .../tests}/testthat/test-as_kable_extra.R | 0 .../tests}/testthat/test-as_tibble.R | 0 .../testthat/test-assign_dichotomous_value.R | 0 .../testthat/test-assign_summary_type.R | 0 .../test-bold_italicize_labels_levels.R | 0 .../tests}/testthat/test-bold_p.R | 0 .../tests}/testthat/test-combine_terms.R | 0 .../testthat/test-continuous_digits_guess.R | 0 .../tests}/testthat/test-custom_tidiers.R | 0 .../tests}/testthat/test-filter_p.R | 0 .../tests}/testthat/test-inline_text.R | 0 .../tests}/testthat/test-modify_caption.R | 0 .../testthat/test-modify_column_alignment.R | 0 .../tests}/testthat/test-modify_column_hide.R | 0 .../testthat/test-modify_column_indent.R | 0 .../testthat/test-modify_column_merge.R | 0 .../tests}/testthat/test-modify_fmt_fun.R | 0 .../tests}/testthat/test-modify_footnote.R | 0 .../tests}/testthat/test-modify_header.R | 0 .../testthat/test-modify_spanning_header.R | 0 .../tests}/testthat/test-modify_table_body.R | 0 .../testthat/test-modify_table_styling.R | 0 .../tests}/testthat/test-plot.R | 0 .../tests}/testthat/test-remove_row_type.R | 0 .../tests}/testthat/test-select_helpers.R | 0 .../testthat/test-separate_p_footnotes.R | 0 .../testthat/test-set_gtsummary_theme.R | 0 .../tests}/testthat/test-show_header_names.R | 0 .../tests}/testthat/test-sort_p.R | 0 .../tests}/testthat/test-style_number.R | 0 .../tests}/testthat/test-style_percent.R | 0 .../tests}/testthat/test-style_pvalue.R | 0 .../tests}/testthat/test-style_ratio.R | 0 .../tests}/testthat/test-style_sigfig.R | 0 .../tests}/testthat/test-tbl_butcher.R | 0 .../tests}/testthat/test-tbl_continuous.R | 0 .../tests}/testthat/test-tbl_cross.R | 0 .../tests}/testthat/test-tbl_custom_summary.R | 0 .../tests}/testthat/test-tbl_merge.R | 0 .../tests}/testthat/test-tbl_regression.R | 0 .../tests}/testthat/test-tbl_split.R | 0 .../tests}/testthat/test-tbl_stack.R | 0 .../tests}/testthat/test-tbl_strata.R | 0 _archive/tests/testthat/test-tbl_summary.R | 789 +++++++++++ .../testthat/test-tbl_summary_input_checks.R | 0 .../tests}/testthat/test-tbl_survfit.R | 0 .../tests}/testthat/test-tbl_survival.R | 0 .../tests}/testthat/test-tbl_svysummary.R | 0 .../tests}/testthat/test-tbl_uvregression.R | 0 .../testthat/test-vetted_models-clogit.R | 0 .../testthat/test-vetted_models-coxph.R | 0 .../testthat/test-vetted_models-geeglm.R | 0 .../tests}/testthat/test-vetted_models-glm.R | 0 .../testthat/test-vetted_models-glmer.R | 0 .../tests}/testthat/test-vetted_models-lm.R | 0 .../tests}/testthat/test-vetted_models-lmer.R | 0 .../testthat/test-vetted_models-survreg.R | 0 {vignettes => _archive/vignettes}/.gitignore | 0 .../vignettes}/articles/shiny.Rmd | 0 {vignettes => _archive/vignettes}/gallery.Rmd | 0 .../vignettes}/gtsummary_definition.Rmd | 0 .../vignettes}/img/icons8-confused-100.png | Bin .../img/icons8-disappointed-100.png | Bin .../vignettes}/img/icons8-neutral-100.png | Bin .../vignettes}/img/icons8-no-entry-100.png | Bin .../vignettes}/img/icons8-smiling-100.png | Bin .../img/icons8-under-construction-100.png | Bin .../vignettes}/inline_text.Rmd | 0 .../vignettes}/rmarkdown.Rmd | 0 .../vignettes}/tbl_regression.Rmd | 0 .../vignettes}/tbl_summary.Rmd | 0 {vignettes => _archive/vignettes}/themes.Rmd | 0 gtsummary.Rproj | 1 + man/as_gt.Rd | 18 - man/bridge_tbl_summary.Rd | 98 ++ man/construct_gtsummary.Rd | 26 + man/gtsummary-package.Rd | 2 - man/modify_column_hide.Rd | 7 +- man/modify_table_styling.Rd | 7 +- man/print_gtsummary.Rd | 8 +- man/reexports.Rd | 11 +- man/select_helpers.Rd | 9 - man/tbl_summary.Rd | 272 +--- tests/testthat.R | 9 +- tests/testthat/test-tbl_summary.R | 790 +---------- 567 files changed, 6928 insertions(+), 2559 deletions(-) delete mode 100644 .Rprofile create mode 100644 R/bridge_tbl_summary.R create mode 100644 R/construct_table_body.R create mode 100644 R/modify_header.R create mode 100644 R/standalone-purrr.R create mode 100644 R/utils-gtsummary.R rename CITATION.cff => _archive/CITATION.cff (100%) create mode 100644 _archive/DESCRIPTION create mode 100644 _archive/LICENSE create mode 100644 _archive/LICENSE.md create mode 100644 _archive/NAMESPACE create mode 100644 _archive/NEWS.md create mode 100644 _archive/R/aaa.R rename {R => _archive/R}/add_ci.R (100%) rename {R => _archive/R}/add_difference.R (100%) rename {R => _archive/R}/add_glance.R (100%) rename {R => _archive/R}/add_global_p.R (100%) rename {R => _archive/R}/add_n.R (100%) rename {R => _archive/R}/add_nevent.R (100%) rename {R => _archive/R}/add_overall.R (100%) rename {R => _archive/R}/add_p.R (100%) rename {R => _archive/R}/add_q.R (100%) rename {R => _archive/R}/add_significance_stars.R (100%) rename {R => _archive/R}/add_stat.R (100%) rename {R => _archive/R}/add_stat_label.R (100%) rename {R => _archive/R}/add_vif.R (100%) rename {R => _archive/R}/as_flex_table.R (100%) create mode 100644 _archive/R/as_gt.R rename {R => _archive/R}/as_hux_table.R (100%) rename {R => _archive/R}/as_kable.R (100%) rename {R => _archive/R}/as_kable_extra.R (100%) rename {R => _archive/R}/as_tibble.R (100%) rename {R => _archive/R}/assert_package.R (100%) rename {R => _archive/R}/bold_italicise_labels_levels.R (100%) rename {R => _archive/R}/bold_p.R (100%) rename {R => _archive/R}/combine_terms.R (100%) rename {R => _archive/R}/custom_tidiers.R (100%) rename {R => _archive/R}/data.R (100%) rename {R => _archive/R}/deprecated.R (100%) create mode 100644 _archive/R/gtsummary-package.R rename {R => _archive/R}/inline_text.R (100%) rename {R => _archive/R}/modify.R (100%) rename {R => _archive/R}/modify_column_alignment.R (100%) create mode 100644 _archive/R/modify_column_hide.R rename {R => _archive/R}/modify_column_indent.R (100%) rename {R => _archive/R}/modify_column_merge.R (100%) rename {R => _archive/R}/modify_fmt_fun.R (100%) rename {R => _archive/R}/modify_table_body.R (100%) rename {R => _archive/R}/modify_table_header.R (100%) create mode 100644 _archive/R/modify_table_styling.R rename {R => _archive/R}/plot.R (100%) create mode 100644 _archive/R/print.R create mode 100644 _archive/R/reexport.R rename {R => _archive/R}/remove_row_type.R (100%) create mode 100644 _archive/R/select_helpers.R rename {R => _archive/R}/separate_p_footnotes.R (100%) rename {R => _archive/R}/set_gtsummary_theme.R (100%) rename {R => _archive/R}/sort_filter_p.R (100%) rename {R => _archive/R}/style_number.R (100%) rename {R => _archive/R}/style_percent.R (100%) rename {R => _archive/R}/style_pvalue.R (100%) rename {R => _archive/R}/style_ratio.R (100%) rename {R => _archive/R}/style_sigfig.R (100%) rename {R => _archive/R}/syntax.R (100%) rename {R => _archive/R}/sysdata.rda (100%) rename {R => _archive/R}/tbl_butcher.R (100%) rename {R => _archive/R}/tbl_continuous.R (100%) rename {R => _archive/R}/tbl_cross.R (100%) rename {R => _archive/R}/tbl_custom_summary.R (100%) rename {R => _archive/R}/tbl_merge.R (100%) rename {R => _archive/R}/tbl_regression.R (100%) rename {R => _archive/R}/tbl_regression_methods.R (100%) rename {R => _archive/R}/tbl_split.R (100%) rename {R => _archive/R}/tbl_stack.R (100%) rename {R => _archive/R}/tbl_strata.R (100%) create mode 100644 _archive/R/tbl_summary.R rename {R => _archive/R}/tbl_survfit.R (100%) rename {R => _archive/R}/tbl_survfit_errors.R (100%) rename {R => _archive/R}/tbl_survival.R (100%) rename {R => _archive/R}/tbl_svysummary.R (100%) rename {R => _archive/R}/tbl_uvregression.R (100%) rename {R => _archive/R}/tests.R (100%) rename {R => _archive/R}/theme_gtsummary.R (100%) rename {R => _archive/R}/tidy_plus_plus_dots.R (100%) rename {R => _archive/R}/utils-add_p.R (100%) rename {R => _archive/R}/utils-add_p_tests.R (100%) create mode 100644 _archive/R/utils-as.R create mode 100644 _archive/R/utils-gtsummary_core.R rename {R => _archive/R}/utils-man_images.R (100%) create mode 100644 _archive/R/utils-misc.R rename {R => _archive/R}/utils-tbl_custom_summary.R (100%) rename {R => _archive/R}/utils-tbl_regression.R (100%) rename {R => _archive/R}/utils-tbl_summary.R (100%) rename {R => _archive/R}/zzz.R (100%) rename README.Rmd => _archive/README.Rmd (100%) create mode 100644 _archive/README.md rename {benchmark => _archive/benchmark}/README.md (100%) rename {benchmark => _archive/benchmark}/README_.Rmd (100%) rename {benchmark => _archive/benchmark}/README_files/figure-gfm/unnamed-chunk-1-1.png (100%) rename {benchmark => _archive/benchmark}/README_files/figure-markdown_strict/unnamed-chunk-1-1.png (100%) rename {benchmark => _archive/benchmark}/benchmark_gts.R (100%) rename {benchmark => _archive/benchmark}/results/benchmark_current.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_master.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.0.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.1.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.2.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.3.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.4.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.5.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.2.6.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.0.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.1.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.2.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.3.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.4.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.5.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.6.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.3.7.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.4.0.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.4.1.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.4.2.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.5.0.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.5.1.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.5.2.csv (100%) rename {benchmark => _archive/benchmark}/results/benchmark_v1.6.0.csv (100%) rename codecov.yml => _archive/codecov.yml (100%) rename codemeta.json => _archive/codemeta.json (100%) rename cran-comments.md => _archive/cran-comments.md (100%) rename {data-raw => _archive/data-raw}/RJ-2021-053.pdf (100%) rename {data-raw => _archive/data-raw}/crayon_images/Dan-SummaryTables.ai (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-selectors-min.png (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-selectors.png (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-tbl_merge.png (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-tbl_regression.png (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-tbl_summary-args.png (100%) rename {data-raw => _archive/data-raw}/crayon_images/crayon-tbl_summary-fns.png (100%) rename {data-raw => _archive/data-raw}/gt_doc_images.R (100%) rename {data-raw => _archive/data-raw}/gtsummary_tests.csv (100%) rename {data-raw => _archive/data-raw}/gtsummary_theme_elements.csv (100%) rename {data-raw => _archive/data-raw}/gtsummary_translated.xlsx (100%) rename {data-raw => _archive/data-raw}/internal_data.R (100%) rename {data-raw => _archive/data-raw}/misc_files/gtsummary-HexSticker.jpg (100%) rename {data-raw => _archive/data-raw}/misc_files/gtsummary-HexSticker.pdf (100%) rename {data-raw => _archive/data-raw}/misc_files/gtsummary-HexSticker.png (100%) rename {data-raw => _archive/data-raw}/misc_files/inline_text_demo1.png (100%) rename {data-raw => _archive/data-raw}/misc_files/inlinetext_demo.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/model_sanity_check.Rmd (100%) rename {data-raw => _archive/data-raw}/misc_files/model_sanity_check.html (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_mvregression_demo.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_regression_demo2.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_regression_demo4.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_summary_demo1.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_summary_demo3.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_summary_demo4.gif (100%) rename {data-raw => _archive/data-raw}/misc_files/tbl_summary_demo_fast.gif (100%) rename {data-raw => _archive/data-raw}/trial.R (100%) rename {data => _archive/data}/trial.rda (100%) rename {inst => _archive/inst}/CITATION (100%) rename {inst => _archive/inst}/WORDLIST (100%) rename {inst => _archive/inst}/rmarkdown_example/.gitignore (100%) rename {inst => _archive/inst}/rmarkdown_example/gtsummary_rmarkdown_html.Rmd (100%) rename {man-images => _archive/man-images}/add_ci_ex1.png (100%) rename {man-images => _archive/man-images}/add_ci_ex2.png (100%) rename {man-images => _archive/man-images}/add_ci_ex3.png (100%) rename {man-images => _archive/man-images}/add_difference_ex1.png (100%) rename {man-images => _archive/man-images}/add_difference_ex2.png (100%) rename {man-images => _archive/man-images}/add_glance_ex1.png (100%) rename {man-images => _archive/man-images}/add_glance_ex2.png (100%) rename {man-images => _archive/man-images}/add_n.tbl_regression_ex1.png (100%) rename {man-images => _archive/man-images}/add_n.tbl_regression_ex2.png (100%) rename {man-images => _archive/man-images}/add_n.tbl_survfit_ex1.png (100%) rename {man-images => _archive/man-images}/add_nevent.tbl_regression_ex1.png (100%) rename {man-images => _archive/man-images}/add_nevent.tbl_regression_ex2.png (100%) rename {man-images => _archive/man-images}/add_nevent.tbl_survfit_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_continuous_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_cross_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_cross_ex2.png (100%) rename {man-images => _archive/man-images}/add_p_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_ex2.png (100%) rename {man-images => _archive/man-images}/add_p_svysummary_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_svysummary_ex2.png (100%) rename {man-images => _archive/man-images}/add_p_svysummary_ex3.png (100%) rename {man-images => _archive/man-images}/add_p_tbl_survfit_ex1.png (100%) rename {man-images => _archive/man-images}/add_p_tbl_survfit_ex2.png (100%) rename {man-images => _archive/man-images}/add_q_ex1.png (100%) rename {man-images => _archive/man-images}/add_q_ex2.png (100%) rename {man-images => _archive/man-images}/add_significance_stars_ex1.png (100%) rename {man-images => _archive/man-images}/add_significance_stars_ex2.png (100%) rename {man-images => _archive/man-images}/add_significance_stars_ex3.png (100%) rename {man-images => _archive/man-images}/add_significance_stars_ex4.png (100%) rename {man-images => _archive/man-images}/add_stat_ex1.png (100%) rename {man-images => _archive/man-images}/add_stat_ex2.png (100%) rename {man-images => _archive/man-images}/add_stat_ex3.png (100%) rename {man-images => _archive/man-images}/add_stat_label_ex1.png (100%) rename {man-images => _archive/man-images}/add_stat_label_ex2.png (100%) rename {man-images => _archive/man-images}/add_stat_label_ex3.png (100%) rename {man-images => _archive/man-images}/add_vif_ex1.png (100%) rename {man-images => _archive/man-images}/add_vif_ex2.png (100%) rename {man-images => _archive/man-images}/as_flex_table_ex1.png (100%) rename {man-images => _archive/man-images}/as_gt_ex1.png (100%) rename {man-images => _archive/man-images}/as_kable_extra_ex1_pdf.png (100%) rename {man-images => _archive/man-images}/as_kable_extra_ex2_pdf.png (100%) rename {man-images => _archive/man-images}/bold_p_ex1.png (100%) rename {man-images => _archive/man-images}/bold_p_ex2.png (100%) rename {man-images => _archive/man-images}/combine_terms_ex1.png (100%) rename {man-images => _archive/man-images}/continuous_summary_ex1.png (100%) rename {man-images => _archive/man-images}/inline_text_ex1.png (100%) rename {man-images => _archive/man-images}/modify_column_hide_ex1.png (100%) rename {man-images => _archive/man-images}/modify_column_indent_ex1.png (100%) rename {man-images => _archive/man-images}/modify_column_merge_ex1.png (100%) rename {man-images => _archive/man-images}/modify_column_merge_ex2.png (100%) rename {man-images => _archive/man-images}/modify_ex1.png (100%) rename {man-images => _archive/man-images}/modify_ex2.png (100%) rename {man-images => _archive/man-images}/modify_ex3.png (100%) rename {man-images => _archive/man-images}/modify_fmt_fun_ex1.png (100%) rename {man-images => _archive/man-images}/modify_table_body_ex1.png (100%) rename {man-images => _archive/man-images}/pool_and_tidy_mice_ex3.png (100%) rename {man-images => _archive/man-images}/proportion_summary_ex1.png (100%) rename {man-images => _archive/man-images}/ratio_summary_ex1.png (100%) rename {man-images => _archive/man-images}/remove_row_type_ex1.png (100%) rename {man-images => _archive/man-images}/select_ex1.png (100%) rename {man-images => _archive/man-images}/separate_p_footnotes_ex1.png (100%) rename {man-images => _archive/man-images}/set_gtsummary_theme_ex1.png (100%) rename {man-images => _archive/man-images}/sort_filter_p_ex1.png (100%) rename {man-images => _archive/man-images}/sort_p_ex2.png (100%) rename {man-images => _archive/man-images}/survfit_cr_ex4.png (100%) rename {man-images => _archive/man-images}/tbl_bold_ital_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_continuous_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_continuous_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_cross_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_cross_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_custom_summary_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_custom_summary_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_custom_summary_ex3.png (100%) rename {man-images => _archive/man-images}/tbl_lm_global_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_merge_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_merge_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_n_ex.png (100%) rename {man-images => _archive/man-images}/tbl_overall_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_overall_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_overall_ex3.png (100%) rename {man-images => _archive/man-images}/tbl_regression_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_regression_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_regression_ex3.png (100%) rename {man-images => _archive/man-images}/tbl_stack_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_stack_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_strata_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_strata_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_summary_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_summary_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_summary_ex3.png (100%) rename {man-images => _archive/man-images}/tbl_summary_ex4.png (100%) rename {man-images => _archive/man-images}/tbl_survfit_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_survfit_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_survfit_ex3.png (100%) rename {man-images => _archive/man-images}/tbl_svysummary_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_svysummary_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_uv_ex1.png (100%) rename {man-images => _archive/man-images}/tbl_uv_ex2.png (100%) rename {man-images => _archive/man-images}/tbl_uv_global_ex2.png (100%) rename {man-images => _archive/man-images}/tidy_standardize_ex1.png (100%) rename {man-images => _archive/man-images}/tidy_standardize_ex2.png (100%) rename {man => _archive/man}/add_ci.Rd (100%) rename {man => _archive/man}/add_difference.Rd (100%) rename {man => _archive/man}/add_glance.Rd (100%) rename {man => _archive/man}/add_global_p.Rd (100%) rename {man => _archive/man}/add_n.Rd (100%) rename {man => _archive/man}/add_n.tbl_summary.Rd (100%) rename {man => _archive/man}/add_n.tbl_survfit.Rd (100%) rename {man => _archive/man}/add_n_regression.Rd (100%) rename {man => _archive/man}/add_nevent.Rd (100%) rename {man => _archive/man}/add_nevent.tbl_survfit.Rd (100%) rename {man => _archive/man}/add_nevent_regression.Rd (100%) rename {man => _archive/man}/add_overall.Rd (100%) rename {man => _archive/man}/add_p.Rd (100%) rename {man => _archive/man}/add_p.tbl_continuous.Rd (100%) rename {man => _archive/man}/add_p.tbl_cross.Rd (100%) rename {man => _archive/man}/add_p.tbl_summary.Rd (100%) rename {man => _archive/man}/add_p.tbl_survfit.Rd (100%) rename {man => _archive/man}/add_p.tbl_svysummary.Rd (100%) rename {man => _archive/man}/add_q.Rd (100%) rename {man => _archive/man}/add_significance_stars.Rd (100%) rename {man => _archive/man}/add_stat.Rd (100%) rename {man => _archive/man}/add_stat_label.Rd (100%) rename {man => _archive/man}/add_vif.Rd (100%) rename {man => _archive/man}/as_flex_table.Rd (100%) create mode 100644 _archive/man/as_gt.Rd rename {man => _archive/man}/as_hux_table.Rd (100%) rename {man => _archive/man}/as_kable.Rd (100%) rename {man => _archive/man}/as_kable_extra.Rd (100%) rename {man => _archive/man}/as_tibble.gtsummary.Rd (100%) rename {man => _archive/man}/bold_italicize_labels_levels.Rd (100%) rename {man => _archive/man}/bold_p.Rd (100%) rename {man => _archive/man}/combine_terms.Rd (100%) rename {man => _archive/man}/continuous_summary.Rd (100%) rename {man => _archive/man}/custom_tidiers.Rd (100%) rename {man => _archive/man}/deprecated.Rd (100%) rename {man => _archive/man}/dot-create_gtsummary_object.Rd (100%) create mode 100644 _archive/man/dot-table_styling_expr_to_row_number.Rd rename {man => _archive/man}/figures/README-tbl_merge_ex1-1.png (100%) rename {man => _archive/man}/figures/README-tbl_regression_printa-1.png (100%) rename {man => _archive/man}/figures/README-tbl_summary_print_extra-1.png (100%) rename {man => _archive/man}/figures/README-tbl_summary_print_simple-1.png (100%) rename {man => _archive/man}/figures/gt_output_formats.PNG (100%) rename {man => _archive/man}/figures/gtsummary_logo.PNG (100%) rename {man => _archive/man}/figures/lifecycle-archived.svg (100%) rename {man => _archive/man}/figures/lifecycle-defunct.svg (100%) rename {man => _archive/man}/figures/lifecycle-deprecated.svg (100%) rename {man => _archive/man}/figures/lifecycle-experimental.svg (100%) rename {man => _archive/man}/figures/lifecycle-maturing.svg (100%) rename {man => _archive/man}/figures/lifecycle-questioning.svg (100%) rename {man => _archive/man}/figures/lifecycle-retired.svg (100%) rename {man => _archive/man}/figures/lifecycle-soft-deprecated.svg (100%) rename {man => _archive/man}/figures/lifecycle-stable.svg (100%) rename {man => _archive/man}/figures/logo.png (100%) create mode 100644 _archive/man/gtsummary-package.Rd rename {man => _archive/man}/inline_text.Rd (100%) rename {man => _archive/man}/inline_text.gtsummary.Rd (100%) rename {man => _archive/man}/inline_text.tbl_cross.Rd (100%) rename {man => _archive/man}/inline_text.tbl_regression.Rd (100%) rename {man => _archive/man}/inline_text.tbl_summary.Rd (100%) rename {man => _archive/man}/inline_text.tbl_survfit.Rd (100%) rename {man => _archive/man}/inline_text.tbl_survival.Rd (100%) rename {man => _archive/man}/inline_text.tbl_uvregression.Rd (100%) rename {man => _archive/man}/kableExtra_utils.Rd (100%) rename {man => _archive/man}/modify.Rd (100%) rename {man => _archive/man}/modify_column_alignment.Rd (100%) create mode 100644 _archive/man/modify_column_hide.Rd rename {man => _archive/man}/modify_column_indent.Rd (100%) rename {man => _archive/man}/modify_column_merge.Rd (100%) rename {man => _archive/man}/modify_fmt_fun.Rd (100%) rename {man => _archive/man}/modify_table_body.Rd (100%) rename {man => _archive/man}/modify_table_header.Rd (100%) create mode 100644 _archive/man/modify_table_styling.Rd rename {man => _archive/man}/plot.Rd (100%) create mode 100644 _archive/man/print_gtsummary.Rd rename {man => _archive/man}/proportion_summary.Rd (100%) rename {man => _archive/man}/ratio_summary.Rd (100%) create mode 100644 _archive/man/reexports.Rd rename {man => _archive/man}/remove_row_type.Rd (100%) create mode 100644 _archive/man/select_helpers.Rd rename {man => _archive/man}/separate_p_footnotes.Rd (100%) rename {man => _archive/man}/set_gtsummary_theme.Rd (100%) rename {man => _archive/man}/sort_filter_p.Rd (100%) rename {man => _archive/man}/style_number.Rd (100%) rename {man => _archive/man}/style_percent.Rd (100%) rename {man => _archive/man}/style_pvalue.Rd (100%) rename {man => _archive/man}/style_ratio.Rd (100%) rename {man => _archive/man}/style_sigfig.Rd (100%) rename {man => _archive/man}/syntax.Rd (100%) rename {man => _archive/man}/tbl_butcher.Rd (100%) rename {man => _archive/man}/tbl_continuous.Rd (100%) rename {man => _archive/man}/tbl_cross.Rd (100%) rename {man => _archive/man}/tbl_custom_summary.Rd (100%) rename {man => _archive/man}/tbl_merge.Rd (100%) rename {man => _archive/man}/tbl_regression.Rd (100%) rename {man => _archive/man}/tbl_regression_methods.Rd (100%) rename {man => _archive/man}/tbl_split.Rd (100%) rename {man => _archive/man}/tbl_stack.Rd (100%) rename {man => _archive/man}/tbl_strata.Rd (100%) create mode 100644 _archive/man/tbl_summary.Rd rename {man => _archive/man}/tbl_survfit.Rd (100%) rename {man => _archive/man}/tbl_survfit_errors.Rd (100%) rename {man => _archive/man}/tbl_survival.Rd (100%) rename {man => _archive/man}/tbl_svysummary.Rd (100%) rename {man => _archive/man}/tbl_uvregression.Rd (100%) rename {man => _archive/man}/tests.Rd (100%) rename {man => _archive/man}/theme_gtsummary.Rd (100%) rename {man => _archive/man}/tidy_plus_plus_dots.Rd (100%) rename {man => _archive/man}/trial.Rd (100%) rename {pkgdown => _archive/pkgdown}/_pkgdown.yml (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon-120x120.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon-152x152.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon-180x180.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon-60x60.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon-76x76.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/apple-touch-icon.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/favicon-16x16.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/favicon-32x32.png (100%) rename {pkgdown => _archive/pkgdown}/favicon/favicon.ico (100%) rename {tests => _archive/tests}/spelling.R (100%) create mode 100644 _archive/tests/testthat.R rename {tests => _archive/tests}/testthat/_snaps/add_ci.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_difference.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_glance.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_global_p.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_n.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_nevent.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_overall.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p.tbl_continuous.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p.tbl_cross.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p.tbl_summary.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p.tbl_survfit.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p.tbl_svysummary.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_p_test_safe.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_q.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_significance_stars.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_stat_label.md (100%) rename {tests => _archive/tests}/testthat/_snaps/add_vif.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_flex_table.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_gt.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_hux_table.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_kable.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_kable_extra.md (100%) rename {tests => _archive/tests}/testthat/_snaps/as_tibble.md (100%) rename {tests => _archive/tests}/testthat/_snaps/bold_italicize_labels_levels.md (100%) rename {tests => _archive/tests}/testthat/_snaps/bold_p.md (100%) rename {tests => _archive/tests}/testthat/_snaps/combine_terms.md (100%) rename {tests => _archive/tests}/testthat/_snaps/custom_tidiers.md (100%) rename {tests => _archive/tests}/testthat/_snaps/filter_p.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_caption.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_column_alignment.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_column_hide.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_column_indent.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_column_merge.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_fmt_fun.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_footnote.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_header.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_spanning_header.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_table_body.md (100%) rename {tests => _archive/tests}/testthat/_snaps/modify_table_styling.md (100%) rename {tests => _archive/tests}/testthat/_snaps/remove_row_type.md (100%) rename {tests => _archive/tests}/testthat/_snaps/select_helpers.md (100%) rename {tests => _archive/tests}/testthat/_snaps/separate_p_footnotes.md (100%) rename {tests => _archive/tests}/testthat/_snaps/set_gtsummary_theme.md (100%) rename {tests => _archive/tests}/testthat/_snaps/sort_p.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_butcher.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_continuous.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_cross.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_custom_summary.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_merge.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_regression.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_split.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_stack.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_strata.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_summary.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_survfit.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_svysummary.md (100%) rename {tests => _archive/tests}/testthat/_snaps/tbl_uvregression.md (100%) rename {tests => _archive/tests}/testthat/helper-dplyr_storms.R (100%) rename {tests => _archive/tests}/testthat/helper-render_as_html.R (100%) rename {tests => _archive/tests}/testthat/helper-vetted_models.R (100%) rename {tests => _archive/tests}/testthat/test-add_ci.R (100%) rename {tests => _archive/tests}/testthat/test-add_difference.R (100%) rename {tests => _archive/tests}/testthat/test-add_glance.R (100%) rename {tests => _archive/tests}/testthat/test-add_global_p.R (100%) rename {tests => _archive/tests}/testthat/test-add_n.R (100%) rename {tests => _archive/tests}/testthat/test-add_nevent.R (100%) rename {tests => _archive/tests}/testthat/test-add_overall.R (100%) rename {tests => _archive/tests}/testthat/test-add_p.tbl_continuous.R (100%) rename {tests => _archive/tests}/testthat/test-add_p.tbl_cross.R (100%) rename {tests => _archive/tests}/testthat/test-add_p.tbl_summary.R (100%) rename {tests => _archive/tests}/testthat/test-add_p.tbl_survfit.R (100%) rename {tests => _archive/tests}/testthat/test-add_p.tbl_svysummary.R (100%) rename {tests => _archive/tests}/testthat/test-add_p_test_safe.R (100%) rename {tests => _archive/tests}/testthat/test-add_q.R (100%) rename {tests => _archive/tests}/testthat/test-add_significance_stars.R (100%) rename {tests => _archive/tests}/testthat/test-add_stat.R (100%) rename {tests => _archive/tests}/testthat/test-add_stat_label.R (100%) rename {tests => _archive/tests}/testthat/test-add_vif.R (100%) rename {tests => _archive/tests}/testthat/test-as_flex_table.R (100%) rename {tests => _archive/tests}/testthat/test-as_gt.R (100%) rename {tests => _archive/tests}/testthat/test-as_hux_table.R (100%) rename {tests => _archive/tests}/testthat/test-as_hux_xlsx.R (100%) rename {tests => _archive/tests}/testthat/test-as_kable.R (100%) rename {tests => _archive/tests}/testthat/test-as_kable_extra.R (100%) rename {tests => _archive/tests}/testthat/test-as_tibble.R (100%) rename {tests => _archive/tests}/testthat/test-assign_dichotomous_value.R (100%) rename {tests => _archive/tests}/testthat/test-assign_summary_type.R (100%) rename {tests => _archive/tests}/testthat/test-bold_italicize_labels_levels.R (100%) rename {tests => _archive/tests}/testthat/test-bold_p.R (100%) rename {tests => _archive/tests}/testthat/test-combine_terms.R (100%) rename {tests => _archive/tests}/testthat/test-continuous_digits_guess.R (100%) rename {tests => _archive/tests}/testthat/test-custom_tidiers.R (100%) rename {tests => _archive/tests}/testthat/test-filter_p.R (100%) rename {tests => _archive/tests}/testthat/test-inline_text.R (100%) rename {tests => _archive/tests}/testthat/test-modify_caption.R (100%) rename {tests => _archive/tests}/testthat/test-modify_column_alignment.R (100%) rename {tests => _archive/tests}/testthat/test-modify_column_hide.R (100%) rename {tests => _archive/tests}/testthat/test-modify_column_indent.R (100%) rename {tests => _archive/tests}/testthat/test-modify_column_merge.R (100%) rename {tests => _archive/tests}/testthat/test-modify_fmt_fun.R (100%) rename {tests => _archive/tests}/testthat/test-modify_footnote.R (100%) rename {tests => _archive/tests}/testthat/test-modify_header.R (100%) rename {tests => _archive/tests}/testthat/test-modify_spanning_header.R (100%) rename {tests => _archive/tests}/testthat/test-modify_table_body.R (100%) rename {tests => _archive/tests}/testthat/test-modify_table_styling.R (100%) rename {tests => _archive/tests}/testthat/test-plot.R (100%) rename {tests => _archive/tests}/testthat/test-remove_row_type.R (100%) rename {tests => _archive/tests}/testthat/test-select_helpers.R (100%) rename {tests => _archive/tests}/testthat/test-separate_p_footnotes.R (100%) rename {tests => _archive/tests}/testthat/test-set_gtsummary_theme.R (100%) rename {tests => _archive/tests}/testthat/test-show_header_names.R (100%) rename {tests => _archive/tests}/testthat/test-sort_p.R (100%) rename {tests => _archive/tests}/testthat/test-style_number.R (100%) rename {tests => _archive/tests}/testthat/test-style_percent.R (100%) rename {tests => _archive/tests}/testthat/test-style_pvalue.R (100%) rename {tests => _archive/tests}/testthat/test-style_ratio.R (100%) rename {tests => _archive/tests}/testthat/test-style_sigfig.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_butcher.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_continuous.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_cross.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_custom_summary.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_merge.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_regression.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_split.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_stack.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_strata.R (100%) create mode 100644 _archive/tests/testthat/test-tbl_summary.R rename {tests => _archive/tests}/testthat/test-tbl_summary_input_checks.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_survfit.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_survival.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_svysummary.R (100%) rename {tests => _archive/tests}/testthat/test-tbl_uvregression.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-clogit.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-coxph.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-geeglm.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-glm.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-glmer.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-lm.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-lmer.R (100%) rename {tests => _archive/tests}/testthat/test-vetted_models-survreg.R (100%) rename {vignettes => _archive/vignettes}/.gitignore (100%) rename {vignettes => _archive/vignettes}/articles/shiny.Rmd (100%) rename {vignettes => _archive/vignettes}/gallery.Rmd (100%) rename {vignettes => _archive/vignettes}/gtsummary_definition.Rmd (100%) rename {vignettes => _archive/vignettes}/img/icons8-confused-100.png (100%) rename {vignettes => _archive/vignettes}/img/icons8-disappointed-100.png (100%) rename {vignettes => _archive/vignettes}/img/icons8-neutral-100.png (100%) rename {vignettes => _archive/vignettes}/img/icons8-no-entry-100.png (100%) rename {vignettes => _archive/vignettes}/img/icons8-smiling-100.png (100%) rename {vignettes => _archive/vignettes}/img/icons8-under-construction-100.png (100%) rename {vignettes => _archive/vignettes}/inline_text.Rmd (100%) rename {vignettes => _archive/vignettes}/rmarkdown.Rmd (100%) rename {vignettes => _archive/vignettes}/tbl_regression.Rmd (100%) rename {vignettes => _archive/vignettes}/tbl_summary.Rmd (100%) rename {vignettes => _archive/vignettes}/themes.Rmd (100%) create mode 100644 man/bridge_tbl_summary.Rd create mode 100644 man/construct_gtsummary.Rd diff --git a/.Rbuildignore b/.Rbuildignore index 3c35250b82..5f5790b18e 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -37,3 +37,4 @@ ^CRAN-SUBMISSION$ ^man-images$ ^vignettes/articles$ +^_archive$ diff --git a/.Rprofile b/.Rprofile deleted file mode 100644 index 23afe78773..0000000000 --- a/.Rprofile +++ /dev/null @@ -1,5 +0,0 @@ -# this sets the dev folder in the libPath -tryCatch( - devtools::dev_mode(on = TRUE), - error = function(e) invisible() -) diff --git a/DESCRIPTION b/DESCRIPTION index 8515c29a4c..cfbe36765a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,67 +1,38 @@ Package: gtsummary -Title: Presentation-Ready Data Summary and Analytic Result - Tables -Version: 1.7.2.9001 -Authors@R: - c(person(given = "Daniel D.", - family = "Sjoberg", - role = c("aut", "cre"), - email = "danield.sjoberg@gmail.com", - comment = c(ORCID = "0000-0003-0862-2018")), - person(given = "Joseph", - family = "Larmarange", - role = "aut", - comment = c(ORCID = "0000-0001-7097-700X")), - person(given = "Michael", - family = "Curry", - role = "aut", - comment = c(ORCID = "0000-0002-0261-4044")), - person(given = "Jessica", - family = "Lavery", - role = "aut", - comment = c(ORCID = "0000-0002-2746-5647")), - person(given = "Karissa", - family = "Whiting", - role = "aut", - comment = c(ORCID = "0000-0002-4683-1868")), - person(given = "Emily C.", - family = "Zabor", - role = "aut", - comment = c(ORCID = "0000-0002-1402-4498")), - person(given = "Xing", - family = "Bai", - role = "ctb"), - person(given = "Esther", - family = "Drill", - role = "ctb", - comment = c(ORCID = "0000-0002-3315-4538")), - person(given = "Jessica", - family = "Flynn", - role = "ctb", - comment = c(ORCID = "0000-0001-8310-6684")), - person(given = "Margie", - family = "Hannum", - role = "ctb", - comment = c(ORCID = "0000-0002-2953-0449")), - person(given = "Stephanie", - family = "Lobaugh", - role = "ctb"), - person(given = "Shannon", - family = "Pileggi", - role = "ctb", - comment = c(ORCID = "0000-0002-7732-4164")), - person(given = "Amy", - family = "Tin", - role = "ctb", - comment = c(ORCID = "0000-0002-8005-0694")), - person(given = "Gustavo", - family = "Zapata Wainberg", - role = "ctb", - comment = c(ORCID = "0000-0002-2524-3637"))) -Description: Creates presentation-ready tables summarizing data - sets, regression models, and more. The code to create the tables is - concise and highly customizable. Data frames can be summarized with - any function, e.g. mean(), median(), even user-written functions. +Title: Presentation-Ready Data Summary and Analytic Result Tables +Version: 1.9.9.9000 +Authors@R: c( + person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre"), + comment = c(ORCID = "0000-0003-0862-2018")), + person("Joseph", "Larmarange", role = "aut", + comment = c(ORCID = "0000-0001-7097-700X")), + person("Michael", "Curry", role = "aut", + comment = c(ORCID = "0000-0002-0261-4044")), + person("Jessica", "Lavery", role = "aut", + comment = c(ORCID = "0000-0002-2746-5647")), + person("Karissa", "Whiting", role = "aut", + comment = c(ORCID = "0000-0002-4683-1868")), + person("Emily C.", "Zabor", role = "aut", + comment = c(ORCID = "0000-0002-1402-4498")), + person("Xing", "Bai", role = "ctb"), + person("Esther", "Drill", role = "ctb", + comment = c(ORCID = "0000-0002-3315-4538")), + person("Jessica", "Flynn", role = "ctb", + comment = c(ORCID = "0000-0001-8310-6684")), + person("Margie", "Hannum", role = "ctb", + comment = c(ORCID = "0000-0002-2953-0449")), + person("Stephanie", "Lobaugh", role = "ctb"), + person("Shannon", "Pileggi", role = "ctb", + comment = c(ORCID = "0000-0002-7732-4164")), + person("Amy", "Tin", role = "ctb", + comment = c(ORCID = "0000-0002-8005-0694")), + person("Gustavo", "Zapata Wainberg", role = "ctb", + comment = c(ORCID = "0000-0002-2524-3637")) + ) +Description: Creates presentation-ready tables summarizing data sets, + regression models, and more. The code to create the tables is concise + and highly customizable. Data frames can be summarized with any + function, e.g. mean(), median(), even user-written functions. Regression models are summarized and include the reference rows for categorical variables. Common regression models, such as logistic regression and Cox proportional hazards regression, are automatically @@ -71,67 +42,28 @@ License: MIT + file LICENSE URL: https://github.com/ddsjoberg/gtsummary, https://www.danieldsjoberg.com/gtsummary/ BugReports: https://github.com/ddsjoberg/gtsummary/issues -Depends: - R (>= 3.4) Imports: - broom (>= 1.0.1), - broom.helpers (>= 1.14.0), - cli (>= 3.1.1), - dplyr (>= 1.1.1), - forcats (>= 1.0.0), + broom.helpers, + cards (>= 0.0.0.9001), + cli (>= 3.6.1), + dplyr (>= 1.1.3), glue (>= 1.6.2), - gt (>= 0.10.0), - knitr (>= 1.37), - lifecycle (>= 1.0.1), - purrr (>= 1.0.1), - rlang (>= 1.0.3), - stringr (>= 1.4.0), - tibble (>= 3.2.1), - tidyr (>= 1.1.4), - vctrs (>= 0.5.2) + lifecycle (>= 1.0.3), + rlang (>= 1.1.1), + tidyr (>= 1.3.0) Suggests: - aod (>= 1.3.1), - broom.mixed (>= 0.2.9), - car (>= 3.0-11), - cmprsk, - covr, - effectsize (>= 0.6.0), - emmeans (>= 1.7.3), - flextable (>= 0.8.1), - geepack, - ggstats (>= 0.2.1), - Hmisc, - huxtable (>= 5.4.0), - insight (>= 0.15.0), - kableExtra (>= 1.3.4), - lme4, - mgcv, - mice (>= 3.10.0), - nnet, - officer, - openxlsx, - parameters (>= 0.20.2), - parsnip (>= 0.1.7), - rmarkdown, - sandwich (>= 3.0.1), - scales, - smd (>= 0.6.6), - spelling (>= 2.2), - survey, - survival (>= 3.2-11), - testthat (>= 3.0.4), - tidycmprsk (>= 0.1.2), - workflows (>= 0.2.4) + knitr, + testthat (>= 3.2.0) VignetteBuilder: knitr RdMacros: lifecycle +Remotes: + insightsengineering/cards +Config/testthat/edition: 3 +Config/testthat/parallel: true Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 -Config/testthat/edition: 3 -Config/testthat/parallel: true -Config/Needs/website: - lubridate diff --git a/LICENSE b/LICENSE index ad805f4916..f9bb6ab1f3 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2020 -COPYRIGHT HOLDER: Daniel D. Sjoberg +YEAR: 2023 +COPYRIGHT HOLDER: gts2 authors diff --git a/LICENSE.md b/LICENSE.md index f61a44ea48..13f4bd185d 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2020 Daniel D. Sjoberg +Copyright (c) 2023 gts2 authors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/NAMESPACE b/NAMESPACE index 3185d1bb62..24bc3b2611 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,318 +1,58 @@ # Generated by roxygen2: do not edit by hand -S3method(add_ci,tbl_summary) -S3method(add_ci,tbl_svysummary) -S3method(add_global_p,tbl_regression) -S3method(add_global_p,tbl_uvregression) -S3method(add_n,tbl_regression) -S3method(add_n,tbl_summary) -S3method(add_n,tbl_survfit) -S3method(add_n,tbl_svysummary) -S3method(add_n,tbl_uvregression) -S3method(add_nevent,tbl_regression) -S3method(add_nevent,tbl_survfit) -S3method(add_nevent,tbl_uvregression) -S3method(add_overall,tbl_continuous) -S3method(add_overall,tbl_custom_summary) -S3method(add_overall,tbl_summary) -S3method(add_overall,tbl_svysummary) -S3method(add_p,tbl_continuous) -S3method(add_p,tbl_cross) -S3method(add_p,tbl_summary) -S3method(add_p,tbl_survfit) -S3method(add_p,tbl_svysummary) -S3method(as.data.frame,gtsummary) -S3method(as_tibble,gtsummary) -S3method(bold_labels,gtsummary) -S3method(bold_labels,tbl_cross) -S3method(bold_levels,gtsummary) -S3method(bold_levels,tbl_cross) -S3method(inline_text,gtsummary) -S3method(inline_text,tbl_cross) -S3method(inline_text,tbl_regression) -S3method(inline_text,tbl_summary) -S3method(inline_text,tbl_survfit) -S3method(inline_text,tbl_survival) -S3method(inline_text,tbl_svysummary) -S3method(inline_text,tbl_uvregression) -S3method(italicize_labels,gtsummary) -S3method(italicize_labels,tbl_cross) -S3method(italicize_levels,gtsummary) -S3method(italicize_levels,tbl_cross) -S3method(knit_print,gtsummary) -S3method(plot,tbl_regression) -S3method(plot,tbl_uvregression) +S3method(construct_gtsummary,default) +S3method(construct_gtsummary,tbl_summary) S3method(print,gtsummary) -S3method(print,tbl_split) -S3method(tbl_regression,brmsfit) -S3method(tbl_regression,crr) -S3method(tbl_regression,default) -S3method(tbl_regression,gam) -S3method(tbl_regression,glmerMod) -S3method(tbl_regression,glmmTMB) -S3method(tbl_regression,glmmadmb) -S3method(tbl_regression,lmerMod) -S3method(tbl_regression,mipo) -S3method(tbl_regression,mira) -S3method(tbl_regression,model_fit) -S3method(tbl_regression,multinom) -S3method(tbl_regression,stanreg) -S3method(tbl_regression,survreg) -S3method(tbl_regression,tidycrr) -S3method(tbl_regression,workflow) -S3method(tbl_split,gtsummary) -S3method(tbl_survfit,data.frame) -S3method(tbl_survfit,list) -S3method(tbl_survfit,survfit) export("%>%") -export(.create_gtsummary_object) -export(.escape_html) -export(.escape_latex) -export(.escape_latex2) export(.table_styling_expr_to_row_number) -export(add_ci) -export(add_difference) -export(add_glance_source_note) -export(add_glance_table) -export(add_global_p) -export(add_n) -export(add_nevent) -export(add_overall) -export(add_p) -export(add_q) -export(add_significance_stars) -export(add_stat) -export(add_stat_label) -export(add_vif) 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) export(all_stat_cols) export(all_tests) export(any_of) -export(as_flex_table) -export(as_flextable) export(as_gt) -export(as_hux_table) -export(as_hux_xlsx) -export(as_kable) -export(as_kable_extra) export(as_tibble) -export(bold_labels) -export(bold_levels) -export(bold_p) -export(check_gtsummary_theme) -export(combine_terms) +export(bridge_summary_categorical) +export(bridge_summary_continuous) +export(bridge_summary_continuous2) +export(bridge_summary_dichotomous) +export(construct_gtsummary) export(contains) -export(continuous_summary) export(ends_with) export(everything) -export(filter_p) -export(get_gtsummary_theme) -export(inline_text) -export(italicize_labels) -export(italicize_levels) -export(knit_print) export(last_col) export(matches) -export(modify_caption) -export(modify_cols_merge) -export(modify_column_alignment) export(modify_column_hide) -export(modify_column_indent) -export(modify_column_merge) export(modify_column_unhide) -export(modify_fmt_fun) -export(modify_footnote) -export(modify_header) -export(modify_spanning_header) -export(modify_table_body) -export(modify_table_header) export(modify_table_styling) export(mutate) export(num_range) export(one_of) -export(pool_and_tidy_mice) -export(proportion_summary) -export(ratio_summary) -export(remove_row_type) -export(reset_gtsummary_theme) export(select) -export(separate_p_footnotes) -export(set_gtsummary_theme) -export(show_header_names) -export(sort_p) export(starts_with) -export(style_number) -export(style_percent) -export(style_pvalue) -export(style_ratio) -export(style_sigfig) -export(tbl_butcher) -export(tbl_continuous) -export(tbl_cross) -export(tbl_custom_summary) -export(tbl_merge) -export(tbl_regression) -export(tbl_split) -export(tbl_stack) -export(tbl_strata) -export(tbl_strata2) export(tbl_summary) -export(tbl_survfit) -export(tbl_survival) -export(tbl_svysummary) -export(tbl_uvregression) -export(theme_gtsummary_compact) -export(theme_gtsummary_continuous2) -export(theme_gtsummary_eda) -export(theme_gtsummary_journal) -export(theme_gtsummary_language) -export(theme_gtsummary_mean_sd) -export(theme_gtsummary_printer) -export(tidy_bootstrap) -export(tidy_gam) -export(tidy_robust) -export(tidy_standardize) -export(tidy_wald_test) export(vars) -export(with_gtsummary_theme) -importFrom(broom.helpers,.formula_list_to_named_list) -importFrom(broom.helpers,.generic_selector) +import(rlang) importFrom(broom.helpers,.select_to_varnames) -importFrom(cli,cli_alert_danger) -importFrom(cli,cli_alert_info) -importFrom(cli,cli_code) -importFrom(cli,cli_ul) importFrom(dplyr,"%>%") +importFrom(dplyr,across) importFrom(dplyr,all_of) importFrom(dplyr,any_of) -importFrom(dplyr,arrange) -importFrom(dplyr,bind_cols) -importFrom(dplyr,bind_rows) -importFrom(dplyr,case_when) -importFrom(dplyr,coalesce) +importFrom(dplyr,as_tibble) importFrom(dplyr,contains) -importFrom(dplyr,count) -importFrom(dplyr,desc) -importFrom(dplyr,distinct) importFrom(dplyr,ends_with) importFrom(dplyr,everything) -importFrom(dplyr,filter) -importFrom(dplyr,full_join) -importFrom(dplyr,group_by) -importFrom(dplyr,if_else) -importFrom(dplyr,inner_join) importFrom(dplyr,last_col) -importFrom(dplyr,left_join) importFrom(dplyr,matches) importFrom(dplyr,mutate) -importFrom(dplyr,mutate_all) -importFrom(dplyr,mutate_at) -importFrom(dplyr,n) importFrom(dplyr,num_range) importFrom(dplyr,one_of) -importFrom(dplyr,pull) -importFrom(dplyr,rename) -importFrom(dplyr,rename_at) -importFrom(dplyr,row_number) -importFrom(dplyr,rowwise) importFrom(dplyr,select) -importFrom(dplyr,slice) importFrom(dplyr,starts_with) -importFrom(dplyr,ungroup) importFrom(dplyr,vars) -importFrom(glue,as_glue) -importFrom(glue,glue) -importFrom(glue,glue_collapse) -importFrom(gt,html) -importFrom(gt,md) -importFrom(knitr,knit_print) -importFrom(lifecycle,deprecate_soft) -importFrom(purrr,chuck) -importFrom(purrr,compact) -importFrom(purrr,cross_df) -importFrom(purrr,discard) -importFrom(purrr,every) -importFrom(purrr,flatten) -importFrom(purrr,imap) -importFrom(purrr,imap_dfr) -importFrom(purrr,imap_lgl) -importFrom(purrr,keep) -importFrom(purrr,map) -importFrom(purrr,map2) -importFrom(purrr,map2_chr) -importFrom(purrr,map_chr) -importFrom(purrr,map_dbl) -importFrom(purrr,map_dfr) -importFrom(purrr,map_if) -importFrom(purrr,map_lgl) -importFrom(purrr,negate) -importFrom(purrr,partial) -importFrom(purrr,pluck) -importFrom(purrr,pmap) -importFrom(purrr,pmap_chr) -importFrom(purrr,pmap_dbl) -importFrom(purrr,pmap_lgl) -importFrom(purrr,reduce) -importFrom(purrr,some) -importFrom(rlang,"%||%") -importFrom(rlang,":=") -importFrom(rlang,.data) -importFrom(rlang,.env) -importFrom(rlang,abort) -importFrom(rlang,call2) -importFrom(rlang,check_dots_empty) -importFrom(rlang,enexpr) -importFrom(rlang,enquo) -importFrom(rlang,eval_tidy) -importFrom(rlang,expr) -importFrom(rlang,exprs) -importFrom(rlang,inform) -importFrom(rlang,inject) -importFrom(rlang,is_character) -importFrom(rlang,is_empty) -importFrom(rlang,is_function) -importFrom(rlang,is_list) -importFrom(rlang,is_named) -importFrom(rlang,is_string) -importFrom(rlang,parse_expr) -importFrom(rlang,quo_is_null) -importFrom(rlang,quo_text) -importFrom(rlang,set_names) -importFrom(rlang,sym) -importFrom(rlang,syms) -importFrom(stats,as.formula) -importFrom(stats,weights) -importFrom(stringr,fixed) -importFrom(stringr,str_detect) -importFrom(stringr,str_extract_all) -importFrom(stringr,str_locate) -importFrom(stringr,str_remove) -importFrom(stringr,str_remove_all) -importFrom(stringr,str_replace_all) -importFrom(stringr,str_split) -importFrom(stringr,str_starts) -importFrom(stringr,str_sub) -importFrom(stringr,str_wrap) -importFrom(stringr,word) -importFrom(tibble,as_tibble) -importFrom(tibble,deframe) -importFrom(tibble,enframe) -importFrom(tibble,tibble) -importFrom(tibble,tribble) -importFrom(tidyr,complete) -importFrom(tidyr,nest) -importFrom(tidyr,spread) -importFrom(tidyr,unnest) diff --git a/NEWS.md b/NEWS.md index 81ccd0c0f5..18b742ef8b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,8 @@ # gtsummary (development version) -* Fix in `add_difference()` for pair t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) +### Bug Fixes + +* Fix in `add_difference()` for paired t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) # gtsummary 1.7.2 diff --git a/R/as_gt.R b/R/as_gt.R index 9ef8eb2f17..ef7ff514a9 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -31,19 +31,11 @@ #' trial[c("trt", "age", "response", "grade")] %>% #' tbl_summary(by = trt) %>% #' as_gt() -#' @section Example Output: -#' -#' \if{html}{Example 1} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "as_gt_ex1.png", width = "50")` -#' }} - as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { .assert_class(x, "gtsummary") # running pre-conversion function, if present -------------------------------- - x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) + # x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) # merging column specified in `x$table_styling$cols_merge` ------------------- # UPDATE THIS WHEN `gt::cols_merge(rows=)` argument is added! @@ -100,14 +92,14 @@ table_styling_to_gt_calls <- function(x, ...) { # gt ------------------------------------------------------------------------- groupname_col <- switch("groupname_col" %in% x$table_styling$header$column, - "groupname_col" + "groupname_col" ) caption <- switch(!is.null(x$table_styling$caption), - rlang::call2( - attr(x$table_styling$caption, "text_interpret"), - x$table_styling$caption - ) + rlang::call2( + attr(x$table_styling$caption, "text_interpret"), + x$table_styling$caption + ) ) gt_calls[["gt"]] <- expr(gt::gt( @@ -137,9 +129,9 @@ table_styling_to_gt_calls <- function(x, ...) { df_cols_align <- x$table_styling$header %>% select("column", "align") %>% - group_by(.data$align) %>% - nest() %>% - mutate(cols = map(.data$data, ~ pull(.x, column))) + dplyr::group_by(.data$align) %>% + tidyr::nest() %>% + dplyr::mutate(cols = map(.data$data, ~ dplyr::pull(.x, column))) gt_calls[["cols_align"]] <- map( @@ -151,7 +143,7 @@ table_styling_to_gt_calls <- function(x, ...) { ) # indent --------------------------------------------------------------------- - df_indent <- x$table_styling$text_format %>% filter(.data$format_type == "indent") + df_indent <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "indent") gt_calls[["indent"]] <- map( seq_len(nrow(df_indent)), @@ -165,7 +157,7 @@ table_styling_to_gt_calls <- function(x, ...) { ) # indent2 -------------------------------------------------------------------- - df_indent2 <- x$table_styling$text_format %>% filter(.data$format_type == "indent2") + df_indent2 <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "indent2") gt_calls[["indent2"]] <- map( seq_len(nrow(df_indent2)), @@ -190,7 +182,7 @@ table_styling_to_gt_calls <- function(x, ...) { ) # tab_style_bold ------------------------------------------------------------- - df_bold <- x$table_styling$text_format %>% filter(.data$format_type == "bold") + df_bold <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "bold") gt_calls[["tab_style_bold"]] <- map( seq_len(nrow(df_bold)), @@ -204,7 +196,7 @@ table_styling_to_gt_calls <- function(x, ...) { ) # tab_style_italic ----------------------------------------------------------- - df_italic <- x$table_styling$text_format %>% filter(.data$format_type == "italic") + df_italic <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "italic") gt_calls[["tab_style_italic"]] <- map( seq_len(nrow(df_italic)), @@ -231,21 +223,21 @@ table_styling_to_gt_calls <- function(x, ...) { # tab_footnote --------------------------------------------------------------- if (nrow(x$table_styling$footnote) == 0 && - nrow(x$table_styling$footnote_abbrev) == 0) { + nrow(x$table_styling$footnote_abbrev) == 0) { gt_calls[["tab_footnote"]] <- list() } else { df_footnotes <- - bind_rows( + dplyr::bind_rows( x$table_styling$footnote, x$table_styling$footnote_abbrev ) %>% - nest(data = c("column", "row_numbers")) %>% - rowwise() %>% - mutate( + tidyr::nest(data = c("column", "row_numbers")) %>% + dplyr::rowwise() %>% + dplyr::mutate( columns = .data$data %>% pull("column") %>% unique() %>% list(), rows = .data$data %>% pull("row_numbers") %>% unique() %>% list() ) %>% - ungroup() + dplyr::ungroup() df_footnotes$footnote_exp <- map2( df_footnotes$text_interpret, @@ -284,17 +276,17 @@ table_styling_to_gt_calls <- function(x, ...) { # spanning_header ------------------------------------------------------------ df_spanning_header <- x$table_styling$header %>% - select("column", "interpret_spanning_header", "spanning_header") %>% - filter(!is.na(.data$spanning_header)) %>% - nest(cols = "column") %>% - mutate( + dplyr::select("column", "interpret_spanning_header", "spanning_header") %>% + dplyr::filter(!is.na(.data$spanning_header)) %>% + tidyr::nest(cols = "column") %>% + dplyr::mutate( spanning_header = map2( .data$interpret_spanning_header, .data$spanning_header, ~ call2(parse_expr(.x), .y) ), cols = map(.data$cols, ~ pull(.x)) ) %>% - select("spanning_header", "cols") + dplyr::select("spanning_header", "cols") gt_calls[["tab_spanner"]] <- map( diff --git a/R/bridge_tbl_summary.R b/R/bridge_tbl_summary.R new file mode 100644 index 0000000000..c0809661c8 --- /dev/null +++ b/R/bridge_tbl_summary.R @@ -0,0 +1,357 @@ +#' Summary Table Bridges +#' +#' Bridge functions for converting `tbl_summary()` cards to table bodies. +#' +#' @param x gtsummary object of class `"tbl_summary"` +#' @param variables character list of variables +#' @param value named list of values to be summarized. the names are the +#' variable names. +#' @inheritParams tbl_summary +#' +#' @return data frame +#' @name bridge_tbl_summary +#' +#' @examples +#' tbl <- +#' tbl_summary( +#' data = mtcars, +#' type = +#' list( +#' cyl = "categorical", +#' am = "dichotomous", +#' mpg = "continuous", +#' hp = "continuous2" +#' ), +#' value = list(am = 1), +#' statistic = +#' list( +#' c(cyl, am) ~ "{n} ({p}%)", +#' mpg = "{mean} ({sd})", +#' hp = c("{mean}", "{median}") +#' ) +#' ) +#' +#' bridge_summary_dichotomous( +#' x = tbl, +#' variables = "am", +#' value = list(am = 1), +#' missing = "ifany", +#' missing_text = "Unknown", +#' missing_stat = "{N_miss}" +#' ) +#' +#' bridge_summary_categorical( +#' x = tbl, +#' variables = "cyl", +#' missing = "ifany", +#' missing_text = "Unknown", +#' missing_stat = "{N_miss}" +#' ) +#' +#' bridge_summary_continuous2( +#' x = tbl, +#' variables = "hp", +#' missing = "ifany", +#' missing_text = "Unknown", +#' missing_stat = "{N_miss}" +#' ) +#' +#' bridge_summary_continuous( +#' x = tbl, +#' variables = "mpg", +#' missing = "ifany", +#' missing_text = "Unknown", +#' missing_stat = "{N_miss}" +#' ) +NULL + +#' @rdname bridge_tbl_summary +#' @export +bridge_summary_dichotomous <- function(x, variables, value, missing, missing_text, missing_stat) { + # subsetting cards object on dichotomous summaries --------------------------- + x$cards <- + x$cards |> + dplyr::filter( + .by = c(cards::all_ard_groups(), "variable"), + .data$variable %in% .env$variables, + .data$variable_level %in% list(NULL) | + .data$variable_level %in% list(value[[.data$variable[1]]]) + ) |> + # updating the context to continuous, because it will be process that way below + dplyr::mutate( + context = ifelse(.data$context %in% "categorical", "continuous", .data$context) + ) + + bridge_summary_continuous(x = x, variables = variables) +} + +#' @rdname bridge_tbl_summary +#' @export +bridge_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { + # subsetting cards object on categorical summaries ---------------------------- + card <- + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "categorical") |> + cards::apply_statistic_fmt_fn() + + # construct formatted statistics --------------------------------------------- + df_glued <- + # construct stat columns with glue by grouping variables and primary summary variable + card |> + dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_map( + function(df_variable_stats, df_groups_and_variable) { + lst_variable_stats <- + cards::get_ard_statistics( + df_variable_stats, + .data$variable_level %in% list(NULL), + .column = "statistic_fmt", + .attributes = NULL + ) + + str_statistic_pre_glue <- + x$calls$tbl_summary$statistic[[df_groups_and_variable$variable[1]]] + + dplyr::mutate( + .data = df_groups_and_variable, + df_stats = + dplyr::filter(df_variable_stats, !.data$variable_level %in% list(NULL)) |> + dplyr::group_by(.data$variable_level) |> + dplyr::group_map( + function(df_variable_level_stats, df_variable_levels) { + dplyr::mutate( + .data = df_variable_levels, + stat = + map( + str_statistic_pre_glue, + function(str_to_glue) { + stat = + glue::glue( + str_to_glue, + .envir = + cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt", .attributes = NULL) |> + c(lst_variable_stats) + ) |> + as.character() + + } + ), + label = unlist(.data$variable_level) |> as.character() + ) + } + ) |> + dplyr::bind_rows() |> + list() + ) + } + ) |> + dplyr::bind_rows() + + # reshape results for final table -------------------------------------------- + df_result_levels <- + df_glued |> + # merge in variable label + dplyr::left_join( + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label") |> + dplyr::select("variable", var_label = "statistic"), + by = "variable" + ) |> + dplyr::mutate( + .by = "variable", + statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), + row_type = "level", + var_label = unlist(.data$var_label), + .after = 0L + ) |> + dplyr::select(-cards::all_ard_groups()) |> + tidyr::unnest(cols = "df_stats") |> + tidyr::unnest(cols = "stat") |> + tidyr::pivot_wider( + id_cols = c("row_type", "var_label", "variable", "label"), + names_from = "statistic_id", + values_from = "stat", + names_glue = "stat_{statistic_id}" + ) + + # add header rows to results ------------------------------------------------- + df_results <- + map( + variables, + ~dplyr::bind_rows( + df_result_levels |> + dplyr::select("variable", "var_label", "row_type") |> + dplyr::filter(.data$variable %in% .x) |> + dplyr::filter(dplyr::row_number() %in% 1L) |> + dplyr::mutate( + label = .data$var_label, + row_type = "header" + ), + df_result_levels |> + dplyr::filter(.data$variable %in% .x) + ) + ) |> + dplyr::bind_rows() + + df_results +} + +#' @rdname bridge_tbl_summary +#' @export +bridge_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { + # subsetting cards object on continuous2 summaries ---------------------------- + card <- + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "continuous") |> + cards::apply_statistic_fmt_fn() + + # construct formatted statistics --------------------------------------------- + df_glued <- + # construct stat columns with glue by grouping variables and primary summary variable + card |> + dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_map( + function(.x, .y) { + dplyr::mutate( + .data = .y, + stat = + map( + x$calls$tbl_summary$statistic[[.y$variable[1]]], + function(str_to_glue) { + stat = + glue::glue( + str_to_glue, + .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) + ) |> + as.character() + + } + ) |> + list(), + label = + map( + x$calls$tbl_summary$statistic[[.y$variable[1]]], + function(str_to_glue) { + label = + glue::glue( + str_to_glue, + .envir = cards::get_ard_statistics(.x, .column = "stat_label", .attributes = NULL) + ) |> + as.character() + } + ) |> + list() + ) + } + ) |> + dplyr::bind_rows() + + # reshape results for final table -------------------------------------------- + df_result_levels <- + df_glued |> + # merge in variable label + dplyr::left_join( + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label") |> + dplyr::select("variable", var_label = "statistic"), + by = "variable" + ) |> + dplyr::mutate( + .by = "variable", + statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), + row_type = "level", + var_label = unlist(.data$var_label), + .after = 0L + ) |> + dplyr::select(-cards::all_ard_groups()) |> + tidyr::unnest(cols = c("stat", "label")) |> + tidyr::unnest(cols = c("stat", "label")) |> + tidyr::pivot_wider( + id_cols = c("row_type", "var_label", "variable", "label"), + names_from = "statistic_id", + values_from = "stat", + names_glue = "stat_{statistic_id}" + ) + + # add header rows to results ------------------------------------------------- + df_results <- + map( + variables, + ~dplyr::bind_rows( + df_result_levels |> + dplyr::select("variable", "var_label", "row_type") |> + dplyr::filter(.data$variable %in% .x) |> + dplyr::filter(dplyr::row_number() %in% 1L) |> + dplyr::mutate( + label = .data$var_label, + row_type = "header" + ), + df_result_levels |> + dplyr::filter(.data$variable %in% .x) + ) + ) |> + dplyr::bind_rows() + + df_results +} + +#' @rdname bridge_tbl_summary +#' @export +bridge_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { + # subsetting cards object on continuous summaries ---------------------------- + card <- + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "continuous") |> + cards::apply_statistic_fmt_fn() + + # construct formatted statistics --------------------------------------------- + df_glued <- + # construct stat columns with glue by grouping variables and primary summary variable + card |> + dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_map( + ~dplyr::mutate( + .data = .y, + stat = + glue::glue( + x$calls$tbl_summary$statistic[[.data$variable[1]]], + .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) + ) |> + as.character() + ) + ) |> + dplyr::bind_rows() + + # reshape results for final table -------------------------------------------- + df_results <- + df_glued |> + # merge in variable label + dplyr::left_join( + x$cards |> + dplyr::filter(.data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label") |> + dplyr::select("variable", var_label = "statistic"), + by = "variable" + ) |> + dplyr::mutate( + .by = "variable", + statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), + row_type = "header", + var_label = unlist(.data$var_label), + label = .data$var_label, + .after = 0L + ) |> + tidyr::pivot_wider( + id_cols = c("row_type", "var_label", "variable", "label"), + names_from = "statistic_id", + values_from = "stat", + names_glue = "stat_{statistic_id}" + ) + + df_results +} diff --git a/R/construct_table_body.R b/R/construct_table_body.R new file mode 100644 index 0000000000..3c696c333f --- /dev/null +++ b/R/construct_table_body.R @@ -0,0 +1,68 @@ +#' Construct Table Body +#' +#' @param x gtsummary object +#' +#' @return gtsummary object +#' @name construct_gtsummary +#' +#' @examples +#' # TODO: Add example +NULL + +#' @rdname construct_gtsummary +#' @export +construct_gtsummary <- function(x) { + if (!inherits(x, "gtsummary")) + cli::cli_abort("Object must be class {.cls gtsummary}.") + UseMethod("construct_gtsummary") +} + +#' @rdname construct_gtsummary +#' @export +construct_gtsummary.default <- function(x) { + cli::cli_abort("There is no {.fun construct_table_body} method for object of class {.cls {class(x)}}.") +} + +#' @rdname construct_gtsummary +#' @export +construct_gtsummary.tbl_summary <- function(x) { + # build the table body pieces with bridge functions and stack them ----------- + x$table_body <- + dplyr::left_join( + dplyr::tibble(variable = x$calls$tbl_summary$include), + dplyr::bind_rows( + bridge_summary_continuous( + x, + variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous") + ), + bridge_summary_continuous2( + x, + variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous2") + ), + bridge_summary_categorical( + x, + variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "categorical") + ), + bridge_summary_dichotomous( + x, + variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "dichotomous"), + value = x$calls$tbl_summary$value + ) + ), + by = "variable" + ) + + # construct default table_styling -------------------------------------------- + x <- construct_initial_table_styling(x) + + # update table_styling ------------------------------------------------------- + x <- x |> + modify_header( + label = "**Characteristic**", + all_stat_cols() ~ + .ifelse1(is.null(x$calls$tbl_summary$by), "**N = {N}**", "**{level}** \nN = {N}") + ) + + # return object with table_body included ------------------------------------- + x +} diff --git a/R/gtsummary-package.R b/R/gtsummary-package.R index 34ac0d04e1..287f922e54 100644 --- a/R/gtsummary-package.R +++ b/R/gtsummary-package.R @@ -1,41 +1,11 @@ -#' @importFrom dplyr mutate select n group_by ungroup filter pull case_when -#' if_else full_join left_join distinct bind_rows count coalesce arrange rename -#' rename_at bind_cols mutate_all mutate_at slice desc rowwise inner_join -#' row_number -#' @importFrom purrr map imap map2 pmap map_chr map_dfr map_lgl map_dbl map_if -#' imap_dfr imap_lgl map2_chr pmap_lgl pmap_chr pmap_dbl compact keep discard -#' every some pluck flatten negate partial cross_df reduce chuck -#' @importFrom tidyr nest unnest complete spread -#' @importFrom tibble tibble tribble as_tibble enframe deframe -#' @importFrom rlang .data .env %||% set_names sym syms parse_expr expr exprs -#' call2 := inform abort is_function is_string enexpr inject is_empty -#' is_function is_list is_named is_character check_dots_empty -#' quo_is_null enquo eval_tidy quo_text -#' @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 -#' str_sub -#' @importFrom broom.helpers .formula_list_to_named_list .select_to_varnames -#' .generic_selector -#' @importFrom cli cli_alert_info cli_alert_danger cli_code cli_ul -#' @importFrom gt md html #' @keywords internal +#' @import rlang +#' @importFrom broom.helpers .select_to_varnames +#' @importFrom dplyr across "_PACKAGE" -# allowing for the use of the dot when piping -utils::globalVariables(".") - ## usethis namespace: start -#' @importFrom lifecycle deprecate_soft ## usethis namespace: end NULL -release_bullets <- function() { - c( - "Check the output from `devtools::check()` and look for warnings or messages", - "Review deprecation schedule", - "Run the code styler", - "Updated the gt help file images", - "Check build size is less than 5MB" - ) -} +utils::globalVariables(c(".")) diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index 6badc4dd9d..bdf0e282bd 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -17,12 +17,6 @@ #' modify_column_hide(columns = ci) %>% #' modify_column_unhide(columns = std.error) #' } -#' @section Example Output: -#' \if{html}{Example 1} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "modify_column_hide_ex1.png", width = "45")` -#' }} NULL #' @rdname modify_column_hide diff --git a/R/modify_header.R b/R/modify_header.R new file mode 100644 index 0000000000..9273e227d8 --- /dev/null +++ b/R/modify_header.R @@ -0,0 +1,40 @@ + + +modify_header <- function(x, ..., text_interpret = c("md", "html"), + quiet = NULL, update = NULL, stat_by = NULL) { + # process inputs ------------------------------------------------------------- + dots <- rlang::dots_list(...) + text_interpret <- rlang::arg_match(text_interpret) + + # deprecated arguments + if (!is.null(stat_by)) { + lifecycle::deprecate_stop( + "1.3.6", "gtsummary::modify_header(stat_by=)", + details = glue("Use `all_stat_cols(FALSE) ~ {stat_by}` instead.") + ) + } + if (!is.null(update)) { + lifecycle::deprecate_warn( + "2.0.0", "gtsummary::modify_header(update=)", + details = "Use `modify_header(...)` input instead." + ) + if (is.factor(dots)) dots <- c(list(dots), update) + else dots <- c(list(dots), update) + } + + cards::process_formula_selectors(data = x$table_body, dots = dots) + + # updated header meta data + x$table_styling$header <- + x$table_styling$header |> + dplyr::mutate( + hide = ifelse(.data$column %in% names(dots), FALSE, .data$hide) + ) |> + dplyr::rows_update( + tibble::enframe(unlist(dots), name = "column", value = "label"), + by = "column" + ) + + # return object + x +} diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index f10456a3c7..4326e269a9 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -140,7 +140,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - tibble(column = columns, interpret_label = text_interpret, label = label), + dplyr::tibble(column = columns, interpret_label = text_interpret, label = label), by = "column" ) } @@ -150,7 +150,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - tibble(column = columns, interpret_label = text_interpret, spanning_header = spanning_header), + dplyr::tibble(column = columns, interpret_label = text_interpret, spanning_header = spanning_header), by = "column" ) } @@ -160,7 +160,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - tibble(column = columns, hide = hide), + dplyr::tibble(column = columns, hide = hide), by = "column" ) } @@ -170,7 +170,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - tibble(column = columns, align = align), + dplyr::tibble(column = columns, align = align), by = "column" ) } @@ -178,9 +178,9 @@ modify_table_styling <- function(x, # footnote ------------------------------------------------------------------- if (!is.null(footnote)) { x$table_styling$footnote <- - bind_rows( + dplyr::bind_rows( x$table_styling$footnote, - tibble( + dplyr::tibble( column = columns, rows = list(rows), text_interpret = text_interpret, @@ -192,9 +192,9 @@ modify_table_styling <- function(x, # footnote_abbrev ------------------------------------------------------------ if (!is.null(footnote_abbrev)) { x$table_styling$footnote_abbrev <- - bind_rows( + dplyr::bind_rows( x$table_styling$footnote_abbrev, - tibble( + dplyr::tibble( column = columns, rows = list(rows), text_interpret = text_interpret, @@ -209,7 +209,7 @@ modify_table_styling <- function(x, x$table_styling$fmt_fun <- bind_rows( x$table_styling$fmt_fun, - tibble( + dplyr::tibble( column = columns, rows = list(rows), fmt_fun = fmt_fun @@ -230,7 +230,7 @@ modify_table_styling <- function(x, tidyr::expand_grid(!!!.) } %>% { - bind_rows(x$table_styling$text_format, .) + dplyr::bind_rows(x$table_styling$text_format, .) } } @@ -246,7 +246,7 @@ modify_table_styling <- function(x, tidyr::expand_grid(!!!.) } %>% { - bind_rows(x$table_styling$fmt_missing, .) + dplyr::bind_rows(x$table_styling$fmt_missing, .) } } @@ -272,8 +272,8 @@ modify_table_styling <- function(x, rows <- enquo(rows) all_columns <- str_extract_all(pattern, "\\{.*?\\}") %>% - map(~ str_remove_all(.x, pattern = fixed("}"))) %>% - map(~ str_remove_all(.x, pattern = fixed("{"))) %>% + map(~ stringr::str_remove_all(.x, pattern = fixed("}"))) %>% + map(~ stringr::str_remove_all(.x, pattern = fixed("{"))) %>% unlist() if (!is.na(pattern) && !all(all_columns %in% x$table_styling$header$column)) { @@ -295,9 +295,9 @@ modify_table_styling <- function(x, x$table_styling$cols_merge <- x$table_styling$cols_merge %>% # remove previous merging for specified column - filter(!.data$column %in% .env$column) %>% + dplyr::filter(!.data$column %in% .env$column) %>% # append new merge instructions - bind_rows( + dplyr::bind_rows( tibble( column = column, rows = list(rows), diff --git a/R/print.R b/R/print.R index ef0aee8123..196628eda0 100644 --- a/R/print.R +++ b/R/print.R @@ -7,29 +7,28 @@ #' `"gt"`, `"kable"`, `"kable_extra"`, `"flextable"`, `"tibble"` #' @param ... Not used #' @author Daniel D. Sjoberg -#' @seealso [tbl_summary] [tbl_regression] [tbl_uvregression] [tbl_merge] [tbl_stack] NULL #' @rdname print_gtsummary #' @export -print.gtsummary <- function(x, print_engine = NULL, ...) { +print.gtsummary <- function(x, print_engine = "gt", ...) { check_dots_empty(error = function(e) inform(c(e$message, e$body))) - # select print engine - print_engine <- - print_engine %||% - .get_deprecated_option("gtsummary.print_engine") %||% - get_theme_element("pkgwide-str:print_engine") %||% - "gt" # default printer is gt - - # checking engine - accepted_print_engines <- - c("gt", "kable", "kable_extra", "flextable", "huxtable", "tibble") - if (!rlang::is_string(print_engine) || !print_engine %in% accepted_print_engines) { - stop(glue( - "Select a valid print engine. ", - "Please select one of {quoted_list(accepted_print_engines)}" - )) - } + # # select print engine + # print_engine <- + # print_engine %||% + # .get_deprecated_option("gtsummary.print_engine") %||% + # # get_theme_element("pkgwide-str:print_engine") %||% + # "gt" # default printer is gt + # + # # checking engine + # accepted_print_engines <- + # c("gt", "kable", "kable_extra", "flextable", "huxtable", "tibble") + # if (!rlang::is_string(print_engine) || !print_engine %in% accepted_print_engines) { + # stop(glue( + # "Select a valid print engine. ", + # "Please select one of {quoted_list(accepted_print_engines)}" + # )) + # } # printing results switch(print_engine, @@ -43,76 +42,3 @@ print.gtsummary <- function(x, print_engine = NULL, ...) { print() } -#' @rdname print_gtsummary -#' @export -knit_print.gtsummary <- function(x, ...) { - # assigning print engine ----------------------------------------------------- - # select print engine - print_engine <- - .get_deprecated_option("gtsummary.print_engine") %||% - get_theme_element("pkgwide-str:print_engine") - - # gt is the default printer for html output - if (is.null(print_engine) && knitr::is_html_output() == TRUE) { - print_engine <- "gt" - } - - # PDF uses kable as default printer (is_latex_output catches pdf_document and beamer...maybe more?) - else if (is.null(print_engine) && knitr::is_latex_output() == TRUE) { - rlang::inform(paste( - "Table printed with `knitr::kable()`, not {gt}. Learn why at", - "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", - "To suppress this message, include `message = FALSE` in code chunk header.", - sep = "\n" - )) - print_engine <- "kable" - } - - # don't use word_document with gt engine - else if (identical(print_engine %||% "gt", "gt") && - "docx" %in% knitr::opts_knit$get("rmarkdown.pandoc.to")) { - if (assert_package("flextable", boolean = TRUE)) { - rlang::inform(paste( - "Table printed with {flextable}, not {gt}. Learn why at", - "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", - "To suppress this message, include `message = FALSE` in the code chunk header.", - sep = "\n" - )) - print_engine <- "flextable" - } else { - rlang::inform(paste( - "Table printed with `knitr::kable()`, not {gt}. Learn why at", - "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", - "To suppress this message, include `message = FALSE` in the code chunk header.", - sep = "\n" - )) - print_engine <- "kable" - } - } - - # RTF warning when using gt - else if (identical(print_engine %||% "gt", "gt") && - "rtf" %in% knitr::opts_knit$get("rmarkdown.pandoc.to")) { - rlang::inform(paste( - "Table printed with `knitr::kable()`, not {gt}. Learn why at", - "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", - "To suppress this message, include `message = FALSE` in code chunk header.", - sep = "\n" - )) - print_engine <- "kable" - } - - # all other types (if any), will attempt to print with gt - else if (is.null(print_engine)) print_engine <- "gt" - - # printing gtsummary table with appropriate engine - switch(print_engine, - "gt" = as_gt(x), - "kable" = as_kable(x), - "flextable" = as_flex_table(x), - "kable_extra" = as_kable_extra(x), - "huxtable" = as_hux_table(x), - "tibble" = as_tibble(x) - ) %>% - knitr::knit_print() -} diff --git a/R/reexport.R b/R/reexport.R index c6c96d3a15..b32db33c67 100644 --- a/R/reexport.R +++ b/R/reexport.R @@ -1,21 +1,11 @@ -# tibble ----------------------------------------------------------------------- -#' @export -#' @importFrom tibble as_tibble -tibble::as_tibble - -# knitr ------------------------------------------------------------------------ -#' @export -#' @importFrom knitr knit_print -knitr::knit_print - # dplyr ------------------------------------------------------------------------ #' @export #' @importFrom dplyr %>% dplyr::`%>%` -#' @importFrom dplyr vars #' @export -dplyr::vars +#' @importFrom dplyr as_tibble +dplyr::as_tibble #' @importFrom dplyr select #' @export @@ -64,3 +54,7 @@ dplyr::last_col #' @importFrom dplyr one_of #' @export dplyr::one_of + +#' @importFrom dplyr vars +#' @export +dplyr::vars diff --git a/R/select_helpers.R b/R/select_helpers.R index 84ef2bc720..d13c78258b 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -31,12 +31,6 @@ #' statistic = all_continuous() ~ "{mean} ({sd})", #' type = all_dichotomous() ~ "categorical" #' ) -#' @section Example Output: -#' \if{html}{Example 1} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "select_ex1.png", width = "55")` -#' }} NULL #' @rdname select_helpers diff --git a/R/standalone-purrr.R b/R/standalone-purrr.R new file mode 100644 index 0000000000..9cb36e941e --- /dev/null +++ b/R/standalone-purrr.R @@ -0,0 +1,236 @@ +# --- +# repo: r-lib/rlang +# file: standalone-purrr.R +# last-updated: 2023-02-23 +# license: https://unlicense.org +# imports: rlang +# --- +# +# This file provides a minimal shim to provide a purrr-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# 2023-02-23: +# * Added `list_c()` +# +# 2022-06-07: +# * `transpose()` is now more consistent with purrr when inner names +# are not congruent (#1346). +# +# 2021-12-15: +# * `transpose()` now supports empty lists. +# +# 2021-05-21: +# * Fixed "object `x` not found" error in `imap()` (@mgirlich) +# +# 2020-04-14: +# * Removed `pluck*()` functions +# * Removed `*_cpl()` functions +# * Used `as_function()` to allow use of `~` +# * Used `.` prefix for helpers +# +# nocov start + +map <- function(.x, .f, ...) { + .f <- as_function(.f, env = global_env()) + lapply(.x, .f, ...) +} +walk <- function(.x, .f, ...) { + map(.x, .f, ...) + invisible(.x) +} + +map_lgl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, logical(1), ...) +} +map_int <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, integer(1), ...) +} +map_dbl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, double(1), ...) +} +map_chr <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, character(1), ...) +} +.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { + .f <- as_function(.f, env = global_env()) + out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) + names(out) <- names(.x) + out +} + +map2 <- function(.x, .y, .f, ...) { + .f <- as_function(.f, env = global_env()) + out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) + if (length(out) == length(.x)) { + set_names(out, names(.x)) + } else { + set_names(out, NULL) + } +} +map2_lgl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "logical") +} +map2_int <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "integer") +} +map2_dbl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "double") +} +map2_chr <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "character") +} +imap <- function(.x, .f, ...) { + map2(.x, names(.x) %||% seq_along(.x), .f, ...) +} + +pmap <- function(.l, .f, ...) { + .f <- as.function(.f) + args <- .rlang_purrr_args_recycle(.l) + do.call("mapply", c( + FUN = list(quote(.f)), + args, MoreArgs = quote(list(...)), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) +} +.rlang_purrr_args_recycle <- function(args) { + lengths <- map_int(args, length) + n <- max(lengths) + + stopifnot(all(lengths == 1L | lengths == n)) + to_recycle <- lengths == 1L + args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) + + args +} + +keep <- function(.x, .f, ...) { + .x[.rlang_purrr_probe(.x, .f, ...)] +} +discard <- function(.x, .p, ...) { + sel <- .rlang_purrr_probe(.x, .p, ...) + .x[is.na(sel) | !sel] +} +map_if <- function(.x, .p, .f, ...) { + matches <- .rlang_purrr_probe(.x, .p) + .x[matches] <- map(.x[matches], .f, ...) + .x +} +.rlang_purrr_probe <- function(.x, .p, ...) { + if (is_logical(.p)) { + stopifnot(length(.p) == length(.x)) + .p + } else { + .p <- as_function(.p, env = global_env()) + map_lgl(.x, .p, ...) + } +} + +compact <- function(.x) { + Filter(length, .x) +} + +transpose <- function(.l) { + if (!length(.l)) { + return(.l) + } + + inner_names <- names(.l[[1]]) + + if (is.null(inner_names)) { + fields <- seq_along(.l[[1]]) + } else { + fields <- set_names(inner_names) + .l <- map(.l, function(x) { + if (is.null(names(x))) { + set_names(x, inner_names) + } else { + x + } + }) + } + + # This way missing fields are subsetted as `NULL` instead of causing + # an error + .l <- map(.l, as.list) + + map(fields, function(i) { + map(.l, .subset2, i) + }) +} + +every <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) + } + TRUE +} +some <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) + } + FALSE +} +negate <- function(.p) { + .p <- as_function(.p, env = global_env()) + function(...) !.p(...) +} + +reduce <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init) +} +reduce_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE) +} +accumulate <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init, accumulate = TRUE) +} +accumulate_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) +} + +detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(.x[[i]]) + } + } + NULL +} +detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(i) + } + } + 0L +} +.rlang_purrr_index <- function(x, right = FALSE) { + idx <- seq_along(x) + if (right) { + idx <- rev(idx) + } + idx +} + +list_c <- function(x) { + inject(c(!!!x)) +} + +# nocov end diff --git a/R/tbl_summary.R b/R/tbl_summary.R index d15a514938..3cf8727f23 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -1,484 +1,99 @@ -#' Create a table of summary statistics -#' -#' The `tbl_summary` function calculates descriptive statistics for -#' continuous, categorical, and dichotomous variables. Review the -#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} -#' for detailed examples. -#' -#' @param data A data frame -#' @param by A column name (quoted or unquoted) in `data`. -#' Summary statistics will be calculated separately for each level of the `by` -#' variable (e.g. `by = trt`). If `NULL`, summary statistics -#' are calculated using all observations. To stratify a table by two or more -#' variables, use `tbl_strata()` -#' @param label List of formulas specifying variables labels, -#' e.g. `list(age ~ "Age", stage ~ "Path T Stage")`. If a -#' variable's label is not specified here, the label attribute -#' (`attr(data$age, "label")`) is used. If -#' attribute label is `NULL`, the variable name will be used. -#' @param type List of formulas specifying variable types. Accepted values -#' are `c("continuous", "continuous2", "categorical", "dichotomous")`, -#' e.g. `type = list(age ~ "continuous", female ~ "dichotomous")`. -#' If type not specified for a variable, the function -#' will default to an appropriate summary type. See below for details. -#' @param value List of formulas specifying the value to display for dichotomous -#' variables. gtsummary selectors, e.g. `all_dichotomous()`, cannot be used -#' with this argument. See below for details. -#' @param statistic List of formulas specifying types of summary statistics to -#' display for each variable. The default is -#' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. -#' See below for details. -#' @param digits List of formulas specifying the number of decimal -#' places to round summary statistics. If not specified, -#' `tbl_summary` guesses an appropriate number of decimals to round statistics. -#' When multiple statistics are displayed for a single variable, supply a vector -#' rather than an integer. For example, if the -#' statistic being calculated is `"{mean} ({sd})"` and you want the mean rounded -#' to 1 decimal place, and the SD to 2 use `digits = list(age ~ c(1, 2))`. User -#' may also pass a styling function: `digits = age ~ style_sigfig` -#' @param missing Indicates whether to include counts of `NA` values in the table. -#' Allowed values are `"no"` (never display NA values), -#' `"ifany"` (only display if any NA values), and `"always"` -#' (includes NA count row for all variables). Default is `"ifany"`. -#' @param missing_text String to display for count of missing observations. -#' Default is `"Unknown"`. -#' @param sort List of formulas specifying the type of sorting to perform for -#' categorical data. Options are `frequency` where results are sorted in -#' descending order of frequency and `alphanumeric`, -#' e.g. `sort = list(everything() ~ "frequency")` -#' @param percent Indicates the type of percentage to return. Must be one of -#' `"column"`, `"row"`, or `"cell"`. Default is `"column"`. -#' @param include variables to include in the summary table. Default is `everything()` -#' -#' @section select helpers: -#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#select_helpers}{Select helpers} -#' from the \\{tidyselect\\} package and \\{gtsummary\\} package are available to -#' modify default behavior for groups of variables. -#' For example, by default continuous variables are reported with the median -#' and IQR. To change all continuous variables to mean and standard deviation use -#' `statistic = list(all_continuous() ~ "{mean} ({sd})")`. -#' -#' All columns with class logical are displayed as dichotomous variables showing -#' the proportion of events that are `TRUE` on a single row. To show both rows -#' (i.e. a row for `TRUE` and a row for `FALSE`) use -#' `type = list(where(is.logical) ~ "categorical")`. -#' -#' The select helpers are available for use in any argument that accepts a list -#' of formulas (e.g. `statistic`, `type`, `digits`, `value`, `sort`, etc.) -#' -#' Read more on the [syntax] used through the package. -#' -#' @section type argument: -#' The `tbl_summary()` function has four summary types: -#' - `"continuous"` summaries are shown on a *single row*. Most numeric -#' variables default to summary type continuous. -#' - `"continuous2"` summaries are shown on *2 or more rows* -#' - `"categorical"` *multi-line* summaries of nominal data. Character variables, -#' factor variables, and numeric variables with fewer than 10 unique levels default to -#' type categorical. To change a numeric variable to continuous that -#' defaulted to categorical, use `type = list(varname ~ "continuous")` -#' - `"dichotomous"` categorical variables that are displayed on a *single row*, -#' rather than one row per level of the variable. -#' Variables coded as `TRUE`/`FALSE`, `0`/`1`, or `yes`/`no` are assumed to be dichotomous, -#' and the `TRUE`, `1`, and `yes` rows are displayed. -#' Otherwise, the value to display must be specified in the `value` -#' argument, e.g. `value = list(varname ~ "level to show")` -#' -#' @section statistic argument: -#' The statistic argument specifies the statistics presented in the table. The -#' input is a list of formulas that specify the statistics to report. For example, -#' `statistic = list(age ~ "{mean} ({sd})")` would report the mean and -#' standard deviation for age; `statistic = list(all_continuous() ~ "{mean} ({sd})")` -#' would report the mean and standard deviation for all continuous variables. -#' A statistic name that appears between curly brackets -#' will be replaced with the numeric statistic (see [glue::glue]). -#' -#' For categorical variables the following statistics are available to display. -#' \itemize{ -#' \item `{n}` frequency -#' \item `{N}` denominator, or cohort size -#' \item `{p}` formatted percentage -#' } -#' For continuous variables the following statistics are available to display. -#' \itemize{ -#' \item `{median}` median -#' \item `{mean}` mean -#' \item `{sd}` standard deviation -#' \item `{var}` variance -#' \item `{min}` minimum -#' \item `{max}` maximum -#' \item `{sum}` sum -#' \item `{p##}` any integer percentile, where `##` is an integer from 0 to 100 -#' \item `{foo}` any function of the form `foo(x)` is accepted where `x` is a numeric vector -#' } -#' When the summary type is `"continuous2"`, pass a vector of statistics. Each element -#' of the vector will result in a separate row in the summary table. -#' -#' For both categorical and continuous variables, statistics on the number of -#' missing and non-missing observations and their proportions are available to -#' display. -#' \itemize{ -#' \item `{N_obs}` total number of observations -#' \item `{N_miss}` number of missing observations -#' \item `{N_nonmiss}` number of non-missing observations -#' \item `{p_miss}` percentage of observations missing -#' \item `{p_nonmiss}` percentage of observations not missing -#' } -#' -#' Note that for categorical variables, `{N_obs}`, `{N_miss}` and `{N_nonmiss}` refer -#' to the total number, number missing and number non missing observations -#' in the denominator, not at each level of the categorical variable. -#' +#' Title +#' +#' @param data TODO: +#' @param by TODO: +#' @param label TODO: +#' @param statistic TODO: +#' @param digits TODO: +#' @param type TODO: +#' @param value TODO: +#' @param missing TODO: +#' @param missing_text TODO: +#' @param missing_stat TODO: +#' @param sort TODO: +#' @param percent TODO: +#' @param include TODO: +#' +#' @return a gtsummary table of class `"tbl_summary"` #' @export -#' @return A `tbl_summary` object -#' @family tbl_summary tools -#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial -#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples -#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary -#' @author Daniel D. Sjoberg -#' @examples -#' \donttest{ -#' # Example 1 ---------------------------------- -#' tbl_summary_ex1 <- -#' trial %>% -#' select(age, grade, response) %>% -#' tbl_summary() #' -#' # Example 2 ---------------------------------- -#' tbl_summary_ex2 <- -#' trial %>% -#' select(age, grade, response, trt) %>% -#' tbl_summary( -#' by = trt, -#' label = list(age ~ "Patient Age"), -#' statistic = list(all_continuous() ~ "{mean} ({sd})"), -#' digits = list(age ~ c(0, 1)) -#' ) -#' -#' # Example 3 ---------------------------------- -#' # for convenience, you can also pass named lists to any arguments -#' # that accept formulas (e.g label, digits, etc.) -#' tbl_summary_ex3 <- -#' trial %>% -#' select(age, trt) %>% -#' tbl_summary( -#' by = trt, -#' label = list(age = "Patient Age") -#' ) -#' -#' # Example 4 ---------------------------------- -#' # multi-line summaries of continuous data with type 'continuous2' -#' tbl_summary_ex4 <- -#' trial %>% -#' select(age, marker) %>% +#' @examples +#' tbl <- #' tbl_summary( -#' type = all_continuous() ~ "continuous2", -#' statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), -#' missing = "no" +#' data = mtcars, +#' type = +#' list( +#' cyl = "categorical", +#' am = "dichotomous", +#' mpg = "continuous", +#' hp = "continuous2" +#' ), +#' value = list(am = 1), +#' statistic = +#' list( +#' c(cyl, am) ~ "{n} ({p}%)", +#' mpg = "{mean} ({sd})", +#' hp = c("{mean}", "{median}") +#' ) #' ) -#' } -#' @section Example Output: -#' \if{html}{Example 1} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "tbl_summary_ex1.png", width = "31")` -#' }} -#' -#' \if{html}{Example 2} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "tbl_summary_ex2.png", width = "45")` -#' }} -#' -#' \if{html}{Example 3} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "tbl_summary_ex3.png", width = "45")` -#' }} -#' -#' \if{html}{Example 4} -#' -#' \if{html}{\out{ -#' `r man_create_image_tag(file = "tbl_summary_ex4.png", width = "31")` -#' }} - tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, digits = NULL, type = NULL, value = NULL, - missing = NULL, missing_text = NULL, sort = NULL, - percent = NULL, include = everything()) { - # ungrouping data ------------------------------------------------------------ - data <- data %>% ungroup() - - # eval ----------------------------------------------------------------------- - by <- - .select_to_varnames( - select = {{ by }}, - data = data, - arg_name = "by", - select_single = TRUE - ) - include <- - .select_to_varnames( - select = {{ include }}, - data = data, - arg_name = "include" - ) %>% - union(by) # include by variable by default - - # setting defaults from gtsummary theme -------------------------------------- - label <- label %||% get_theme_element("tbl_summary-arg:label") - statistic <- statistic %||% get_theme_element("tbl_summary-arg:statistic") - digits <- digits %||% get_theme_element("tbl_summary-arg:digits") - type <- type %||% get_theme_element("tbl_summary-arg:type") - value <- value %||% get_theme_element("tbl_summary-arg:value") - missing <- - missing %||% - get_theme_element("tbl_summary-arg:missing", default = "ifany") - missing_text <- - missing_text %||% - get_theme_element("tbl_summary-arg:missing_text", - default = translate_text("Unknown") - ) - sort <- sort %||% get_theme_element("tbl_summary-arg:sort") - percent <- percent %||% get_theme_element("tbl_summary-arg:percent", - default = "column" + missing = c("ifany", "no", "always"), + missing_text = "Unknown", missing_stat = "{N_miss}", + sort = NULL, percent = c("column", "row", "cell"), + include = c(everything(), -by)) { + # process arguments ---------------------------------------------------------- + data <- dplyr::ungroup(data) + cards::process_selectors(data, by = {{by}}, include = {{include}}) + include <- setdiff(include, by) # remove by variable from list vars included + missing <- rlang::arg_match(arg = missing) + percent <- rlang::arg_match0(arg = percent) + + cards::process_formula_selectors( + data = data[include], + label = label, + statistic = statistic, + digits = digits, + type = type ) - # matching arguments --------------------------------------------------------- - missing <- match.arg(missing, choices = c("ifany", "always", "no")) - percent <- match.arg(percent, choices = c("column", "row", "cell")) - - # checking input data -------------------------------------------------------- - tbl_summary_data_checks(data) - - # deleting obs with missing by values ---------------------------------------- - # saving variable labels - if (!is.null(by) && sum(is.na(data[[by]])) > 0) { - message(glue( - "{sum(is.na(data[[by]]))} observations missing `{by}` have been removed. ", - "To include these observations, use `forcats::fct_na_value_to_level()` on `{by}` ", - "column before passing to `tbl_summary()`." - )) - - data <- filter(data, !is.na(.data[[by]])) - } - - # will return call, and all object passed to in tbl_summary call ------------- - # the object func_inputs is a list of every object passed to the function + # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) - # checking function inputs --------------------------------------------------- - tbl_summary_input_checks(data, by, missing_text, include) - - # generate meta_data -------------------------------------------------------- - meta_data <- generate_metadata( - data = data %>% select(all_of(include)), - value = value, by = by, - type = type, label = label, statistic = statistic, - digits = digits, percent = percent, sort = sort - ) - - # calculating summary statistics --------------------------------------------- - table_body <- - meta_data %>% - mutate( - tbl_stats = pmap( - list( - .data$summary_type, .data$variable, - .data$var_label, .data$stat_display, .data$df_stats - ), - function(summary_type, variable, var_label, stat_display, df_stats) { - df_stats_to_tbl( - data = data, variable = variable, summary_type = summary_type, by = by, - var_label = var_label, stat_display = stat_display, - df_stats = df_stats, missing = missing, missing_text = missing_text - ) - } + # construct cards ------------------------------------------------------------ + cards <- + cards::bind_ard( + cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), + # tabulate by variable for header stats + if (!rlang::is_empty(by)) cards::ard_categorical(data, variables = all_of(by)), + # tabulate categorical summaries + cards::ard_categorical( + data, + by = by, + variables = .get_variables_by_type(type, c("categorical", "dichotomous")) + ), + # calculate categorical summaries + cards::ard_continuous( + data, + by = by, + variables = .get_variables_by_type(type, c("continuous", "continuous2")) ) - ) %>% - select(var_type = "summary_type", "var_label", "tbl_stats") %>% - unnest("tbl_stats") %>% - select("variable", "var_type", "var_label", everything()) - - # table of column headers ---------------------------------------------------- - x <- - .create_gtsummary_object( - table_body = table_body, - meta_data = meta_data, - inputs = tbl_summary_inputs, - N = nrow(data), - call_list = list(tbl_summary = match.call()), - by = by, - df_by = df_by(data, by) ) - # adding "modify_stat_" information ------------------------------------------ - x$table_styling$header$modify_stat_N <- nrow(data) - if (!is.null(by)) { - x$table_styling$header <- - x$table_styling$header %>% - dplyr::left_join( - x$df_by %>% - select( - column = "by_col", - modify_stat_n = "n", - modify_stat_p = "p", - modify_stat_level = "by_chr" - ), - by = "column" - ) - } else { - x$table_styling$header <- - x$table_styling$header %>% - mutate( - modify_stat_n = .data$modify_stat_N, - modify_stat_p = .data$modify_stat_n / .data$modify_stat_N, - modify_stat_level = ifelse(.data$column %in% "stat_0", translate_text("Overall"), NA_character_) - ) - } - - # adding headers and footnote ------------------------------------------------ - x <- + # return object + list( + cards = cards, + calls = list(tbl_summary = tbl_summary_inputs) + ) |> + structure(class = c("tbl_summary", "gtsummary")) |> + construct_gtsummary() |> modify_table_styling( - x, - columns = all_stat_cols(), - footnote = footnote_stat_label(meta_data) - ) %>% - modify_header( - label = paste0("**", translate_text("Characteristic"), "**"), - all_stat_cols() ~ - ifelse(is.null(by), - get_theme_element("tbl_summary-str:header-noby", - default = "**N = {style_number(N)}**" - ), - get_theme_element("tbl_summary-str:header-withby", - default = "**{level}**, N = {style_number(n)}" - ) - ) + columns = "label", + rows = .data$row_type %in% c("level", "missing"), + text_format = "indent" ) - - # assign class and return final tbl ------------------------------------------ - class(x) <- c("tbl_summary", class(x)) - - # running any additional mods - x <- - get_theme_element("tbl_summary-fn:addnl-fn-to-run", default = identity) %>% - do.call(list(x)) - - x } - -# generate metadata table -------------------------------------------------------------- -# for survey objects pass the full survey object to `survey` argument, and `design$variables` to `data` argument -generate_metadata <- function(data, value, by, type, label, - statistic, digits, percent, sort, survey = NULL) { - # converting tidyselect formula lists to named lists ------------------------- - 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( - variable = names(data), - # assigning our best guess of the type, the final type is assigned below - # we make a guess first, so users may use the gtsummary tidyselect functions for type - summary_type = assign_summary_type( - data = data, variable = .data$variable, - summary_type = NULL, value = value - ) - ) - # excluding by variable - if (!is.null(by)) meta_data <- filter(meta_data, .data$variable != by) - - # updating type -------------------------------------------------------------- - # updating type of user supplied one - # converting tidyselect formula lists to named lists - type <- - .formula_list_to_named_list( - x = type, - data = data, - var_info = meta_data_to_var_info(meta_data), - arg_name = "type", - type_check = chuck(type_check, "is_string_summary_type", "fn"), - type_check_msg = chuck(type_check, "is_string_summary_type", "msg") - ) - - # updating meta data object with new types - meta_data <- - meta_data %>% - mutate( - summary_type = assign_summary_type( - data = data, variable = .data$variable, - summary_type = type, value = value, check_assignment = TRUE - ) - ) - - # converting tidyselect formula lists to named lists ------------------------- - label <- .formula_list_to_named_list( - x = label, - data = data, - var_info = meta_data_to_var_info(meta_data), - arg_name = "label", - type_check = chuck(type_check, "is_character", "fn"), - type_check_msg = chuck(type_check, "is_character", "msg") - ) - statistic <- .formula_list_to_named_list( - x = statistic, - data = data, - var_info = meta_data_to_var_info(meta_data), - arg_name = "statistic", - type_check = chuck(type_check, "is_character", "fn"), - type_check_msg = chuck(type_check, "is_character", "msg") - ) - digits <- .formula_list_to_named_list( - x = digits, - data = data, - var_info = meta_data_to_var_info(meta_data), - arg_name = "digits", - type_check = chuck(type_check, "digits", "fn"), - type_check_msg = chuck(type_check, "digits", "msg") - ) - sort <- .formula_list_to_named_list( - x = sort, - data = data, - var_info = meta_data_to_var_info(meta_data), - arg_name = "sort", - type_check = chuck(type_check, "is_string_summary_sort", "fn"), - type_check_msg = chuck(type_check, "is_string_summary_sort", "msg") - ) - - # assigning variable characteristics ----------------------------------------- - if (is.null(survey)) { - df_stats_function <- df_stats_fun - data_for_df_stats <- data - } else { - df_stats_function <- df_stats_fun_survey - data_for_df_stats <- survey - } - - meta_data <- - meta_data %>% - mutate( - dichotomous_value = assign_dichotomous_value(data, .data$variable, .data$summary_type, value), - var_label = assign_var_label(data, .data$variable, label), - stat_display = assign_stat_display(data, .data$variable, .data$summary_type, statistic), - stat_label = stat_label_match(.data$stat_display), - sort = assign_sort(.data$variable, .data$summary_type, sort), - df_stats = pmap( - list( - .data$summary_type, .data$variable, - .data$dichotomous_value, - .data$sort, .data$stat_display, .data$var_label - ), - ~ df_stats_function( - summary_type = ..1, variable = ..2, - dichotomous_value = ..3, - sort = ..4, stat_display = ..5, - data = data_for_df_stats, by = by, - percent = percent, digits = digits, - var_label = ..6 - ) - ) - ) - - meta_data +.get_variables_by_type <- function(x, type) { + names(x)[unlist(x) %in% type] } diff --git a/R/utils-as.R b/R/utils-as.R index 3655cbd69a..70017abd87 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -2,33 +2,33 @@ if (column %in% c("footnote", "footnote_abbrev")) { x$table_styling[[column]] <- x$table_header %>% - select(all_of(c("column", .env$column))) %>% + dplyr::select(all_of(c("column", .env$column))) %>% set_names(c("column", "footnote")) %>% - filter(!is.na(.data$footnote)) %>% - mutate( + dplyr::filter(!is.na(.data$footnote)) %>% + dplyr::mutate( rows = list(expr(NULL)), text_interpret = "gt::md" ) %>% - select(all_of(c("column", "rows", "text_interpret", "footnote"))) + dplyr::select(all_of(c("column", "rows", "text_interpret", "footnote"))) } else if (column %in% c("indent", "bold", "italic")) { x$table_styling$text_format <- x$table_header %>% - select(all_of(c("column", .env$column))) %>% - filter(!is.na(.data[[column]])) %>% + dplyr::select(all_of(c("column", .env$column))) %>% + dplyr::filter(!is.na(.data[[column]])) %>% set_names(c("column", "rows")) %>% - mutate( + dplyr::mutate( rows = map(.data$rows, ~ parse_expr(.x)), format_type = .env$column, undo_text_format = FALSE ) %>% - bind_rows(x$table_styling$text_format) + dplyr::bind_rows(x$table_styling$text_format) } else if (column %in% "missing_emdash") { x$table_styling[["fmt_missing"]] <- x$table_header %>% - select(all_of(c("column", .env$column))) %>% - filter(!is.na(.data[[column]])) %>% + dplyr::select(all_of(c("column", .env$column))) %>% + dplyr::filter(!is.na(.data[[column]])) %>% set_names(c("column", "rows")) %>% - mutate( + dplyr::mutate( rows = map(.data$rows, ~ parse_expr(.x)), symbol = get_theme_element("tbl_regression-str:ref_row_text", default = "\U2014" @@ -37,10 +37,10 @@ } else if (column %in% "fmt_fun") { x$table_styling[[column]] <- x$table_header %>% - select(all_of(c("column", .env$column))) %>% - filter(!map_lgl(.data[[column]], is.null)) %>% - mutate(rows = list(expr(NULL))) %>% - select(all_of(c("column", "rows", .env$column))) + dplyr::select(all_of(c("column", .env$column))) %>% + dplyr::filter(!map_lgl(.data[[column]], is.null)) %>% + dplyr::mutate(rows = list(expr(NULL))) %>% + dplyr::select(all_of(c("column", "rows", .env$column))) } # return gtsummary table @@ -59,8 +59,8 @@ .cols_to_show <- function(x) { x$table_styling$header %>% - filter(!.data$hide) %>% - pull("column") + dplyr::filter(!.data$hide) %>% + dplyr::pull("column") } @@ -89,9 +89,9 @@ # text_format ---------------------------------------------------------------- x$table_styling$text_format <- x$table_styling$text_format %>% - filter(.data$column %in% .cols_to_show(x)) %>% - rowwise() %>% - mutate( + dplyr::filter(.data$column %in% .cols_to_show(x)) %>% + dplyr::rowwise() %>% + dplyr::mutate( row_numbers = switch(nrow(.) == 0, integer(0) @@ -102,40 +102,40 @@ ) %>% list(), ) %>% - select(-"rows") %>% - unnest("row_numbers") %>% - group_by(.data$column, .data$row_numbers, .data$format_type) %>% - filter(row_number() == n()) %>% - filter(.data$undo_text_format == FALSE) %>% + dplyr::select(-"rows") %>% + tidyr::unnest("row_numbers") %>% + dplyr::group_by(.data$column, .data$row_numbers, .data$format_type) %>% + dplyr::filter(dplyr::row_number() == dplyr::n()) %>% + dplyr::filter(.data$undo_text_format == FALSE) %>% # dropping undoing cmds - group_by(.data$column, .data$format_type) %>% - nest(row_numbers = "row_numbers") %>% - mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) %>% - select("column", "row_numbers", everything()) %>% - ungroup() + dplyr::group_by(.data$column, .data$format_type) %>% + tidyr::nest(row_numbers = "row_numbers") %>% + dplyr::mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) %>% + dplyr::select("column", "row_numbers", everything()) %>% + dplyr::ungroup() # fmt_missing ---------------------------------------------------------------- x$table_styling$fmt_missing <- x$table_styling$fmt_missing %>% - filter(.data$column %in% .cols_to_show(x)) %>% - rowwise() %>% - mutate( + dplyr::filter(.data$column %in% .cols_to_show(x)) %>% + dplyr::rowwise() %>% + dplyr::mutate( row_numbers = switch(nrow(.) == 0, integer(0) ) %||% .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(), ) %>% - select(-"rows") %>% - unnest("row_numbers") %>% - group_by(.data$column, .data$row_numbers) %>% - filter(row_number() == n()) %>% - select("column", "row_numbers", "symbol") %>% - ungroup() %>% + dplyr::select(-"rows") %>% + tidyr::unnest("row_numbers") %>% + dplyr::group_by(.data$column, .data$row_numbers) %>% + dplyr::filter(dplyr::row_number() == dplyr::n()) %>% + dplyr::select("column", "row_numbers", "symbol") %>% + dplyr::ungroup() %>% tidyr::nest(row_numbers = "row_numbers") %>% - rowwise() %>% + dplyr::rowwise() %>% dplyr::mutate(row_numbers = unlist(.data$row_numbers) %>% unname() %>% list()) %>% - ungroup() + dplyr::ungroup() # footnote ------------------------------------------------------------------- x$table_styling$footnote <- @@ -149,8 +149,8 @@ x$table_styling$fmt_fun <- x$table_styling$fmt_fun %>% # filter(.data$column %in% .cols_to_show(x)) %>% - rowwise() %>% - mutate( + dplyr::rowwise() %>% + dplyr::mutate( row_numbers = switch(nrow(.) == 0, integer(0) @@ -159,21 +159,21 @@ return_when_null = seq_len(nrow(x$table_body)) ) %>% list() ) %>% - select(-"rows") %>% - unnest("row_numbers") %>% - group_by(.data$column, .data$row_numbers) %>% - filter(row_number() == n()) %>% - ungroup() %>% - nest(row_numbers = "row_numbers") %>% - mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) + dplyr::select(-"rows") %>% + tidyr::unnest("row_numbers") %>% + dplyr::group_by(.data$column, .data$row_numbers) %>% + dplyr::filter(dplyr::row_number() == dplyr::n()) %>% + dplyr::ungroup() %>% + tidyr::nest(row_numbers = "row_numbers") %>% + dplyr::mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) # cols_merge ----------------------------------------------------------------- x$table_styling$cols_merge <- x$table_styling$cols_merge %>% - group_by(.data$column) %>% - filter(dplyr::row_number() == dplyr::n(), !is.na(.data$pattern)) %>% - rowwise() %>% - mutate( + dplyr::group_by(.data$column) %>% + dplyr::filter(dplyr::row_number() == dplyr::n(), !is.na(.data$pattern)) %>% + dplyr::rowwise() %>% + dplyr::mutate( row_numbers = switch(nrow(.) == 0, integer(0) @@ -184,7 +184,7 @@ ) %>% list(), ) %>% - select(-"rows", rows = "row_numbers") + dplyr::select(-"rows", rows = "row_numbers") x } @@ -192,9 +192,9 @@ .table_styling_expr_to_row_number_footnote <- function(x, footnote_type) { df_clean <- x$table_styling[[footnote_type]] %>% - filter(.data$column %in% .cols_to_show(x)) + dplyr::filter(.data$column %in% .cols_to_show(x)) if (nrow(df_clean) == 0) { - return(tibble( + return(dplyr::tibble( column = character(0), tab_location = character(0), row_numbers = logical(0), text_interpret = character(0), footnote = character(0) )) @@ -202,8 +202,8 @@ df_clean <- df_clean %>% - rowwise() %>% - mutate( + dplyr::rowwise() %>% + dplyr::mutate( row_numbers = switch(nrow(.) == 0, integer(0) @@ -211,30 +211,30 @@ .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(), tab_location = ifelse(identical(.data$row_numbers, NA), "header", "body") ) %>% - select(-"rows") %>% - unnest(cols = "row_numbers") %>% - group_by(.data$column, .data$tab_location, .data$row_numbers) %>% - filter(row_number() == n()) %>% + dplyr::select(-"rows") %>% + tidyr::unnest(cols = "row_numbers") %>% + dplyr::group_by(.data$column, .data$tab_location, .data$row_numbers) %>% + dplyr::filter(dplyr::row_number() == dplyr::n()) %>% # keeping the most recent addition - filter(!is.na(.data$footnote)) # keep non-missing additions + dplyr::filter(!is.na(.data$footnote)) # keep non-missing additions if (footnote_type == "footnote_abbrev") { # order the footnotes by where they first appear in the table, df_clean <- df_clean %>% - inner_join( + dplyr::inner_join( x$table_styling$header %>% select("column") %>% - mutate(column_id = row_number()), + mutate(column_id = dplyr::row_number()), by = "column" ) %>% - arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% - ungroup() %>% - mutate(footnote = paste(unique(.data$footnote), collapse = ", ")) + dplyr::arrange(dplyr::desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% + dplyr::ungroup() %>% + dplyr::mutate(footnote = paste(unique(.data$footnote), collapse = ", ")) } df_clean %>% - select(all_of(c("column", "tab_location", "row_numbers", "text_interpret", "footnote"))) + dplyr::select(all_of(c("column", "tab_location", "row_numbers", "text_interpret", "footnote"))) } # this function orders the footnotes by where they first appear in the table, @@ -242,28 +242,28 @@ .number_footnotes <- function(x) { if (nrow(x$table_styling$footnote) == 0 && nrow(x$table_styling$footnote_abbrev) == 0) { - return(tibble( + return(dplyr::tibble( footnote_id = integer(), footnote = character(), column = character(), tab_location = character(), row_numbers = integer() )) } - bind_rows( + dplyr::bind_rows( x$table_styling$footnote, x$table_styling$footnote_abbrev ) %>% - inner_join( + dplyr::inner_join( x$table_styling$header %>% select("column") %>% - mutate(column_id = row_number()), + mutate(column_id = dplyr::row_number()), by = "column" ) %>% - arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% - group_by(.data$footnote) %>% - nest() %>% - ungroup() %>% - mutate(footnote_id = row_number()) %>% - unnest(cols = "data") %>% - select( + dplyr::arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% + dplyr::group_by(.data$footnote) %>% + tidyr::nest() %>% + dplyr::ungroup() %>% + dplyr::mutate(footnote_id = dplyr::row_number()) %>% + tidyr::unnest(cols = "data") %>% + dplyr::select( "footnote_id", "footnote", "column", "tab_location", "row_numbers" ) @@ -280,13 +280,13 @@ # replacing numeric columns with formatted/character,merged columns merging_columns <- x_cleaned$table_styling$cols_merge$column - df_merged <- as_tibble(x, include = c("tibble", "fmt", "cols_merge")) + df_merged <- dplyr::as_tibble(x, include = c("tibble", "fmt", "cols_merge")) x$table_body[merging_columns] <- df_merged[merging_columns] # removing merging instructions ---------------------------------------------- x$table_styling$cols_merge <- x$table_styling$cols_merge %>% - filter(FALSE) + dplyr::filter(FALSE) # replacing formatting functions for merged columns -------------------------- x <- modify_fmt_fun(x, update = inject(!!merging_columns ~ as.character)) @@ -301,7 +301,7 @@ exprs %>% # removing NULL elements unlist() %>% - compact() %>% + purrr::compact() %>% # concatenating expressions with %>% between each of them - reduce(function(x, y) rlang::inject(!!x %>% !!y, env = env)) + purrr::reduce(function(x, y) rlang::inject(!!x %>% !!y, env = env)) } diff --git a/R/utils-gtsummary.R b/R/utils-gtsummary.R new file mode 100644 index 0000000000..2db5069cd2 --- /dev/null +++ b/R/utils-gtsummary.R @@ -0,0 +1,32 @@ + +.extract_glue_elements <- function(x) { + regmatches(x, gregexpr("\\{([^\\}]*)\\}", x)) |> + unlist() %>% + {substr(., 2, nchar(.) - 1)} +} + +.ifelse1 <- function(test, yes, no) { + if (test) { + return(yes) + } + no +} + +.get_selecting_data_frame <- function(x) { + # if a tbl_summary-like table, grab data frame from inputs + if (tryCatch(x$calls[[1]]$data |> is.data.frame(), error = function(x) FALSE)) { + return(x$calls[[1]]$dataa) + } + + # TODO: add tbl_regression results often return the type of variable input, we could use that to construct a df with the approriate class? + + # if none of the above apply, return a data frame based on the variables listed + if ("variable" %in% names(x$table_body)) { + return( + dplyr::tibble(!!!rlang::rep_named(unique(x$table_body$variable), character())) + ) + } + + # lastly, we can get a variable list from the card data frame + dplyr::tibble(!!!rlang::rep_named(unique(x$cards$variable), character())) +} diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 11d2d8823b..539fce9dd2 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -1,27 +1,9 @@ -# THIS FILE CONTAINS A FEW SCRIPTS THAT ASSIST IN SETTING UP A GENERAL -# GTSUMMARY OBJECT. IF YOU'RE CREATING A GTSUMMARY-LIKE FUNCTION, YOU'LL -# WANT TO GRAB A COPY OF THIS FILE AND PLACE IT IN YOUR PACKAGE. - -# LAST UPDATED: 2020-12-19 - -# .create_gtsummary_object ----------------------------------------------------- -#' Function uses `table_body` to create a gtsummary object -#' -#' @param table_body the table_body tibble -#' @param ... other objects that will be added to the gtsummary object list -#' -#' @export -#' @keywords internal -#' @return gtsummary object -.create_gtsummary_object <- function(table_body, ...) { - x <- list() # empty gtsummary object - - # table_body ----------------------------------------------------------------- - x$table_body <- table_body +get_theme_element <- function(...) NULL +construct_initial_table_styling <- function(x) { # table_styling -------------------------------------------------------------- x$table_styling$header <- - tibble( + dplyr::tibble( column = names(x$table_body), hide = TRUE, align = "center", @@ -30,51 +12,76 @@ interpret_spanning_header = "gt::md", spanning_header = NA_character_ ) %>% - mutate( - hide = ifelse(.data$column == "label", FALSE, .data$hide), - align = ifelse(.data$column == "label", "left", .data$align) + dplyr::mutate( + hide = ifelse(.data$column %in% "label", FALSE, .data$hide), + align = ifelse(.data$column %in% "label", "left", .data$align) ) x$table_styling$footnote <- - tibble( + dplyr::tibble( column = character(), rows = list(), text_interpret = character(), footnote = character() ) x$table_styling$footnote_abbrev <- - tibble( + dplyr::tibble( column = character(), rows = list(), text_interpret = character(), footnote = character() ) x$table_styling$text_format <- - .purrr_when( - isTRUE(all(c("label", "row_type") %in% x$table_styling$header$column)) ~ - tibble( - column = "label", - rows = list(rlang::expr(.data$row_type %in% c("level", "missing"))), - format_type = "indent", undo_text_format = FALSE - ), - isFALSE(all(c("label", "row_type") %in% x$table_styling$header$column)) ~ - tibble( - column = character(), rows = list(), - format_type = character(), undo_text_format = logical() - ) + dplyr::tibble( + column = character(), rows = list(), + format_type = character(), undo_text_format = logical() ) + x$table_styling$indentation <- + if (all(c("label", "row_type") %in% x$table_styling$header$column)) { + dplyr::tibble( + column = c("label", "label"), + rows = list(rlang::expr(TRUE), rlang::expr(.data$row_type %in% c("level", "missing"))), + n_spaces = c(0L, 4L) + ) + } + else { + dplyr::tibble(column = character(), rows = list(), n_spaces = integer()) + } + x$table_styling$fmt_missing <- - tibble(column = character(), rows = list(), symbol = character()) + dplyr::tibble(column = character(), rows = list(), symbol = character()) x$table_styling$fmt_fun <- - tibble(column = character(), rows = list(), fmt_fun = list()) + dplyr::tibble(column = character(), rows = list(), fmt_fun = list()) x$table_styling$cols_merge <- - tibble(column = character(), rows = list(), pattern = character()) + dplyr::tibble(column = character(), rows = list(), pattern = character()) - # adding other objects to list ----------------------------------------------- - x <- c(x, list(...)) # returning gtsummary object ------------------------------------------------- - class(x) <- "gtsummary" x } + +.purrr_when <- function(...) { + lst_formulas <- rlang::dots_list(...) + + for (i in seq_len(length(lst_formulas))) { + if (isTRUE(eval_tidy(.f_lhs_as_quo(lst_formulas[[i]])))) { + return(eval_tidy(.f_rhs_as_quo(lst_formulas[[i]]))) + } + } + # if not matches, return NULL + NULL +} +.f_lhs_as_quo <- function(x) { + rlang::new_quosure( + expr = rlang::f_lhs(x), + env = attr(x, ".Environment") + ) +} +.f_rhs_as_quo <- function(x) { + rlang::new_quosure( + expr = rlang::f_rhs(x), + env = attr(x, ".Environment") + ) +} + # this fn updates `table_styling` list to match `table_body` .update_table_styling <- function(x) { # vector of columns deleted in update @@ -87,17 +94,17 @@ for (styling_element in names(x$table_styling)) { # if element is a tibble with a column called 'column' if (is.data.frame(x$table_styling[[styling_element]]) && - "column" %in% names(x$table_styling[[styling_element]])) { + "column" %in% names(x$table_styling[[styling_element]])) { x$table_styling[[styling_element]] <- x$table_styling[[styling_element]] %>% - filter(!.data$column %in% deleted_columns) + dplyr::filter(!.data$column %in% deleted_columns) } } } # update styling header table with new variables ----------------------------- x$table_styling$header <- - tibble( + dplyr::tibble( column = names(x$table_body), hide = TRUE, align = "center", @@ -118,37 +125,13 @@ x %>% # updating rows in header dplyr::rows_update( - y %>% select(all_of(common_columns)), + y %>% dplyr::select(all_of(common_columns)), by = "column" ) %>% # re-adding the columns not in the original header table dplyr::left_join( - y %>% select(-all_of(setdiff(common_columns, "column"))), + y %>% dplyr::select(-all_of(setdiff(common_columns, "column"))), by = "column" ) } - -.purrr_when <- function(...) { - lst_formulas <- rlang::dots_list(...) - - for (i in seq_len(length(lst_formulas))) { - if (isTRUE(eval_tidy(.f_lhs_as_quo(lst_formulas[[i]])))) { - return(eval_tidy(.f_rhs_as_quo(lst_formulas[[i]]))) - } - } - # if not matches, return NULL - NULL -} -.f_lhs_as_quo <- function(x) { - rlang::new_quosure( - expr = rlang::f_lhs(x), - env = attr(x, ".Environment") - ) -} -.f_rhs_as_quo <- function(x) { - rlang::new_quosure( - expr = rlang::f_rhs(x), - env = attr(x, ".Environment") - ) -} diff --git a/README.md b/README.md index f34f05f19e..26530ac63d 100644 --- a/README.md +++ b/README.md @@ -1,266 +1 @@ - - - - -[![R-CMD-check](https://github.com/ddsjoberg/gtsummary/workflows/R-CMD-check/badge.svg)](https://github.com/ddsjoberg/gtsummary/actions) -[![CRAN -status](https://www.r-pkg.org/badges/version/gtsummary)](https://cran.r-project.org/package=gtsummary) -[![Codecov test -coverage](https://codecov.io/gh/ddsjoberg/gtsummary/branch/main/graph/badge.svg)](https://app.codecov.io/gh/ddsjoberg/gtsummary?branch=main) -[![](https://cranlogs.r-pkg.org/badges/gtsummary)](https://cran.r-project.org/package=gtsummary) -[![DOI:10.32614/RJ-2021-053](https://zenodo.org/badge/DOI/10.32614/RJ-2021-053.svg)](https://doi.org/10.32614/RJ-2021-053) - - -## gtsummary - -The {gtsummary} package provides an elegant and flexible way to create -publication-ready analytical and summary tables using the **R** -programming language. The {gtsummary} package summarizes data sets, -regression models, and more, using sensible defaults with highly -customizable capabilities. - -- [**Summarize data frames or - tibbles**](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html) - easily in **R**. Perfect for presenting descriptive statistics, - comparing group **demographics** (e.g creating a **Table 1** for - medical journals), and more. Automatically detects continuous, - categorical, and dichotomous variables in your data set, calculates - appropriate descriptive statistics, and also includes amount of - missingness in each variable. - -- [**Summarize regression - models**](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) - in R and include reference rows for categorical variables. Common - regression models, such as logistic regression and Cox proportional - hazards regression, are automatically identified and the tables are - pre-filled with appropriate column headers (i.e. Odds Ratio and Hazard - Ratio). - -- [**Customize gtsummary - tables**](https://www.danieldsjoberg.com/gtsummary/reference/index.html#section-general-formatting-styling-functions) - using a growing list of formatting/styling functions. - **[Bold](https://www.danieldsjoberg.com/gtsummary/reference/bold_italicize_labels_levels.html)** - labels, - **[italicize](https://www.danieldsjoberg.com/gtsummary/reference/bold_italicize_labels_levels.html)** - levels, **[add - p-value](https://www.danieldsjoberg.com/gtsummary/reference/add_p.html)** - to summary tables, - **[style](https://www.danieldsjoberg.com/gtsummary/reference/style_percent.html)** - the statistics however you choose, - **[merge](https://www.danieldsjoberg.com/gtsummary/reference/tbl_merge.html)** - or - **[stack](https://www.danieldsjoberg.com/gtsummary/reference/tbl_stack.html)** - tables to present results side by side… there are so many - possibilities to create the table of your dreams! - -- **[Report statistics - inline](https://www.danieldsjoberg.com/gtsummary/articles/inline_text.html)** - from summary tables and regression summary tables in **R markdown**. - Make your reports completely reproducible! - -By leveraging [{broom}](https://broom.tidymodels.org/), -[{gt}](https://gt.rstudio.com/), and -[{labelled}](http://larmarange.github.io/labelled/) packages, -{gtsummary} creates beautifully formatted, ready-to-share summary and -result tables in a single line of R code! - -Check out the examples below, review the -[vignettes](https://www.danieldsjoberg.com/gtsummary/articles/) for a -detailed exploration of the output options, and view the -[gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html) -for various customization examples. - -## Installation - -The {gtsummary} package was written as a companion to the -[{gt}](https://gt.rstudio.com/) package from RStudio. You can install -{gtsummary} with the following code. - -``` r -install.packages("gtsummary") -``` - -Install the development version of {gtsummary} with: - -``` r -remotes::install_github("ddsjoberg/gtsummary") -``` - -## Examples - -### Summary Table - -Use -[`tbl_summary()`](https://www.danieldsjoberg.com/gtsummary/reference/tbl_summary.html) -to summarize a data frame. - -animated - -Example basic table: - -``` r -library(gtsummary) - -# summarize the data with our package -table1 <- - trial %>% - tbl_summary(include = c(age, grade, response)) -``` - - - -There are many **customization options** to **add information** (like -comparing groups) and **format results** (like bold labels) in your -table. See the -[`tbl_summary()`](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html) -tutorial for many more options, or below for one example. - -``` r -table2 <- - tbl_summary( - trial, - include = c(age, grade, response), - by = trt, # split table by group - missing = "no" # don't list missing data separately - ) %>% - add_n() %>% # add column with total number of non-missing observations - add_p() %>% # test for a difference between groups - modify_header(label = "**Variable**") %>% # update the column header - bold_labels() -``` - - - -### Regression Models - -Use -[`tbl_regression()`](https://www.danieldsjoberg.com/gtsummary/reference/tbl_regression.html) -to easily and beautifully display regression model results in a table. -See the -[tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) -for customization options. - -``` r -mod1 <- glm(response ~ trt + age + grade, trial, family = binomial) - -t1 <- tbl_regression(mod1, exponentiate = TRUE) -``` - - - -### Side-by-side Regression Models - -You can also present side-by-side regression model results using -`tbl_merge()` - -``` r -library(survival) - -# build survival model table -t2 <- - coxph(Surv(ttdeath, death) ~ trt + grade + age, trial) %>% - tbl_regression(exponentiate = TRUE) - -# merge tables -tbl_merge_ex1 <- - tbl_merge( - tbls = list(t1, t2), - tab_spanner = c("**Tumor Response**", "**Time to Death**") - ) -``` - - - -Review even more output options in the **[table -gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html)**. - -## gtsummary + R Markdown - -The **{gtsummary}** package was written to be a companion to the -**{gt}** package from RStudio. But not all output types are supported by -the **{gt}** package. Therefore, we have made it possible to print -**{gtsummary}** tables with various engines. - -Review the **[gtsummary + R -Markdown](https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html)** -vignette for details. - - - - -## Save Individual Tables - -{gtsummary} tables can also be saved directly to file as an image, HTML, -Word, RTF, and LaTeX file. - -``` r -tbl %>% - as_gt() %>% - gt::gtsave(filename = ".") # use extensions .png, .html, .docx, .rtf, .tex, .ltx -``` - -## Additional Resources - -- The best resources are the gtsummary vignettes: [table - gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html), - [`tbl_summary()` - tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html), - [`tbl_regression()` - tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html), - [`inline_text()` - tutorial](https://www.danieldsjoberg.com/gtsummary/articles/inline_text.html), - [gtsummary - themes](https://www.danieldsjoberg.com/gtsummary/articles/themes.html), - [gtsummary+R - markdown](https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html). - -- The R Journal Article [*Reproducible Summary Tables with the gtsummary - Package*](https://github.com/ddsjoberg/gtsummary/raw/main/data-raw/RJ-2021-053.pdf). - -- The [RStudio Education - Blog](https://education.rstudio.com/blog/2020/07/gtsummary/) includes - a post with a brief introduction to the package. - -- A [recording of a - presentation](https://www.youtube.com/watch?v=tANo9E1SYJE) given to - the Weill Cornell Biostatistics Department and the Memorial Sloan - Kettering R Users Group. - - - -## Cite gtsummary - -``` text -> citation("gtsummary") - -To cite gtsummary in publications use: - - Sjoberg DD, Whiting K, Curry M, Lavery JA, Larmarange J. Reproducible summary tables with the gtsummary package. - The R Journal 2021;13:570–80. https://doi.org/10.32614/RJ-2021-053. - -A BibTeX entry for LaTeX users is - - @Article{gtsummary, - author = {Daniel D. Sjoberg and Karissa Whiting and Michael Curry and Jessica A. Lavery and Joseph Larmarange}, - title = {Reproducible Summary Tables with the gtsummary Package}, - journal = {{The R Journal}}, - year = {2021}, - url = {https://doi.org/10.32614/RJ-2021-053}, - doi = {10.32614/RJ-2021-053}, - volume = {13}, - issue = {1}, - pages = {570-580}, - } -``` - -## Contributing - -Big thank you to -[@jeffreybears](https://www.etsy.com/shop/jeffreybears/) for the hex -sticker! - -Please note that the {gtsummary} project is released with a [Contributor -Code of -Conduct](https://www.danieldsjoberg.com/gtsummary/CODE_OF_CONDUCT.html). -By contributing to this project, you agree to abide by its terms. Thank -you to all contributors! +# gts2 \ No newline at end of file diff --git a/CITATION.cff b/_archive/CITATION.cff similarity index 100% rename from CITATION.cff rename to _archive/CITATION.cff diff --git a/_archive/DESCRIPTION b/_archive/DESCRIPTION new file mode 100644 index 0000000000..8515c29a4c --- /dev/null +++ b/_archive/DESCRIPTION @@ -0,0 +1,137 @@ +Package: gtsummary +Title: Presentation-Ready Data Summary and Analytic Result + Tables +Version: 1.7.2.9001 +Authors@R: + c(person(given = "Daniel D.", + family = "Sjoberg", + role = c("aut", "cre"), + email = "danield.sjoberg@gmail.com", + comment = c(ORCID = "0000-0003-0862-2018")), + person(given = "Joseph", + family = "Larmarange", + role = "aut", + comment = c(ORCID = "0000-0001-7097-700X")), + person(given = "Michael", + family = "Curry", + role = "aut", + comment = c(ORCID = "0000-0002-0261-4044")), + person(given = "Jessica", + family = "Lavery", + role = "aut", + comment = c(ORCID = "0000-0002-2746-5647")), + person(given = "Karissa", + family = "Whiting", + role = "aut", + comment = c(ORCID = "0000-0002-4683-1868")), + person(given = "Emily C.", + family = "Zabor", + role = "aut", + comment = c(ORCID = "0000-0002-1402-4498")), + person(given = "Xing", + family = "Bai", + role = "ctb"), + person(given = "Esther", + family = "Drill", + role = "ctb", + comment = c(ORCID = "0000-0002-3315-4538")), + person(given = "Jessica", + family = "Flynn", + role = "ctb", + comment = c(ORCID = "0000-0001-8310-6684")), + person(given = "Margie", + family = "Hannum", + role = "ctb", + comment = c(ORCID = "0000-0002-2953-0449")), + person(given = "Stephanie", + family = "Lobaugh", + role = "ctb"), + person(given = "Shannon", + family = "Pileggi", + role = "ctb", + comment = c(ORCID = "0000-0002-7732-4164")), + person(given = "Amy", + family = "Tin", + role = "ctb", + comment = c(ORCID = "0000-0002-8005-0694")), + person(given = "Gustavo", + family = "Zapata Wainberg", + role = "ctb", + comment = c(ORCID = "0000-0002-2524-3637"))) +Description: Creates presentation-ready tables summarizing data + sets, regression models, and more. The code to create the tables is + concise and highly customizable. Data frames can be summarized with + any function, e.g. mean(), median(), even user-written functions. + Regression models are summarized and include the reference rows for + categorical variables. Common regression models, such as logistic + regression and Cox proportional hazards regression, are automatically + identified and the tables are pre-filled with appropriate column + headers. +License: MIT + file LICENSE +URL: https://github.com/ddsjoberg/gtsummary, + https://www.danieldsjoberg.com/gtsummary/ +BugReports: https://github.com/ddsjoberg/gtsummary/issues +Depends: + R (>= 3.4) +Imports: + broom (>= 1.0.1), + broom.helpers (>= 1.14.0), + cli (>= 3.1.1), + dplyr (>= 1.1.1), + forcats (>= 1.0.0), + glue (>= 1.6.2), + gt (>= 0.10.0), + knitr (>= 1.37), + lifecycle (>= 1.0.1), + purrr (>= 1.0.1), + rlang (>= 1.0.3), + stringr (>= 1.4.0), + tibble (>= 3.2.1), + tidyr (>= 1.1.4), + vctrs (>= 0.5.2) +Suggests: + aod (>= 1.3.1), + broom.mixed (>= 0.2.9), + car (>= 3.0-11), + cmprsk, + covr, + effectsize (>= 0.6.0), + emmeans (>= 1.7.3), + flextable (>= 0.8.1), + geepack, + ggstats (>= 0.2.1), + Hmisc, + huxtable (>= 5.4.0), + insight (>= 0.15.0), + kableExtra (>= 1.3.4), + lme4, + mgcv, + mice (>= 3.10.0), + nnet, + officer, + openxlsx, + parameters (>= 0.20.2), + parsnip (>= 0.1.7), + rmarkdown, + sandwich (>= 3.0.1), + scales, + smd (>= 0.6.6), + spelling (>= 2.2), + survey, + survival (>= 3.2-11), + testthat (>= 3.0.4), + tidycmprsk (>= 0.1.2), + workflows (>= 0.2.4) +VignetteBuilder: + knitr +RdMacros: + lifecycle +Encoding: UTF-8 +Language: en-US +LazyData: true +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.2.3 +Config/testthat/edition: 3 +Config/testthat/parallel: true +Config/Needs/website: + lubridate diff --git a/_archive/LICENSE b/_archive/LICENSE new file mode 100644 index 0000000000..ad805f4916 --- /dev/null +++ b/_archive/LICENSE @@ -0,0 +1,2 @@ +YEAR: 2020 +COPYRIGHT HOLDER: Daniel D. Sjoberg diff --git a/_archive/LICENSE.md b/_archive/LICENSE.md new file mode 100644 index 0000000000..f61a44ea48 --- /dev/null +++ b/_archive/LICENSE.md @@ -0,0 +1,21 @@ +# MIT License + +Copyright (c) 2020 Daniel D. Sjoberg + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/_archive/NAMESPACE b/_archive/NAMESPACE new file mode 100644 index 0000000000..3185d1bb62 --- /dev/null +++ b/_archive/NAMESPACE @@ -0,0 +1,318 @@ +# Generated by roxygen2: do not edit by hand + +S3method(add_ci,tbl_summary) +S3method(add_ci,tbl_svysummary) +S3method(add_global_p,tbl_regression) +S3method(add_global_p,tbl_uvregression) +S3method(add_n,tbl_regression) +S3method(add_n,tbl_summary) +S3method(add_n,tbl_survfit) +S3method(add_n,tbl_svysummary) +S3method(add_n,tbl_uvregression) +S3method(add_nevent,tbl_regression) +S3method(add_nevent,tbl_survfit) +S3method(add_nevent,tbl_uvregression) +S3method(add_overall,tbl_continuous) +S3method(add_overall,tbl_custom_summary) +S3method(add_overall,tbl_summary) +S3method(add_overall,tbl_svysummary) +S3method(add_p,tbl_continuous) +S3method(add_p,tbl_cross) +S3method(add_p,tbl_summary) +S3method(add_p,tbl_survfit) +S3method(add_p,tbl_svysummary) +S3method(as.data.frame,gtsummary) +S3method(as_tibble,gtsummary) +S3method(bold_labels,gtsummary) +S3method(bold_labels,tbl_cross) +S3method(bold_levels,gtsummary) +S3method(bold_levels,tbl_cross) +S3method(inline_text,gtsummary) +S3method(inline_text,tbl_cross) +S3method(inline_text,tbl_regression) +S3method(inline_text,tbl_summary) +S3method(inline_text,tbl_survfit) +S3method(inline_text,tbl_survival) +S3method(inline_text,tbl_svysummary) +S3method(inline_text,tbl_uvregression) +S3method(italicize_labels,gtsummary) +S3method(italicize_labels,tbl_cross) +S3method(italicize_levels,gtsummary) +S3method(italicize_levels,tbl_cross) +S3method(knit_print,gtsummary) +S3method(plot,tbl_regression) +S3method(plot,tbl_uvregression) +S3method(print,gtsummary) +S3method(print,tbl_split) +S3method(tbl_regression,brmsfit) +S3method(tbl_regression,crr) +S3method(tbl_regression,default) +S3method(tbl_regression,gam) +S3method(tbl_regression,glmerMod) +S3method(tbl_regression,glmmTMB) +S3method(tbl_regression,glmmadmb) +S3method(tbl_regression,lmerMod) +S3method(tbl_regression,mipo) +S3method(tbl_regression,mira) +S3method(tbl_regression,model_fit) +S3method(tbl_regression,multinom) +S3method(tbl_regression,stanreg) +S3method(tbl_regression,survreg) +S3method(tbl_regression,tidycrr) +S3method(tbl_regression,workflow) +S3method(tbl_split,gtsummary) +S3method(tbl_survfit,data.frame) +S3method(tbl_survfit,list) +S3method(tbl_survfit,survfit) +export("%>%") +export(.create_gtsummary_object) +export(.escape_html) +export(.escape_latex) +export(.escape_latex2) +export(.table_styling_expr_to_row_number) +export(add_ci) +export(add_difference) +export(add_glance_source_note) +export(add_glance_table) +export(add_global_p) +export(add_n) +export(add_nevent) +export(add_overall) +export(add_p) +export(add_q) +export(add_significance_stars) +export(add_stat) +export(add_stat_label) +export(add_vif) +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) +export(all_stat_cols) +export(all_tests) +export(any_of) +export(as_flex_table) +export(as_flextable) +export(as_gt) +export(as_hux_table) +export(as_hux_xlsx) +export(as_kable) +export(as_kable_extra) +export(as_tibble) +export(bold_labels) +export(bold_levels) +export(bold_p) +export(check_gtsummary_theme) +export(combine_terms) +export(contains) +export(continuous_summary) +export(ends_with) +export(everything) +export(filter_p) +export(get_gtsummary_theme) +export(inline_text) +export(italicize_labels) +export(italicize_levels) +export(knit_print) +export(last_col) +export(matches) +export(modify_caption) +export(modify_cols_merge) +export(modify_column_alignment) +export(modify_column_hide) +export(modify_column_indent) +export(modify_column_merge) +export(modify_column_unhide) +export(modify_fmt_fun) +export(modify_footnote) +export(modify_header) +export(modify_spanning_header) +export(modify_table_body) +export(modify_table_header) +export(modify_table_styling) +export(mutate) +export(num_range) +export(one_of) +export(pool_and_tidy_mice) +export(proportion_summary) +export(ratio_summary) +export(remove_row_type) +export(reset_gtsummary_theme) +export(select) +export(separate_p_footnotes) +export(set_gtsummary_theme) +export(show_header_names) +export(sort_p) +export(starts_with) +export(style_number) +export(style_percent) +export(style_pvalue) +export(style_ratio) +export(style_sigfig) +export(tbl_butcher) +export(tbl_continuous) +export(tbl_cross) +export(tbl_custom_summary) +export(tbl_merge) +export(tbl_regression) +export(tbl_split) +export(tbl_stack) +export(tbl_strata) +export(tbl_strata2) +export(tbl_summary) +export(tbl_survfit) +export(tbl_survival) +export(tbl_svysummary) +export(tbl_uvregression) +export(theme_gtsummary_compact) +export(theme_gtsummary_continuous2) +export(theme_gtsummary_eda) +export(theme_gtsummary_journal) +export(theme_gtsummary_language) +export(theme_gtsummary_mean_sd) +export(theme_gtsummary_printer) +export(tidy_bootstrap) +export(tidy_gam) +export(tidy_robust) +export(tidy_standardize) +export(tidy_wald_test) +export(vars) +export(with_gtsummary_theme) +importFrom(broom.helpers,.formula_list_to_named_list) +importFrom(broom.helpers,.generic_selector) +importFrom(broom.helpers,.select_to_varnames) +importFrom(cli,cli_alert_danger) +importFrom(cli,cli_alert_info) +importFrom(cli,cli_code) +importFrom(cli,cli_ul) +importFrom(dplyr,"%>%") +importFrom(dplyr,all_of) +importFrom(dplyr,any_of) +importFrom(dplyr,arrange) +importFrom(dplyr,bind_cols) +importFrom(dplyr,bind_rows) +importFrom(dplyr,case_when) +importFrom(dplyr,coalesce) +importFrom(dplyr,contains) +importFrom(dplyr,count) +importFrom(dplyr,desc) +importFrom(dplyr,distinct) +importFrom(dplyr,ends_with) +importFrom(dplyr,everything) +importFrom(dplyr,filter) +importFrom(dplyr,full_join) +importFrom(dplyr,group_by) +importFrom(dplyr,if_else) +importFrom(dplyr,inner_join) +importFrom(dplyr,last_col) +importFrom(dplyr,left_join) +importFrom(dplyr,matches) +importFrom(dplyr,mutate) +importFrom(dplyr,mutate_all) +importFrom(dplyr,mutate_at) +importFrom(dplyr,n) +importFrom(dplyr,num_range) +importFrom(dplyr,one_of) +importFrom(dplyr,pull) +importFrom(dplyr,rename) +importFrom(dplyr,rename_at) +importFrom(dplyr,row_number) +importFrom(dplyr,rowwise) +importFrom(dplyr,select) +importFrom(dplyr,slice) +importFrom(dplyr,starts_with) +importFrom(dplyr,ungroup) +importFrom(dplyr,vars) +importFrom(glue,as_glue) +importFrom(glue,glue) +importFrom(glue,glue_collapse) +importFrom(gt,html) +importFrom(gt,md) +importFrom(knitr,knit_print) +importFrom(lifecycle,deprecate_soft) +importFrom(purrr,chuck) +importFrom(purrr,compact) +importFrom(purrr,cross_df) +importFrom(purrr,discard) +importFrom(purrr,every) +importFrom(purrr,flatten) +importFrom(purrr,imap) +importFrom(purrr,imap_dfr) +importFrom(purrr,imap_lgl) +importFrom(purrr,keep) +importFrom(purrr,map) +importFrom(purrr,map2) +importFrom(purrr,map2_chr) +importFrom(purrr,map_chr) +importFrom(purrr,map_dbl) +importFrom(purrr,map_dfr) +importFrom(purrr,map_if) +importFrom(purrr,map_lgl) +importFrom(purrr,negate) +importFrom(purrr,partial) +importFrom(purrr,pluck) +importFrom(purrr,pmap) +importFrom(purrr,pmap_chr) +importFrom(purrr,pmap_dbl) +importFrom(purrr,pmap_lgl) +importFrom(purrr,reduce) +importFrom(purrr,some) +importFrom(rlang,"%||%") +importFrom(rlang,":=") +importFrom(rlang,.data) +importFrom(rlang,.env) +importFrom(rlang,abort) +importFrom(rlang,call2) +importFrom(rlang,check_dots_empty) +importFrom(rlang,enexpr) +importFrom(rlang,enquo) +importFrom(rlang,eval_tidy) +importFrom(rlang,expr) +importFrom(rlang,exprs) +importFrom(rlang,inform) +importFrom(rlang,inject) +importFrom(rlang,is_character) +importFrom(rlang,is_empty) +importFrom(rlang,is_function) +importFrom(rlang,is_list) +importFrom(rlang,is_named) +importFrom(rlang,is_string) +importFrom(rlang,parse_expr) +importFrom(rlang,quo_is_null) +importFrom(rlang,quo_text) +importFrom(rlang,set_names) +importFrom(rlang,sym) +importFrom(rlang,syms) +importFrom(stats,as.formula) +importFrom(stats,weights) +importFrom(stringr,fixed) +importFrom(stringr,str_detect) +importFrom(stringr,str_extract_all) +importFrom(stringr,str_locate) +importFrom(stringr,str_remove) +importFrom(stringr,str_remove_all) +importFrom(stringr,str_replace_all) +importFrom(stringr,str_split) +importFrom(stringr,str_starts) +importFrom(stringr,str_sub) +importFrom(stringr,str_wrap) +importFrom(stringr,word) +importFrom(tibble,as_tibble) +importFrom(tibble,deframe) +importFrom(tibble,enframe) +importFrom(tibble,tibble) +importFrom(tibble,tribble) +importFrom(tidyr,complete) +importFrom(tidyr,nest) +importFrom(tidyr,spread) +importFrom(tidyr,unnest) diff --git a/_archive/NEWS.md b/_archive/NEWS.md new file mode 100644 index 0000000000..81ccd0c0f5 --- /dev/null +++ b/_archive/NEWS.md @@ -0,0 +1,1218 @@ +# gtsummary (development version) + +* Fix in `add_difference()` for pair t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) + +# gtsummary 1.7.2 + +* Removed messaging about the former auto-removal of the `tbl_summary(group)` variable from the table: a change that occurred 3+ years ago in gtsummary v1.3.1 + +* Fix in `as_flex_table()` where source notes were not accurately rendered. (#1520) + +* Fix in column order when `add_ci()` is run after `add_overall(last=TRUE)`. Previously, the overall columns were placed in front. (#1525) + +* Line breaks (i.e. `\n`) are now removed from column headers and table cells when `as_kable()` is called. (#1526) + +* Fix in `as_gt()` where columns with common spanning headers were gathered. Corrected with `gt::tab_spanner(gather = FALSE)`. (#1527) + +* Fix in `remove_row_type()` where header rows for `continuous2` type variables was not removed when requested. (#1507) + +* Fix where some default `add_p.tbl_summary()` categorical tests were chi-squared when it should have been Fisher's exact test. This misclassification occurred in some cases when there was a large differential in the missing pattern for one of the variables in the cross table. (#1513) + +* Fix in `add_overall(col_label=)` where specified label was not always placed. (#1505) + +# gtsummary 1.7.1 + +### New Functions + +* Added `as.data.frame()` S3 method for gtsummary class. + +### New Functionality + +* The `tbl_svysummary()` function may now report the design effect, e.g. `tbl_svysummary(statistic = ~"{deff}")`. (#1486) + +* Added French translations for new marginal effects tidiers housed in {broom.helpers}. (#1417) + +* Added theme elements to control the default headers in `tbl_svysummary()`. (#1452) + +* Improved error messaging in `tbl_uvregression()` when `method=` argument is not correctly specified. (#1469) + +* Updates to account for changes in {forcats} v1.0.0 and {dplyr} v1.1.0. + +* `tbl_svysummary()` can now report design effects (#1486) + +### Bug Fixes + +* Fix in the footnote of `add_overall()` when run after `tbl_continuous()`. (#1436) + +* Updating the levels of precision used in `round2()`, which is used in the background for every rounded/formatted number in a gtsummary table. (#1494) + +* Bug fix when a subset of CIs are requested in `add_ci(include=)`. (#1484) + +* Update in `as_hux_table()` to ensure the Ns in header are not incorrectly auto-formatted by {huxtable}. + +* Fix in the `style_*()` family of functions. The attributes of the input vector--excluding the class--are retained. (#1460) + +* Updated `style_ratio()` to now format negative values. + +* Bug fix in `add_ci.tbl_svysummary()` for dichotomous variables. + +* `add_ci.tbl_svysummary()` now takes properly into account the `percent` argument (#1470) + +# gtsummary 1.7.0 + +### Breaking Changes + +* Updated the default argument values in `tidy_robust(vcov=NULL, vcov_args=NULL)`. Users must specify the type of robust standard errors using these arguments. + +* Fully removed deprecated items that were originally deprecated in v1.2.5 (released 3 years ago). + - `add_p(exclude=)`, `as_gt(exclude=)`, `as_kable(exclude=)`, `as_tibble.gtsummary(exclude=)`, `tbl_regression(exclude=)`, `tbl_uvregression(exclude=)` + - `tbl_summary_()`,`add_p_()` + - `add_global_p(terms=)` + +### New Functions + +* New function `add_ci.tbl_svysummary()` for adding confidence intervals to `tbl_svysummary()` summary statistics. (#965) + +### New Functionality + +* Arguments pass via the dots in `tbl_uvregression(...)` are now passed to `broom.helpers::tidy_plus_plus(...)`. (#1396) + +* Added new theme elements to control the default headers in `tbl_summary()`. (#1401) + +* All examples that previously used `
` for line breaks in gt tables have been updated to use ` \n`. Additionally, the `"qjecon"` journal theme has been updated to use the updated line breaker as well. (#1311) + +* Now allowing for mixed-class numeric types in `tbl_summary()`, such that `inline_text()` will not throw an error when the pattern argument is specified. + +* Added `stats::mood.test()` to `add_p.tbl_summary()`. (#1397) + +### New Documentation + +* Added a new article illustrating how to place gtsummary tables into Shiny applications. (#1335) + +### Bug Fixes + +* Updated Lancet journal theme to report p-values with more precision, per the journal's reporting guidelines. (#1442) + +* Fix for `as_flex_table()` when the header is blank. (#1406) + +* Fix in `tbl_summary()` that now allows for column vectors to be named within a data frame. (#1403) + +# gtsummary 1.6.3 + +* The `as_flex_table()` function now recognizes markdown bold (`**`) and italic (`_`) syntax in the headers and spanning headers. Restrictions apply. See help file for details. Users can no longer place sets of double stars and underscores *without* the text being formatted as markdown syntax. (#1361) + +* The `modify_caption()` function now works with tables created with `gtreg::tbl_listing()` that do not contain a column named `"label"`. (#1358) + +* Functions `tbl_summary()` and `tbl_svysummary()` now support `"{n}"`, `"{p}"`, and `"{level}"` when no `by=` variable is present for use in functions like `modify_header()`. For example, the following previously invalid code works well for both the overall column and the stratified columns: + + ```r + trial %>% + tbl_summary(by = trt) %>% + add_overall() %>% + modify_header(all_stat_cols() ~ "**{level}**, N = {n}") + ``` + + For the survey summary, the unweighted variants are also available. (#1366) + +* Added experimental feature where additional arguments can be passed to `broom.helpers::tidy_plus_plus()` via `tbl_regression(...)`. (#1383) + +* Updated the arguments in `tidy_robust()` to account for updates in {parameters}. (#1376) + +* Allowing for 'survfit' objects of class `survfit2` in `add_nevent.tbl_survfit()`. (#1389) + +* Added `oneway.test()` test to `add_p()`. (#1382) + +* Now using {ggstats} to plot regression model coefficients via `plot()` instead of {GGally}. (#1367) + +* Bug fix in `tbl_custom_summary()`: the full dataset (including missing observations) is now properly passed as `full_data` (#1388) + +# gtsummary 1.6.2 + +* The following updates were made to the indentation implementation for gt output: + - Previously, only HTML output was able to indent for gt tables, and this was implemented via `gt::tab_style()`. + - Indentation is now available for HTML, PDF, and Word and is implemented by adding unicode non-breaking spaces to the data frame via `gt::text_transform()`. + - The "names" for the indentation calls have been updated to `"indent"` and `"indent2"`. This change should affect very very few users. If you're not sure what the names refer to, then this does not affect you. + - Indentation for RTF does not currently work. Instead of indented columns, irregular unicode characters are shown. This issue will be addressed in a future gt release. If you do use RTF output, and would like your output to be identical to what it was before this update, use `as_gt(include = -indent)`. + +* A link to the cheat sheet has been added to the website's navigation bar. + +* Added additional options to `remove_row_type(type = c("level", "all"))`. + - Use `type = "all"` to remove all rows associated with the variable(s) specified in `remove_row_type(variables=)`. + - Use `type = "level"` in conjunction with new argument `level_values=` to remove specified levels for a variable, or do not use the new argument to remove all levels for categorical variables. + +* Added the standard error of means to the list of available statistics for continuous data summaries in `tbl_svysummary()`. (#1291) + +* Added Dutch language translations. (#1302) + +* Updated `add_significance_stars()` to accept any gtsummary table (instead of only regression model summaries) and to work with `add_global_p()` (#1320) + +* Added the `"var_type"` hidden column to the output of `tbl_survfit()`. This addition ensures the table will work with `remove_row_type()`. (#1343) + +* Updated calls to `round()` in the `style_*()` functions to `round2()`, which implements classic rounding rules. (#1304) + +* Fixed bug in `style_sigfig()` with numbers close to the thresholds. (#1298) + +* Fixed bug when a column named `"variable"` was passed to `tbl_custom_summary(by=)`, which resulted in an error. (#1285) + +* Bug fix in `as_tibble(fmt_missing = TRUE)`. Previously, missing assignments applied to more than one row were being ignored. (#1327) + +* Bug fix in column alignment with `tbl_stack()` for `as_kable_extra()` output. (#1326) + +# gtsummary 1.6.1 + +### New Functionality + +* Added the standard error of proportions to the list of available statistics for categorical data summaries in `tbl_svysummary()`. (#1187) + +* Added Tarone-Ware test to `add_p.tbl_survfit()` (#732) + +* Updated `add_global_p()` to handle `tbl_uvregression()` objects where users specified the `x=` argument (when `y=` argument is more common). (#1260) + +### Other Updates + +* Updated start-up messaging. (#1228) + +* The `paired.wilcox.test` available in `add_p.tbl_summary()` and `add_difference.tbl_summary()` was mistakenly marked as returning a difference, but it does not. The documentation has been corrected, which results in improved messaging to the user when the test is selected in `add_difference()`. (#1279) + +* Improved error messages for paired tests in `add_p()` and `add_difference()` when `group=` argument is not specified. (#1273) + +* Added argument `with_gtsummary_theme(msg_ignored_elements=)` argument. Use this argument to message users if any theme elements will be overwritten and therefore ignored inside the `with_gtsummary_theme()` call. (#1266) + +* Swapped `gt::fmt_missing()` for `gt::sub_missing()` as the former is now deprecated. (#1257) + +* The checks for `"haven_labelled"` class are now only performed for the variables indicated in `include=` and `by=` in `tbl_summary()` and `tbl_svysummary()`. The checks in `tbl_uvregression()` and `tbl_survfit.data.frame()` are only applied to the variables in `include=`, e.g. no checking for the outcome variable(s). + +* Updates to labels and default formatting functions of unweighted statistics presented in `tbl_svysummary()`. (#1253) + +* Adding additional structural checks in `tbl_merge()` and `inline_text()` to provide better error messaging. (#1248) + +* Added `tbl_regression.crr()` method with messaging recommending use of `tidycmprsk::crr()` instead. (#1237) + +* The experimental support for `ftExtra::colformat_md()` in `as_flex_table()` has been removed. The function requires evaluated YAML paths and does not allow un-evaluated references like ``bibliography:: "`r here::here()`"``. (#1229) + +* Update for `tbl_summary(by=)` that now allows for a column named `"variable"` to be passed. (#1234) + +* Added theme element to control what missing statistic is shown in summary tables with options to display number or percent missing or non-missing or total number of observations. (#1224) + +* Renamed `modify_cols_merge()` to `modify_column_merge()` to be inline with the other `modify_column_*()` functions. + +### Bug Fixes + +* Fix in `as_kable_extra()` when output format is `'latex'` where a cell that had been bold or italicized had special characters double-escaped. Added a condition not to escape special characters in these styled cells. (#1230) + +* Fix in `with_gtsummary_theme()`. The function restored any previously set theme, but inadvertently included the temporary theme along with it. + +# gtsummary 1.6.0 + +### Improvements to `as_kable_extra()` + +* For users who used the default kableExtra print without output-specific formatting, there are no breaking changes...the only changes will be improved output styling. +* The biggest user-facing change is that the default results for **LaTeX output** are now greatly improved compared to previous releases, when `escape=FALSE` (the new default). + - Markdown bold, italic, and underline syntax in the headers, spanning headers, caption, and footnote will be converted to escaped LaTeX code. + - Special LaTeX characters in the body of the table will be escaped with `.escape_latex()` or `.escape_latex2()`, e.g. `%` will be updated to `\\%`, and rendered as `%` in the PDF document. + - The "\n" symbol will be recognized as a line break in the table headers, spanning headers, caption, and the table body. + - `\n` is removed from footnotes + - The `escape=` argument is now passed to `kableExtra::add_header_row()` and `kableExtra::footnote()` as well (previously, was only passed to `knitr::kable()`). +* The `as_kable_extra(escape=, format=)` arguments have been made explicit, where previously, these arguments were passed via `...`. +* *Breaking Change* The default value of `escape=` is now `FALSE`. If users previously used `as_kable_extra(escape=FALSE)` and had manually escaped LaTeX/HTML characters in the body of the table, these characters will now be double escaped. To print the table without the auto-escaping that is now present, utilize the new argument `as_kable_extra(addtl_fmt=FALSE)` +* *Breaking Change* The `fmt_missing=` argument was added to `as_tibble()`, `as_kable()`, and `as_kable_extra()` in the last release. This argument is now deprecated in `as_kable()` and `as_kable_extra()`. If a user does not want missing values formatted, they can exclude these commands with the `include=` argument. +* *Breaking Change* The `strip_md_bold=` has been deprecated. The markdown syntax will automatically be stripped from headers, unless `escape = FALSE` and `format = "latex"`. In that case, the markdown syntax will be converted to LaTeX commands. +* **HTML Updates** + - The default markdown syntax in the headers and spanning headers is removed. + - Special characters in the table body, headers, spanning headers, caption, and footnote will be escaped with `.escape_html()`. + - The `"\n"` symbol is removed from the footnotes + +### Improvements to `as_flex_table()` + +* Added support for markdown syntax in {flextable} header rows by utilizing the {ftExtra} package. If this package is installed and `options(gtsummary.use_ftExtra = TRUE)` has been set (or the equivalent theme element), the bold/italic markdown syntax found in the headers will be styled. Otherwise, the markdown syntax is stripped from the header rows. (#1200) + +### New Functions + +* New function `as_hux_xlsx()` added to export a formatted {gtsummary} table directly to Excel. + +* Added a `tbl_regression.tidycrr()` method to summarize competing risks regression models. (#1169) + +* Added tidier `tidy_wald_test()`, a generic function that can calculate Wald test statistics for groups of variables in a model. The tidier expects the model object is supported by both `vcov()` and `coef()` to obtain the variance-covariance matrix and the coef vector. + +* Adding functions `get_gtsummary_theme()` and `with_gtsummary_theme()` for extracting the current gtsummary theme and running code with a temporarily theme. + +* Added new function `modify_column_indent()`--a wrapper for `modify_table_styling()`--to make it easier to add and remove indentation in a table. + +* Now exporting a function primarily used internally as a helper for converting a gtsummary table to gt (and other formats): `.table_styling_expr_to_row_number()`. + +* Theme helper function `check_gtsummary_theme()` has been added. The function takes a gtsummary theme list as the input, and runs various consistency checks. Useful when constructing a personalized theme. This function replaces the internal checks that a passed theme element is indeed a valid theme element. + +### New Functionality + +* Functions `bold_labels()`, `bold_levels()`, `italicize_labels()`, `italicize_levels()` are now method functions so they can work better on `tbl_cross()` objects. + +* Total overhaul to the way statistics are saved and reported in `modify_header()`, `modify_spanning_header()`, `modify_footnote()`, and `modify_caption()`. There is now a standardized place to these statistics to be saved in all gtsummary tables (in `x$table_styling$header` in columns starting with `"modify_stat_"`). The modify functions have been updated to access the statistics from the header data frame. An added benefit to this structure, is that the statistics are available after tables are merged and stacked. Statistics available in `modify_caption()` are taken from the `"label"` column. (#1165, #1101) + +* Added `add_global_p(anova_fun=)` argument allowing users to pass custom functions to calculate global p-values when `car::Anova()` does not support the model type. (#1149) + +* Functions `bold_labels()`, `bold_levels()`, `italicize_labels()`, and `italicize_levels()` now bold/italicize the first column shown in the table. Previously, the `"label"` column (which is most often the first shown column) was styled. + +* Added theme element to pass arguments to `knitr::kable()` in `as_kable()` and `as_kable_extra()`. + +* Updated the default function in `add_glance_*(glance_fun=)` for MICE models. (#1137) + +* Add `tbl_butcher(keep=)` argument to optionally keep some internal objects as needed. (#1148) + +* Adding Norwegian translations (#1143) + +### Other Updates + +* Removed use of `round()` in `style_number()`, and replaced it with a round function that does _not_ "round-to-even". (#1140) + +* Converted the Table Gallery vignette into an FAQ+Gallery (#811) + +* Added error messaging if user tries to run `add_p()` or `add_difference()` twice. (#1209) + +* All models CIs were labelled as a Confidence Interval. Now Bayesian models will correctly label the Credible Interval. (#1196) + +* Improved error messaging the functions `as_gt()`, `as_kable()`, `as_flex_table()`, `as_hux_table()` when an object that is not class 'gtsummary' is passed. (#1188) + +* Deprecated the `as_huxtable(strip_md_bold=)` as {huxtable} now recognizes the markdown syntax and there is no reason to remove the markdown syntax. + +* Added `huxtable::set_header_rows()` to the `as_hux_table()` stack. + +* Improved error messaging in `modify_*()` functions. (#914) + +* Added `style_percent()` as the default formatting function for un-weighted proportions. (#1181) + +* The global options previously available have now been soft deprecated. All documentation of the global options was removed in v1.3.1. (#1085) + +* The `as_flextable()` function has been upgraded from a soft to a hard deprecation; use `as_flex_table()` instead. + +* No longer removing the survey design columns from survey objects from the columns that will be summarized in `tbl_svysummary()` and those summarized in `tbl_uvregression()`. If users previously didn't indicate which variables to summarize with `include=`, then the design columns will now appear in the summary tables. (#1166) + +* Added a check for functions that accept `...` where nothing should be passed in the `...`. If a bad or misspelled argument is found, the users are informed. (#1083) + +### Bug Fixes + +* Fix in `"emmeans"` methods for `add_difference()` to due an argument name change in the emmeans package. We now require the most recent version of the package. (#1205) + +* Bug fix in `inline_text.tbl_summary()` where one could not pass a pattern only when the column argument was `NULL`. (#1193) + +* Fix in `as_gt()` when there are no hidden columns. + +* Fix in `add_p.tbl_svysummary()` when Wald tests were converted to flextable. The survey tidier saved the column as a matrix-column instead of a vector, which was incompatible with flextable output. (#1153) + +* Fixing Lancet theme mid-point encoding issue on Linux and MacOS. (#1146) + +* Fix when using summary type gtsummary selectors (e.g. `all_continuous()`) with the `add_ci(style_fun=)` argument. (#1141) + +# gtsummary 1.5.2 + +* Removed foreign reference to external functions in the top level of the package and replaced with indirect calls (the reason for the short time between releases). (#1129) + +* Updates to the way footnotes are printed in `tbl_summary()` when there is summary type `"continuous2"` present. Previously, all footnotes were removed, and now only the `"continuous2"` footnotes are removed. (#1127) + +* Added the continuous variable name/label to the footnote for greater clarity in `tbl_continuous()` (#1123) + +* Now exporting the `.create_gtsummary_object()` function as a utility for other packages to build gtsummary tables. (#1130) + +* Fix when `add_overall()` was run before `add_n()`. The overall row was not being omitted from the sum and the Ns were doubled. (#1126) + +* Added method "emmeans" to `add_difference()` for `tbl_svysummary()` objects. + +* Updated default `add_difference()` for `tbl_svysummary()` objects to be "emmeans" for continuous and dichotomous variables, and "smd" for categorical variables. + +# gtsummary 1.5.1 + +### New Functions + +* Added new function `modify_column_alignment()` to updated column alignment. Function is a wrapper for the more complex `modify_table_styling()` function. + +* New function `tbl_strata2()` that passes both the the stratified data frame as well as the stratum level to the user function. (#1091) + +* Added a `add_p.tbl_continuous()` method for adding p-values to `tbl_continuous()` tables. (#1023) + +* Added `add_overall.tbl_continuous()` method. (#1037) + +### New Functionality + +* New test option "emmeans" in `add_difference()` and `add_p()` uses the {emmeans} package to estimate marginal means/least-squares means for continuous variables, binary variables and random intercept models. (#1112) + +* Column alignment is now recognized in `as_kable()` and `as_kable_extra()`. Previously, the alignment utilized the `kable()` defaults and ignored any alignment instructions included in the gtsummary table styling. + +* The `as_kable_extra()` was updated to utilize `kableExtra::column_spec()` and `kableExtra::cell_spec()` to apply bold and italic styling. The choice of the function depends on the use of `escape=` in `knitr::kable()` (#1107) + +* Default arguments to `knitr::kable()` may now be overwritten by passing `...` to either `as_kable()` or `as_kable_extra()`. Previously, passing a user-defined argument previously in use would result in error. + +* Added `tbl_strata(.header=)` argument providing greater control over the stratum headers that are added to the tables, e.g. you can now add Ns to the headers using this argument. + +* Added `add_p.tbl_cross(test.args=)` argument. (#1095) + +* The `tbl_strata(.combine_args=)` has been added that lets you control all arguments in the `tbl_merge()` or `tbl_stack()` that occurs in `tbl_strata()`. (#1090) + +* Added the `add_ci(pattern=)` argument, which makes it easier to merge the CI column with the primary statistics column. (#1029) + +* Suppress `tbl_merge()` spanning headers by passing `tbl_merge(tab_spanner = FALSE)` (#1067) + +* Functions `as_tibble()`, `as_kable()`, and `as_kable_extra()` gain the `fmt_missing=` argument that applies missing symbols to missing values. The `as_tibble()` argument defaults to `FALSE`, while the others' default is `TRUE`. (#1073) + +* Adding `tbl_regression(conf.int=)` and `tbl_uvregression(conf.int=)` argument. For some models, the confidence interval adds to the computation time significantly and may not be needed. This argument will omit the CI calculation. (#1052) + +* The `add_stat()` function was updated to accept `tbl_continuous()` tables. + +* Multinomial models computed using MICE are now supported. (#1065) + +* Added theme element to control the `tbl_regression(conf.int=)` default argument. + +* It is now possible to pass a single tbl to `tbl_merge()`. This is useful when using `tbl_merge()` as a helper in other functions. (#1068) + +* Added `statistics=` and `digits=` arguments to the `add_overall()` family of functions. (#1047) + +* Added `digits=` argument to `tbl_cross()`. (#1046) + +### Other Updates + +* Allowed modification to font_size for compact theme. (#1106) + +* Automatically reduced vertical white space between columns for compact flextable theme. + +* Improved user interface for `modify_*()` functions (#1064) + +* Improved error messaging throughout the package. (#1050) + +* Added link to the `syntax` help file to functions throughout the package. The `syntax` help file illustrates how to use the gtsummary selectors and details the formula-list notation. (#981) + +* Updated Spanish translation for Wilcoxon Rank-sum Test. + +* Updates and additions to Portuguese language translations. (#1098) + +* Updates to the French translations. + +* Updating the `add_overall()` S3 method to have a more common structure, e.g. `add_overall(x, ....)`, where previously, the `...` were not present. (#1066) + +* Updated the `theme_gtsummary_journal("qjecon")` to set `tbl_regression(conf.int = FALSE)` by default. + +* Improved error messaging in `tbl_custom_summary()` + +* Updated the default formatting functions in `tbl_custom_summary()`. Previously, summaries with character results erred because the default summary function was `style_number()`. This has been updated to `style_sigfig()` for numeric columns, and `as.character()` for everything else. (#983) + +* All `style_*()` functions will retain attribute, such as the names. (#1035, #1031, #981) + +* The `add_n.tbl_regression()` (which is also utilized in `tbl_uvregression()`) was adding the N column without applying a formatting function. The `style_number()` function has now been added as the default styler. (#1022) + +* Added class `"tbl_continuous"` to the output of `tbl_continuous()`. + +* Adding `add_p()` test `"mcnemar.test.wide"` to calculate the p-value when the data are stored in a wide format, e.g. one column for a before value and a second column for after. The other McNemar test variant available in {gtsummary} expects data in a long format. + +* Converted `tbl_split()` to S3 function. + +* Update how calls to `gt::fmt_missing()` are constructed to be more memory efficient. + +### Bug Fixes + +* Fix in `add_significance_stars()` that led to an error when the summarized model did not have a confidence interval column. + +* Fix in `as_flex_table()` and `as_hux_table()` where reference row was not properly placed after a `tbl_merge()` when the merged tables share common categorical variables but different reference rows. (#1063) + +* Fix in `inline_text.gtsummary()` where the first level of a categorical variable could not be selected if the table had also been processed with `remove_row_type()`. (#1078) + +* Fix in `modify_table_styling(cols_merge_pattern)` when it is used with `tbl_stack()` followed by `tbl_merge()`. (#1057) + +* Bug fix in `separate_p_footnotes()` where test names were not being translated when `theme_gtsummary_language()` was set. (#1055) + +* Fix in `tbl_merge()` when rows in a merging table are not present in the first table. (#1033) + +* Fix in `as_tibble()` for `nnet::multinom()` regression models. + +* Fix in `tbl_continuous()` when `include=` is not specified. + +* Fix in `tbl_regression()` when a tidier returns CI columns that are all missing. (#1012) + +* Fix in `add_p()`/`add_difference()` when check whether the passed test is an internal method or a custom method. The previous code required Suggested packages, such as, {lme4}, {effectsize}, and {survey}, to be installed. (#1018) + +### Breaking Changes + +* No longer exporting `assert_package()`. It has been migrated to {broom.helpers} and we now use `broom.helpers::.assert_package()`. (#1051) + +# gtsummary 1.5.0 + +### New Functions + +* Added new function `tbl_continuous()` to summarize a continuous variable by 1 or more categorical variables. + +* Added new function `add_ci()` that adds a new column with the confidence interval for proportions/means reported in `tbl_summary()`. (#868) + +* Migrated a new function `tbl_split()` from the {bstfun} package. Function allows users to split a {gtsummary} table into multiple tables. + +* Migrated a new function `separate_p_footnotes()` from the {bstfun} package. Function allows users to separate the composite footnote listing the tests performed in `add_p()`, and replaces it with individual footnotes for each test name. + +* New function `tbl_custom_summary()` allowing to create a table of summary statistics using a custom summary function (#973, #976) + + * Set of helpers to be used with `tbl_custom_summary()`: `continuous_summary()`, `proportion_summary()`, `ratio_summary()` + +* New function `modify_cols_merge()` that can merge two or more columns in a {gtsummary} table. (#939) + +* Added function `tbl_butcher()` to reduce the size of a {gtsummary} table. After an object has been butchered, other {gtsummary} functions may not be able to execute on the object. + +* Added new function `tidy_robust()` that will add robust standard errors, confidence intervals, and p-values with `tbl_regression()` and `tbl_uvregression()`. The function is a wrapper for `parameters::model_paramters()`. (#979) + +### New Functionality + +* Added a `CITATION` file so users can now cite the R Journal manuscript using `citation("gtsummary")`. + +* Added Standardized Mean Difference method to `add_difference()`, wrapping the {smd} package's calculations. (#966) + +* Extended `add_difference()` to accept `tbl_svysummary()` objects in addition to `tbl_summary()` objects. + +* Added a standardized mean difference method for `tbl_svysummary()` tables. + +* Added `tbl_strata(.stack_group_header=)` argument to include/exclude the headers when tables are combined with `tbl_stack()` + +* Added `tbl_strata(.quiet=)` argument. + +* Allow `add_p()` and `add_difference()` to be run on the same table. (#959) + +* Updated `add_overall()` to include the overall statistics in the `df_stats` tibbles saved in `.$meta_data.` This makes it possible to report any of the overall statistics using the `inline_text(pattern=)` argument. + +### Other Updates + +* Added a help file detailing the formula list notation used throughout the {gtsummary} package. (#981) + +* Updates to `tbl_regression()` documentation. The model N is no longer reported by default, and removed that section from the help file. (#998) + +* Updates to make the internal `df_stats` objects consistent across various {gtsummary} objects. Added internal function `df_stats_to_table_body` that adds the numeric df_stats tibble to `.$table_body`. The formatting functions are also added for the new columns to `.$table_styling$fmt_fun`. This function is now used in `inline_text.gtsummary()` to prepare the returned statistics (#921) + +* Now using `broom::tidy()` to prepare the `car::Anova()` results. This will be more stable than the version originally written. (#898) + +* The function `assert_package()` now takes the minimum required version of the package from the DESCRIPTION file, and the function is now exported. + +* Now using `broom::tidy()` to prepare `aov()` test results in `add_p.tbl_summary()`, which adds additional columns to `.$table_body()` (#956) + +* Updated the `README` to include links to a recording of a gtsummary presentation and to the RStudio Education blog post. + +* Removed `maturing` lifecycle tag from `README`. + +* Updated deprecated function `workflows::pull_workflow_fit(x)` to `workflows::extract_fit_parsnip(x)`. + +### Bug Fixes + +* Fix in `tbl_summary()` when a factor variable is passed that is all `NA` with no specified levels. (#977) + +* Fix in `add_p.tbl_summary()` when a factor variable with all NA values is passed. (#977) + +* Bug fix for the `add_difference(estimate_fun=)` argument. + +### Breaking Changes + +* Updated `add_p.tbl_summary(test = . ~ "mcnemar.test", group = id)` syntax to require the `group=` argument to align with the paired Wilcoxon rank-sum test and paired t-test syntax. + +* Deleted deprecated functions `add_comparison()`, `add_global()`, `tab_style_bold_p()`, `tab_style_bold_labels()`, `tab_style_italicize_levels()`, `tab_style_italicize_labels()`, `tab_style_bold_levels()`. + +* The following deprecated arguments have been removed: `tbl_summary(group=)`, `as_gt(omit=)`. + +* The survival package has been moved from Imports to Suggests, and will no longer automatically be installed when {gtsummary} is installed. Additionally, `survival::Surv()` is no longer re-exported with the package. + +# gtsummary 1.4.2 + +* Update to the internals of `tbl_stack()` to better handle when two or more stacked tables are then stacked again (#906) + +* Updates to make `tbl_svysummary()` compatible with {survey} package updates in v4.1 (#930) + +* The `as_hux_table()` function previously stripped markdown old syntax from column headers and spanning headers. The output now uses markdown syntax in the headers by default utilizing `huxtable::set_markdown()` (#885) + +* Variables passed in the `tbl_svysummary(by=)` argument will now automatically be added to `include=`. (#925) + +* Bold and italic requests are now ignored for kableExtra output. These are carried out via markdown syntax, which is not supported by {kableExtra} (#917) + +* Bug fix for `add_p.tbl_cross(pvalue_fun=)`; argument was being ignored. + +* Updated `style_pvalue()` to format p-values slightly larger than 1 and slightly lower than 0 (due to imprecise numeric storage). (#907) + +* Fix allowing for factor vectors to be passed in `tbl_stack(group_header=)`. (#908) + +* Updated arguments `y=` and `x=` in `tbl_uvregression()` to allow for non-standard names (#912) + +# gtsummary 1.4.1 + +* Updated `tbl_regression()` to be compatible with models created with the {parsnip} and {workflows} packages (#890, #647) + +* Added the `modify_table_styling(text_format = "indent2")` option to double indent a row. (#864) + +* Messaging update when `inline_text.gtsummary()` suspects a variable has been repeated in the gtsummary table. (#855) + +* Bug fix in `add_p.tbl_summary()` for columns that are all `NA`. These variables no longer error; rather, a message is printed indicating the p-value is not possible to calculate. (#889) + +* Updated `tbl_svysummary()` to be compatible with {srvyr} package (#886) + +* Updated default header when using `tbl_uvregression(x=)` to `"**Outcome**"` (#867) + +* The `tbl_summary(by=)` variable is now added to `include=` by default (#871) + +* Variables are converted to numeric before being passed to `wilcox.test()` in `add_p()`. This avoids an error when a date difference is passed. (#880) + +* Bug fix for {Hmisc} labeled data with `tbl_summary()` (#876) + +* Bug fix in `add_n.tbl_summary()` to proportion missing in some cases. (#903) + +* Updates to the default formatting functions in the `add_glance_*()` functions. P-values are now styled with `style_pvalue()` and No. Obs. and degrees of freedom with `style_number()` (#870) + +# gtsummary 1.4.0 + +### New Functions + +* Added new function `add_glance_table()` as a companion to `add_glance_source_note()`. Function adds model statistics, such as R-squared, to the bottom of the model summary table. + +* Added new function `add_significance_stars()` adding star indicators to significant estimates and an explanatory footnote. + +* Added new function `tbl_strata()`. The function aids prepares gtsummary tables stratified by one or more variables (#679) + +* Adding coefficient `plot()` methods for `tbl_regression()` and `tbl_uvregression()`. Function creates a forest plot of model coefficients via `GGally::ggcoef_plot()`. + +* New function `modify_fmt_fun()` has been introduced to help update the functions that format numeric columns and rows in `.x$table_body`. + +* New function introduced, `modify_table_styling()`, to update printing instructions of tables. This function replaces `modify_table_header()`, which is now soft deprecated. + +* Added function `add_vif()` to include variance inflation factors in `tbl_regression()` output. (#717) + +* Added a generic function `inline_text.gtsummary()` that can report results from any gtsummary table. (#398) + +### New Functionality + +* Print infrastructure has been updated to allow for both row and column specification when formatting data or table styling. The `x$table_header` object has been replaced with a more general `x$table_styling`. Review the updated vignette `"gtsummary_definition.Rmd"` for details. The `x$table_body` is no longer grouped after `tbl_stack()`; rather, the grouping variable is specified in `gt::gt(groupname_col=)` + +* `tbl_summary()` now accepts any class as input. Previously only non-date base classes were accepted. For non-base R classes, the summary type must be specified using `tbl_summary(type=)`. The default summary statistic for dates/times is the minimum and maximum. (#488) + +* The `add_stat()` function may now return multiple columns of new statistics. Some arguments have been deprecated in the update. (#746) + +* `tbl_uvregression()` now accepts both data frames and survey design objects as input. (#742) + +* If the default `tidy_fun = broom::tidy` fails, `parameters::model_parameters()` attempts to tidy the model, if {parameters} is installed. (#854) + +* Added a custom tidier for `mgcv::gam()` models (`tidy_gam()`) and a method function (`tbl_regression.gam()`) that uses the new tidier by default. (#745) + +* Added default support for `brmsfit` model in `tbl_regression()` with new method function. (#751) + +* Functions `modify_footnote()` and `modify_spanning_header()` now include the `text_interpret=` argument indicating whether to use `gt::md()` or `gt::html()` to format text. Default is `gt::md()`. + +* Added/updated functions `add_n()` and `add_nevent()` to work with `tbl_regression` and `tbl_uvregression` objects. Each function now has an argument to place Ns on the label or level rows. (#744) + +* Added _The Quarterly Journal of Economics_ to `theme_gtsummary_journal()`. This journal theme will be updated again after the gt package updates `cols_merge()` with a rows argument and allows for line breaks within cell. + +* Korean and Icelandic language translations added for `theme_gtsummary_language()`. + +* Ability to merge two or more columns with `modify_table_styling(cols_merge_pattern=)` argument. + +* Added theme element `"pkgwide-fun:pre_conversion"`. The function specified here will be executed on the gtsummary object before it is printed or converted with the `as_gt()`, `as_flex_table()`, etc functions. (#773) + +* The `modify_table_body(fun=)` argument has been generalized to accept formula shortcut notation. + +* Added exploratory data analysis theme that shows more details by default, `theme_gtsummary_eda()`. + +### Other Updates + +* Updated` tbl_merge()` and `tbl_stack()` to capture the first source note and caption in the merged/stacked tables. Previously, any captions and source notes were lost. + +* Added messaging when table caption requested via `modify_caption()` for a gt table when using a version of gt that does not support captions. + +* Updates to the table gallery vignette reflecting changes in the package. (#775) + +* Improved error messaging when there is a problem constructing one of the univariate regression models in `tbl_uvregression()`. + +* Added variable-specific formatting to `add_difference(estimate_fun=)` allowing a single table to show, for example, mean and rate differences that are formatted/rounded differently. + +* Improved handling and messaging to users when columns with `"haven_labelled"` class are passed to gtsummary functions. (#805) + +* Improved handling of ordered factors as the `by=` variable (#569, #540) + +* Removed {usethis} package dependency and replaced with {cli}. (#768) + +* Added the survey-adapted t-test to `theme_gtsummary_mean_sd()` for continuous variables in `add_p.tbl_svysummary()` (#758) + +* Allowing for tidyverse shortcut notation in `tbl_survfit(estimate_fun=)` specification, e.g. `tbl_survfit(estimate_fun= ~style_sigfig(.x * 100))` (#761) + +* The JAMA journal theme has been updated to merge the coefficient and confidence interval columns. + +* Updated other `inline_text()` functions to wrap `inline_text.gtsummary()` + +### Bug Fixes + +* The `label=` argument for unstratified models was being ignored in `tbl_survfit()` (#842) + +* Preserve ordering for factor variables in `tbl_survfit()`. (#764) + +* Bug fix for spanning headers with kableExtra output. The spanning header was misplaced when the header text was sandwiched between two blank spanning headers. + +* Bug fix when displaying an unobserved level of a factor variable dichotomously in `tbl_summary()`. (#780) + +* Bug fix in `add_p()` where test name footnote was not being translated with `theme_gtsummary_language()`. + +### Breaking Changes + +* `tbl_survival()` has moved from questioning to deprecated. This function maintains the old `x$table_header` format (instead of the more flexible `x$table_styling`). The `"level_label"` column was renamed to `"groupname_col"` and the `x$table_body` is no longer grouped with `group_by(level_label)` + +* The back-end implementation of `add_stat_label(location = "row")` has been updated. The function now merges columns `"label"` and `"stat_label"` instead of modifying the `"label"` column directly. This _could_ be a breaking change if users had manually updated results, for example, from a `tbl_regression()` table to merge with `tbl_summary()` using `tbl_merge()` + +* The function `add_stat_label()` no longer auto-switches `location = "column"` requests to `"row"` in the presence of `"continuous2"` variables. + +# gtsummary 1.3.7 + +* No changes. Resubmitting to resolve CRAN quirk. + +# gtsummary 1.3.6 + +### New Functions + +* Added function `add_difference()`, which adds difference between groups, confidence interval and p-value. (#617) + +* Added function `modify_caption()` that includes table captions. For gt output, requires gt version > 0.2.2 (#701) + +* Added function `modify_table_body()` allowing users to more easily make changes to gtsummary tables + +* Added function `remove_row_type()` for removing header, reference, or missing rows from a gtsummary tables. (#678) + +* Added selecting function `all_stat_cols()` that selects columns from `tbl_summary`/`tbl_svysummary` object with summary statistics (i.e. `"stat_0"`, `"stat_1"`, `"stat_2"`, etc.). + +* New selecting function was added `all_tests()` to make it easier to select variables based on the test used to calculate the p-value, e.g. `add_p(test = c(age, marker) ~ "t.test", test.args = all_tests("t.test") ~ list(var.equal = TRUE))` + +* Added functions `modify_column_hide()` and `modify_column_unhide()` to hide and unhide columns in `.$table_body`. Simple wrappers for `modify_table_header()`. + +### New Functionality + +* Previously, the `tbl_summary(digits=)` only accepted integer values specifying the number of decimal places to round a statistic. The argument now accepts both integers or functions, e.g. `digits = age ~ style_sigfig`. (#708) + +* The `add_stat()` function now supports `tbl_svysummary()` objects in addition to `tbl_summary()` (#688) + +* The `add_stat()` function can now place statistics on the label row, or the level rows for categorical variables. (#714) + +* `inline_text.tbl_survfit()` updated to allow users to select p-value (and other) columns. (#589) + +### Other Updates + +* `modify_header()` has been updated so users may more easily access internal data while defining headers and so that it no longer adds its call to the gtsummary `.$call_list` (#719) + +* The default value for `include=` argument for the `add_global_p.tbl_regression()` and `add_global_p.tbl_uvregression()` methods have been made the same with `include = everything()`, and the help files for these methods have been brought together in a single file. (#721) + +* Introducing new package dependency {broom.helpers} + + * The tidying and preparation of `tbl_regression()` tables are now being performed by {broom.helpers} (#636, #607) + + * All select helper functions and the utility functions that make them possible, have been cleaned up and migrated to {broom.helpers}. (#648, #680) + + * Importing `.generic_selector()`, `.select_to_varnames()`, and `.formula_list_to_named_list()` from {broom.helpers}: 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) + + * Theme element has been added for controlling the other `tidy_plus_plus()` arguments. (#692) + + * Variables that do not follow standard naming conventions are now parsed correctly and presented in the regression tables. + +* The `tbl_regression()` function is now an S3 method. The new interface allows for special handling of different model types using S3 methods: `tbl_regression.default()`, `tbl_regression.lmer()`, `tbl_regression.glmer()`, `tbl_regression.survreg()` + +* `tbl_regression(add_estimate_to_reference_rows=)` argument has been added. Also added to `tbl_uvregression()`. (#692) + +* Theme element for `tbl_regression(add_estimate_to_reference_rows=)` has been added. (#677) + +* Removed `"Statistics presented:"` and `"Statistical tests performed:"` prefixes from the `tbl_summary() %>% add_p()` footnotes. + +* The codebase powering `add_p()` and related methods has been refactored for better performance, organization, and customizability. (#622) + + * For clarity, a help file listing each test available within gtsummary and the pseudo code for calculating the p-value has been added (see `?tests`) + + * Each `add_p()` method now has the `test.args=` argument. Use this argument to pass additional arguments to the statistical method, e.g. `add_p(test = c(age, marker) ~ "t.test", test.args = c(age, marker) ~ list(var.equal = TRUE))` + + * Additional tests have been added: paired t-test, signed rank test, and more. See `?tests` for full list. + + * More robust unit testing implemented for all `add_p()` methods. + +* Added messaging to `tbl_stack()` to inform users that the attributes from the first table passed take precedent over the others'. (#699) + +* In the `modfiy_*()` functions, if users did not select any columns, they encountered an error. Now, if no columns are selected, instructions are printed for how to correctly select columns in a gtsummary table. Moreover, if no columns are selected, the gtsummary object is now returned unaltered. (#699) + +* The `add_glance_source_note()` function has been generalized so users may pass any glance function. Previously, `broom::glance()` was being used with no option to change it. (#699) + +* The `...` arguments have been added to `as_gt()`. These dots are subsequently passed to `gt::gt(...)`. (#701) + +* Multiple imputation models created with {mice}, and multinomial regression models created with {nnet} are now supported in `tbl_regression()` (#645) + +* Updates to `add_global_p.tbl_regression()` allowing for variable names with spaces and special characters (#682) + +* Added `digits=` argument to `style_percent()` (#690) + +* Users may now choose which `tbl_regression()` columns to report with a theme element. they can choose among the `"estimate"`, `"std.error"`, `"statistic"`, `"ci"`, `"conf.low"`, `"conf.high"` and `"p.value"` (#637) + +* Allow users to include the reference value in `tbl_regression()` via a theme element + +* Users may change the symbol with a reference row symbol with a theme element. (#628) + +### Bug Fixes + +* Bug fix when a default statistic is set using themes for `"continuous2"` variables that has length larger than one + +* Bug fix when missing/non-missing percentages requested in `add_n.tbl_summary()` + +### Breaking Changes + +* The default test for 2-by-2 tables with expected cell counts has been updated from the chi-squared test with continuity correction to the original chi-squared test for `add_p.tbl_summary()` (#721) + +* Experimental function `add_p.tbl_survfit(test.args=)` in addition to accepting the formula list notation, also accepted a single string naming a test that was interpreted as `everything() ~ "test_name"`. The single string is no longer accepted, and users must use the formula notation. + +* Removed theme element `N_fun` that was previously marked as questioning and likely to be removed from the package. + +# gtsummary 1.3.5 + +### New Functionality + +* New summary type `continuous2` allows adding labelled statistic rows to tables in `tbl_summary()` and `tbl_svysummary()`. You can report several lines of statistics with this type. (#620) + - The `all_continuous()` function now selects summary types `continuous` and `continuous2` by default. + - Added `all_continuous2()` function for selecting summary type `continuous2` exclusively. + - Added `theme_gtsummary_continuous2()` to make `continuous2` the default summary type for all continuous variables. + +* New function `add_glance_source_note()` adds the statistics returned in `broom::glance()` as a source note on a `tbl_regression()` (#434) + +* Exporting the `modify_table_header()` function, which is an advanced-use function used to make modifications to the `.$table_header` object to update printing instructions for the gtsummary object. + +* Added two custom tidiers for use in `tbl_regression()` and `tbl_uvregression()`. (#635) + - `tidy_standardize()` returns standardized coefficients using the {effectsize} package + - `tidy_bootstrap()` gives bootstrapped parameter estimates, calculated using the {parameters} package + +### Bug Fixes + +* Bug fix where `estimate_fun=` and `pvalue_fun=` were not being passed to `tbl_regression()` in `tbl_uvregression()` + +* There was an environments bug when evaluating the LHS of the formula inputs. In some complex situations, a stored character vector of column names could not properly evaluate (#604) + +* Fixed `style_ratio()` bug where there were rounding errors near one (#651) + +* Fixed `style_sigfig()` bug where there were rounding errors near thresholds (#638) + +* Adding the footnote from the stat columns describing the statistics presented to the overall column (#643) + +### Other Updates + +* Refresh of vignettes to use recently released functions (#649) + +* Moved the nevent column to after the N column when `add_nevent()` is called on a `tbl_regression()` object (#439) + +* gtsummary themes updates + - Add `theme_gtsummary_mean_sd()` theme to report mean and SD by default and use t-tests and ANOVA in `add_p()` (#654) + - Added first draft of the NEJM theme + - Added the mid-point decimal separator for the Lancet theme + +# gtsummary 1.3.4 + +* Added a copy of tidyselect's `where()` function to allow users to use predicate select helpers (#632) + +* Fixed `tbl_cross()` bug where function defaulted to `'column'` when `margin = NULL`. Now it defaults to display no margins when `NULL`. (#624) + +* Changed default of `tbl_survfit()` `missing` argument from `'\U2014'` (em dash) to NULL (CRAN issue). Em dash is still displayed by default in tables but it is set later in function. + +# gtsummary 1.3.3 + +### New Functions + +* The {flextable} has graduated from Experimental status! Introducing `as_flex_table()`, which replaces `as_flextable()`. The updated function includes improvements to the default aesthetics of the tables, and improved consistency for spanning header rows. + +* Added `tbl_svysummary()` function to summarize complex and weighted survey designs. `tbl_svysummary` is now its own class that works with `add_n()`, `add_p()`, `add_q()`, `add_stat_label()`, `add_overall()`, `inline_text()`, `tbl_merge()` and `tbl_stack()` (#460). + +* The family of `tbl_survfit()` functions has been greatly expanded! + - `tbl_survfit.survfit()`, `tbl_survfit.list()`, and `tbl_survfit.data.frame()` have been added that accept a single survfit object, list of survfit objects, or a data frame for more flexible creation of univariate survival tables. + - `add_p.tbl_survfit()`, `add_n.tbl_survfit()`, `add_nevent.tbl_survfit()` have been added to include additional information in `tbl_survfit()` tables. + +* Adding `as_hux_table()` after the huxtable 5.0.0 release. + +* Added `show_header_names()` function to assist when updating table headers, footnotes, and spanning headers. The function prints the current underlying column names along with their labels easing the process of identifying the column names needed to make updates. (#539) + +* Added a language theme, `theme_gtsummary_language()` for translating tables into Spanish, French, Portuguese, German, Chinese (Traditional and Simplified), Hindi, Marathi, Gujarati, Japanese and Swedish (#511) + +* Added `style_number()` function which allows for granular control of how numbers are formatted throughout the package. The `style_percent()`, `style_pvalue()`, `style_sigfig()`, and `style_ratio()` functions have been updated to use `style_number()` in the background. The implication is that users can now control how every number in a gtsummary table appears. For example, formatting can be updated to use the comma as the decimal mark and also specify the big mark using the gtsummary themes. (#458) + +### User-facing Updates + +* Added support for competing risk cumulative incidence estimates to `tbl_survfit()` (#64, #448) + +* Updated API for `set_gtsummary_theme()`. Users no longer need call `set_gtsummary_theme(theme_gtsummary_journal())`; rather, they call `theme_gtsummary_journal()`. Each built-in theme now has an argument `set_theme = TRUE`. When `FALSE`, the theme function will invisibly return the named list the theme elements, and the theme will not be set. (#522) + +* Users can now specify how many decimal places to round statistics for categorical variables in `tbl_summary()`, e.g. `45 / 100 (45.0%)`. (#458) + +* Added the 'The Lancet' theme to `theme_gtsummary_journal()` + +* Updated the handling for arguments that accept functions to allow users to pass anonymous functions using the tidyverse shortcut notation, e.g. `~style_pvalue(.x, digits = 2)`. + +* The header for the `tbl_stack(group_header=)` column is now integrated into a typical gtsummary framework, meaning that all standard functions can be executed on it, e.g. `modify_header()` for non-gt output. + +* Added `type=` argument to `add_global_p()`, and added `include=` and `keep=` arguments to `add_global_p.tbl_uvregression()` (#554) + +### Internal Updates + +* Updated `add_n()` internals to be more efficient without recalculating statistics previously saved in `tbl_summary()` + +* {survival} package moved from Imports to Suggests + +* The `add_overall()` function is now a method function, and `add_overall.tbl_summary` and `add_overall.tbl_svysummary` added (#460). + +* Updated the variable labels for age and marker in the trial dataset. + +* Removed large *.gif files out of the package to reduce build size (#485) + +### Bug Fixes + +* Fixed bug where source note was not made smaller font size with compact theme when table was printed with {flextable} (#584) + +* Bug fix for `tbl_summary()` when a data frame contained an ordered factor column (#567) + +* Bug fix when only categorical summary statistics were requested for continuous variables in `tbl_summary()` and `tbl_svysummary()` (#528) + +* Bug fix when _named_ list of {gtsummary} objects is passed to `tbl_merge(x=)` (#541) + +* Bug fix when for `tbl_uvregression()` when adjustment variables were included in `formula = "{y} ~ {x} + age"`. The adjustment variables were being printed in the resulting table. (#555) + +### Breaking Changes + +* All `lifecycle::deprecate_warn()` have been upgraded to `lifecycle::deprecate_stop()` for <= v1.2.0 (released Aug 2019) + +* Removing `as_flextable()` and replacing with `as_flex_table()` due to a name conflict with `flextable::as_flextable` (#462) + +# gtsummary 1.3.2 + +* Now returning all columns from `broom::tidy()` in `.$table_body()` (#516) + +* `tbl_stack()` now accepts a named list of gtsummary tables when using the `group_header=` argument (#524) + +* `add_p.tbl_summary()` bug fix for Wilcoxon rank-sum p-value calculation introduced in the last release (#525) + +* Delaying the release of `as_huxtable()` until the next {huxtable} release. + +# gtsummary 1.3.1 + +### New Functions + +* Introducing themes in {gtsummary}. Use the function `set_gtsummary_theme()` to set new themes, and review the themes vignette for details on setting and creating personalized themes. (#424) + +* New functions `modify_footnote()` and `modify_spanning_header()` give users control over table footnotes and spanning headers. (#464) + +* Introducing `as_huxtable()`! The function converts gtsummary objects to {huxtable} objects. {huxtable} supports indentation, footnotes, and spanning headers with Word, HTML, and PDF output. (#469) + +* New function `add_stat()`! Add a new column of any statistic to a `tbl_summary()` table (#495) + +### User-facing Updates + +* The following columns in `tbl_summary()` are now available to print for both continuous and categorical variables: total number of observations `{N_obs}`, number of missing observations `{N_miss}`, number of non-missing observations `{N_nomiss}`, proportion of missing observations `{p_miss}`, proportion of non-missing observations `{p_nomiss}`. (#473) + +* Improved appearance of default `as_flextable()` output (#499) + +* Added `tbl_cross(margin=)` argument to control which margins are shown in the output table. (#444) + +* The missing values are now included in the calculation of p-values in `tbl_cross()`. + +* Messaging about statistical methods used has been added for `add_global_p()`, `add_q()`, and `combine_terms()`. (#471) + +* Added `include=` argument to `tbl_summary()`. The preferred syntax for p-values with correlated data is now `tbl_summary(..., include = -group_var) %>% add_p(group = group_var)`. The group variable is now no longer removed from the table summary. (#477) + +* `add_stat_label()` function updated with `location=` and `label=` arguments to change the location of the statistic labels and to modify the text of the labels. `location = "row"` is now the default. (#467) + +* `tbl_stack()` function added the `group_header=` argument that groups the stacked tables and adds a horizontal header row between them. (#468) + +* Updated handling for interaction terms in `tbl_regression()`. Interaction terms may now be specified in the `show_single_row=` and `label=` arguments. (#451, #452) + +### Internal Updates + +* Improved error messaging when invalid statistics are requested in `tbl_summary(statistic=)` (#502) + +* All columns in `as_tibble()` are now styled and converted to character. Previously, styling was applied to most columns, but there were a few that relied on default printing for the type of underlying data. This was ok to rely on this default behavior for `as_kable()`, but with the introduction of `as_flextable()` we needed to style and format each column to character. Potential to break some code in edge cases. (#493) + +* Handling of passed custom p-value functions in `add_p.tbl_summary()` has been improved with more careful handling of the environments from which the functions were passed. Other related updates were also made: + - Users may pass their custom p-value function as a quoted string or bare. + - The basic functions for calculating p-values, such as `t.test()` can now be passed directly e.g. `test = age ~ t.test`. We now perform a check match check for functions passed. If it is passed, we replace it with our internal version that returns the p-value and assigns the test name. + - If a user passes a custom function, and it's not the proper form (i.e. a named list return object) AND the function returns a single numeric value, we assume that is the p-value and it's added to the gtsummary table. + +* Updated the gtsummary core script, `utils-gtsummary_core.R`, to refer to all non-base R functions with the `pkg::` prefix, so other packages that copy the file don't need to import the same functions as {gtsummary} in the NAMESPACE. Now they just need to depend on the same packages. (#454) + +### Bug Fixes + +* Bug fix for `inline_text.tbl_summary()` when categorical variable contained levels with empty strings. There is still an issue if a user tries to select the empty string, however. + +* Fixed bug where some variables in `tbl_cross()` defaulted to dichotomous instead of showing as categorical (#506) + +* Bug fix when using a `tbl_summary(by=)` with missing observations in `by=` followed by `add_overall()` + +* Bug fix where values `">0.9"` were incorrectly made bold using `bold_p()`. (#489) + +* Bug fix for `as_flextable()`. (#482) + - Added a formatting function to all numeric columns to force conversion to character. + - Spanning headers were being printed in alphabetical order! Update to preserve the ordering. + +# gtsummary 1.3.0 + +### New Functions + +* Introducing `tbl_cross()`, `add_p.tbl_cross()`, and `inline_text.tbl_cross()`! Easily construct cross tabulations of two variables. + +* Introducing `tbl_survfit()` and `inline_text.tbl_survfit()`! These will eventually replace `tbl_survival()`, which will no longer be encouraged. The new functions follow the structural guidelines of a {gtsummary} object and can be merged and stacked with any other {gtsummary} object (#280) + +* Introducing `as_flextable()`! The function converts gtsummary objects to {flextable} objects. {flextable} is a great option when using R markdown with Microsoft Word output. {flextable} supports indentation, footnotes, and spanning headers with Word, HTML, and PDF output. + +* Introducing `as_kable_extra()`! The function converts gtsummary objects to {kableExtra} objects. {kableExtra} supports indentation, footnotes, and spanning headers with HTML and PDF output. (#394) + +### User-facing Updates + +* Updated default print engine for {gtsummary} objects. {gt} is the default printer for the R console and R markdown documents with HTML output. PDF, RTF, and Word output default to using {kable} with a note referring users to a new vignette explaining why {gt} was not used. (#395, #396) + +* Updated `add_p()` custom p-value description to NOT require double escape characters for quotation marks (#361) + +* Created structure and enumerated list of unit tests each vetted model must pass, and added the tests (#383) + +### Internal Updates + +* Each gtsummary object has an associated `.$table_header`. The code needed to print a table with either gt or kable was previously a mix of information stored in the `table_header`, and code manually added to the `gt_calls` or `kable_calls` object. Now, all the information needed to print a table is stored in `table_header`. This has the advantage that any updates to the printing will now require an update to `table_header` only, and we no longer need to update the tibble, kable and gt calls. (#412, #414) + +* The {gt} package is now released on CRAN, and we've updated to depend on the CRAN version instead of the version on GitHub. This also resulted in significant updates throughout the documentation and code. For example, we no longer provide instructions for installing {gt}, or include internal checks if {gt} is installed. (#420) + +* Several functions have been made general, and may now be applied to any {gtsummary}-like object. Functions updated are `add_q()`, `bold_p()`, `sort_p()`, `tbl_merge()`, `tbl_stack()`, `bold_labels()`, `bold_levels()`, `italicize_labels()`, and `italicize_levels()`. (#434, #429, #373) + +* In `tbl_regression()` we previously printed the estimate, confidence interval, and p-value for all models. But some models don't have associated methods for calculating the p-value or the confidence intervals. In this update, we now print the p-value if `tidy()` returns a `"p.value"` column. Similarly, the confidence interval is printed if `tidy()` returns `"conf.low"` and `"conf.high"` columns. (#391, #404) + +### Bug Fixes + +* Bug fix when data frame passed to `tbl_summary()` with a single column (#389) + +* In `tbl_summary()` passing an ordered factor in the `by=` argument no longer causes as error. (#453) + +# gtsummary 1.2.6 + +* Bug fix for random effects regression model where coefficients were not exponentiated when requested. Using `broom.mixed::tidy()` rather than `broom::tidy()` resolved issue. + +# gtsummary 1.2.5 + +### Documentation + +* Updated documentation and README to improve readability, added more cross-linking across pages, added search terms to help users find our package, and added gif demonstrations (#340) + +* README images now build differently for website vs GitHub markdown to accommodate different output formats + +### Breaking changes + +* Removed deprecated `fmt*_()` and `cols_label_summary()` functions (#365) + +* Functions `tbl_summary_()` and `add_p_()` have been deprecated because the `by=` and `group=` arguments now accept strings (#250) + +### Syntax + +* Package-wide update allowing arguments that accept variable names to accept bare/symbol inputs, character inputs, stored character inputs, and tidyselect helpers. When passing a single variable, the `vars()` function wrapper is no longer required. (#250) + + ```r + tbl_summary(trial, label = age ~ "NEW LABEL")) + tbl_summary(trial, label = "age" ~ "NEW LABEL")) + tbl_summary(trial, label = c("age", "trt") ~ "NEW LABEL")) + tbl_summary(trial, label = c(age, trt) ~ "NEW LABEL")) + tbl_summary(trial, label = vars(age, trt) ~ "NEW LABEL")) + tbl_summary(trial, label = vars(everything(), -age, -trt) ~ "NEW LABEL")) + + age_column = "age" + tbl_summary(trial, label = age_column ~ "NEW LABEL")) + tbl_summary(trial, label = vars(age_column) ~ "NEW LABEL") + + purrr::map(c("trt", "grade"), ~tbl_summary(trial, by = .x)) + ``` +* Updated `tbl_uvregression()` to allow flexible tidyselect inputs and improved error messaging for arguments `x` and `y` (#249) + +* After the input updates in #250, the `exclude=` argument appearing in `add_p()`, `tbl_regression()`, `tbl_uvregression()`, `as_gt()`, `as_kable()`, and `as_tibble()` was redundant. The `exclude=` argument is now deprecated. Use `include=` instead, with tidyselect syntax. (#331) + +* Functions `all_categorical()`, `all_dichotomous()`, and `all_continuous()` may now be used in `tbl_summary()` argument `type=` (#256) + +### User-facing improvements + +* New `pattern=` argument in `inline_text.tbl_summary()`. Previously, we could only grab the entire cell from a `tbl_summary()` with `inline_text()`, and now we can get any single statistic reported (#254) + +* Improved messaging for users who use `knitr::kable()` to print gtsummary tables, and users who have not yet installed the {gt} package (#347) + +* New function `combine_terms()` allows users to combine multiple independent variables in a regression model into a single line after `tbl_regression()`. The single line does not report regression coefficients, rather a single p-value from the `anova()` function. (#310) + +* In the regression modeling functions `tbl_regression()` and `tbl_uvregression()`, the users are presented an informative error message when the tidier fails (e.g. `broom::tidy()`) alerting them to the location of the error so they may address the issue (#337, #338) + +* For each release of gtsummary, we now can make reference to the version of gt our release coincides with. The commit SHA for gt is now saved in an object called `gt_sha`, and the version of gt can be installed with `remotes::install_github("rstudio/gt", ref = gt_sha)` (#329) + +* Created "style" family of functions + +* Improved error messaging in `tidyselect_to_list()` (#300) + +### Other features and fixes + +* Updated class detection to use `inherits()`, and added secondary class of `"gtsummary"` to all objects. This allows users to create their own cobbled/custom gtsummary objects while utilizing the gtsummary print functions (#249) + +* `tbl_summary()` will now summarize columns of class `difftime` (#343) + +* Infrastructure update to the way styling/formatting functions are returned. Styling functions are now returned as a column in the `.$table_header` tibble. The update simplifies handling of these styling functions in `tbl_merge()` and `tbl_stack()`. (#298, #299) + +* Bug fix for `tbl_summary()` when variables were all NA (#344) + +* The data summary function `add_p()` now uses probabilities rather than counts to calculate expected cell counts to avoid an error when working with large data sets. (#341) + +* Cubic spline terms are now accurately matched to a variable name/term (#312) + +* Bug fix when non-standard evaluation arguments were passed in `method.args=` argument of `tbl_uvregression()` (#322) + +* Updates after the gt package deprecated `gt::cells_data()` in favor of `gt::cells_body()`. Check added to `as_gt()` ensuring a version of gt with `gt::cells_body()` in its NAMESPACE + +* Lowered minimum required version of R to v3.4 (#356) + +* Removed {broom.mixed} dependency as the {broom} package contained all necessary tidiers (#354) + + +# gtsummary 1.2.4 + +* Bug fix in `as_kable()` where column header did not match statistics presented when certain levels of the `by=` variable are entirely missing in `tbl_summary()` (#304) + +* Updated the trial example data set `"trt"` variable to be `"Drug A"` and `"Drug B"` instead of `"Placebo"` and `"Drug"` + +* Improved messaging to users when an error or warning occurs while calculating a p-value in `add_p()`. Also, p-values are no longer omitted from output when a warning is encountered during their calculation (#283) + +* Added `tidy_fun=` argument to `tbl_regression()` and `tbl_uvregression()` allowing users to pass tidiers that are not in the {broom} and {broom.mixed} packages (#247) + +# gtsummary 1.2.3 + +* `tbl_uvregression()` now accepts an `x=` argument to build univariate regression models where the covariate `x` remains the same while models are built the with remaining variables as the outcome (#294) + +* Internal updates to the way {gt} is installed during CRAN checks. + +* Bug fix when stacking `tbl_summary` objects with calculated p-values. + +# gtsummary 1.2.2 + +### New Features + +* `tbl_summary` objects may be stacked and merged with `tbl_stack()` and `tbl_merge()` (#230, #255) + +* The `add_n()` function now reports additional statistics: total N, non-missing N, missing N, and their percentages. The `missing = ` argument has been deprecated in favor of the `statistic = ` argument. (#237) + +* Users may now pass a list of formulas, named lists, or a combination of both (#251) + +* Users can add an option to their script to append any {gt} calls when a {gtsummary} object is printed: `gtsummary.as_gt.addl_cmds` + +* Added `include =` and `exclude =` arguments to `tbl_uvregression()` (#240) + +* Added standard evaluation variants, `tbl_summary_()` and `add_p_()` (#223) + +* Added `as_tibble()` function that converts any {gtsummary} table to a tibble (#245) + +* New `show_single_row` argument in `tbl_regression()` and `tbl_uvregression()` allows any binary variable to be printed on a single row. Previous argument `show_yesno` is now deprecated. (#220) + +### Documentation + +* Added a gallery of tables possible by merging, stacking, and modifying {gtsummary} arguments (#258) + +* Added a vignette documenting each global option that can be set in {gtsummary} (#289) + +* Added {lifecycle} badges to mark deprecated and experimental functions (#225) + +### Other Updates + +* The `by = ` column in `tbl_summary()` now has missing variables dropped rather than halting with error (#279) + +* Bug fix in `vars()` selection where only first variable listed was being selected (#259) + +* Bug fix where logical variable labels printed as `NA` in `tbl_regression()` (#248) + +* `tbl_merge()` now interprets `tab_spanner =` text with `gt::md()` (#253) + +* No longer checking outcome variable name for consistency in `tbl_regression()`---only checking independent variable names (#287) + +* Improved error messaging for `add_global_p()` (#243) + +* Removed `gt::cols_merge()` function ahead of the {gt} package [PR 355](https://github.com/rstudio/gt/pull/355) that changes the `cols_merge()` API (#222) + +* Updated API for using custom functions to calculate p-values in `add_p()`. User now may reference a custom function by its name. (#226) + +* Removed legacy support for tidyr version less than 1.0.0 (#235) + +# gtsummary 1.2.1 + +* Vignettes no longer install the {gt} package (required for CRAN check) (#217) + +* Added ability to name custom `add_p()` tests (#213) + +# gtsummary 1.2.0 + +* Users can pass variable names in backticks (#212) + +* The `group = ` argument in `tbl_summary()` has been moved to `add_p()` (#208) + +* Users can now write custom functions to calculate p-values in `add_p()` (#194) + +* In `tbl_summary()` the `by = ` argument accepts a bare variable name instead of the variable name passed as a string (#193) + +* Added support for column, row, and cell percentages in `tbl_summary()` (#181) + +* Users can now set default p-value formatting functions, regression coefficient formatting functions, default level for confidence intervals, and formatting functions in `tbl_survival()` (#120) + +* The {gt} package is no longer a required dependency. If {gt} is not installed, tables will be printed with `knitr::kable()`. The `as_kable()` function was added to the package as well. (#180) + +* The function `as_gt()` now has `include = ` and `exclude = ` arguments + +* Updated some function names to be the same as they were in the first version + +```r + bold_p() <- tab_style_bold_p() + bold_labels() <- tab_style_bold_labels() + bold_levels() <- tab_style_bold_levels() + italicize_labels() <- tab_style_italicize_labels() + italicize_levels() <- tab_style_italicize_levels() +``` + +* Passing named lists in `tbl_summary()` is now defunct. + +* `tbl_stack()` fix for `tbl_uvregression` objects (#175) + +* Option to exclude some variables from testing when using `add_p()` (#164) + +* Updates after {gt} package renamed `cells_style()` to `cell_text()` (#78) + +# gtsummary 1.1.1 + +* Modified `tbl_merge()` to accommodate `tbl_stack()` object (#167) + +* Bug fix with incorrect column order in `tbl_summary()` with 10+ levels of by variable (#166) + +# gtsummary 1.1.0 + +* Added {tidyselect} and {gtsummary} variable select functions (#146) + +* Added `tbl_stack()` function (#152) + +* Bug fix for dichotomous yes/no variables in `tbl_summary` (#158) + +* Changed `add_comparison()` and `add_global()` to `add_p()` and `add_global_p()` (#143) + +* Added `sort_p()` function (#105) + +* Allow unobserved values to serve as the level for dichotomous variables (#149) + +* Bug fix in `add_nevent()` when formula was passed to `glm()` as a string (#148) + +* Added returned `call_list` to some functions without it previously (#137) + +* Corrected name of call list in returned `tbl_regression()` results (#128) + +* `tbl_survival()`: bug fix when upper bound of CI was not able to be estimated (#134) + +* `tbl_survival()`: the `groupname` column name has been changed to `label_level` (#133) + +# gtsummary 1.0.0 + +First release since major re-factoring. The {gt} package is now used as the print engine to create all tables. Some function names have been modified to be more in line with other {gt} function calls, and additional functions have been added. The API for some functions has also been updated. Review documentation and vignettes for details. + +### Updated Function Names + +```r + tbl_summary() <- fmt_table1() + tbl_regression() <- fmt_regression() + tbl_uvregression() <- fmt_uni_regression() + style_pvalue() <- fmt_pvalue() + style_percent <- fmt_percent() + style_ratio <- fmt_beta() +``` + +### New Functions + +```r + tbl_survival() as_gt() + tbl_merge() style_sigfig() + add_nevent() gtsummary_logo() +``` + +# gtsummary 0.1.0 + +First version of package available [here](https://github.com/ddsjoberg/gtsummary-v0.1). diff --git a/_archive/R/aaa.R b/_archive/R/aaa.R new file mode 100644 index 0000000000..edca35e268 --- /dev/null +++ b/_archive/R/aaa.R @@ -0,0 +1,2 @@ +# initializing new env where all gtsummary theme elements are saved +env_gtsummary_theme <- rlang::new_environment() diff --git a/R/add_ci.R b/_archive/R/add_ci.R similarity index 100% rename from R/add_ci.R rename to _archive/R/add_ci.R diff --git a/R/add_difference.R b/_archive/R/add_difference.R similarity index 100% rename from R/add_difference.R rename to _archive/R/add_difference.R diff --git a/R/add_glance.R b/_archive/R/add_glance.R similarity index 100% rename from R/add_glance.R rename to _archive/R/add_glance.R diff --git a/R/add_global_p.R b/_archive/R/add_global_p.R similarity index 100% rename from R/add_global_p.R rename to _archive/R/add_global_p.R diff --git a/R/add_n.R b/_archive/R/add_n.R similarity index 100% rename from R/add_n.R rename to _archive/R/add_n.R diff --git a/R/add_nevent.R b/_archive/R/add_nevent.R similarity index 100% rename from R/add_nevent.R rename to _archive/R/add_nevent.R diff --git a/R/add_overall.R b/_archive/R/add_overall.R similarity index 100% rename from R/add_overall.R rename to _archive/R/add_overall.R diff --git a/R/add_p.R b/_archive/R/add_p.R similarity index 100% rename from R/add_p.R rename to _archive/R/add_p.R diff --git a/R/add_q.R b/_archive/R/add_q.R similarity index 100% rename from R/add_q.R rename to _archive/R/add_q.R diff --git a/R/add_significance_stars.R b/_archive/R/add_significance_stars.R similarity index 100% rename from R/add_significance_stars.R rename to _archive/R/add_significance_stars.R diff --git a/R/add_stat.R b/_archive/R/add_stat.R similarity index 100% rename from R/add_stat.R rename to _archive/R/add_stat.R diff --git a/R/add_stat_label.R b/_archive/R/add_stat_label.R similarity index 100% rename from R/add_stat_label.R rename to _archive/R/add_stat_label.R diff --git a/R/add_vif.R b/_archive/R/add_vif.R similarity index 100% rename from R/add_vif.R rename to _archive/R/add_vif.R diff --git a/R/as_flex_table.R b/_archive/R/as_flex_table.R similarity index 100% rename from R/as_flex_table.R rename to _archive/R/as_flex_table.R diff --git a/_archive/R/as_gt.R b/_archive/R/as_gt.R new file mode 100644 index 0000000000..9ef8eb2f17 --- /dev/null +++ b/_archive/R/as_gt.R @@ -0,0 +1,341 @@ +#' Convert gtsummary object to a gt object +#' +#' @description Function converts a gtsummary object to a `"gt_tbl"` object, +#' that is, a table created with `gt::gt()`. +#' Function is used in the background when the results are printed or knit. +#' A user can use this function if they wish to add customized formatting +#' available via the [gt package](https://gt.rstudio.com/index.html). +#' +#' @description Review the +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#advanced}{tbl_summary vignette} +#' or +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html#advanced}{tbl_regression vignette} +#' for detailed examples in the 'Advanced Customization' section. +#' +#' @param x Object created by a function from the gtsummary package +#' (e.g. [tbl_summary] or [tbl_regression]) +#' @param include Commands to include in output. Input may be a vector of +#' quoted or unquoted names. tidyselect and gtsummary select helper +#' functions are also accepted. +#' Default is `everything()`. +#' @param return_calls Logical. Default is `FALSE`. If `TRUE`, the calls are returned +#' as a list of expressions. +#' @param ... Arguments passed on to [gt::gt] +#' @return A `gt_tbl` object +#' @family gtsummary output types +#' @author Daniel D. Sjoberg +#' @export +#' @examples +#' # Example 1 ---------------------------------- +#' as_gt_ex1 <- +#' trial[c("trt", "age", "response", "grade")] %>% +#' tbl_summary(by = trt) %>% +#' as_gt() +#' @section Example Output: +#' +#' \if{html}{Example 1} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "as_gt_ex1.png", width = "50")` +#' }} + +as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { + .assert_class(x, "gtsummary") + + # running pre-conversion function, if present -------------------------------- + x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) + + # merging column specified in `x$table_styling$cols_merge` ------------------- + # UPDATE THIS WHEN `gt::cols_merge(rows=)` argument is added! + x <- .table_styling_cols_merge(x) + + # converting row specifications to row numbers, and removing old cmds -------- + x <- .table_styling_expr_to_row_number(x) + + # creating list of gt calls -------------------------------------------------- + gt_calls <- table_styling_to_gt_calls(x = x, ...) + + # adding user-specified calls ------------------------------------------------ + insert_expr_after <- get_theme_element("as_gt-lst:addl_cmds") + gt_calls <- + purrr::reduce( + .x = seq_along(insert_expr_after), + .f = function(x, y) { + add_expr_after( + calls = x, + add_after = names(insert_expr_after[y]), + expr = insert_expr_after[[y]], + new_name = paste0("user_added", y) + ) + }, + .init = gt_calls + ) + + # converting to character vector --------------------------------------------- + include <- + .select_to_varnames( + select = {{ include }}, + var_info = names(gt_calls), + arg_name = "include" + ) + + # user cannot omit the first 'gt' command + include <- "gt" %>% union(include) + + # return calls, if requested ------------------------------------------------- + if (return_calls == TRUE) { + return(gt_calls[include]) + } + + # taking each gt function call, concatenating them with %>% separating them + gt_calls[include] %>% + c(parse_expr(.get_deprecated_option("gtsummary.as_gt.addl_cmds", default = "NULL"))) %>% + .eval_list_of_exprs() +} + +# creating gt calls from table_styling ----------------------------------------- +table_styling_to_gt_calls <- function(x, ...) { + gt_calls <- list() + + # gt ------------------------------------------------------------------------- + groupname_col <- + switch("groupname_col" %in% x$table_styling$header$column, + "groupname_col" + ) + caption <- + switch(!is.null(x$table_styling$caption), + rlang::call2( + attr(x$table_styling$caption, "text_interpret"), + x$table_styling$caption + ) + ) + gt_calls[["gt"]] <- + expr(gt::gt( + data = x$table_body, + groupname_col = !!groupname_col, + caption = !!caption, + !!!list(...) + )) + + # fmt_missing ---------------------------------------------------------------- + gt_calls[["fmt_missing"]] <- + expr( + gt::sub_missing(columns = gt::everything(), missing_text = "") + ) %>% + c( + map( + seq_len(nrow(x$table_styling$fmt_missing)), + ~ expr(gt::sub_missing( + columns = !!x$table_styling$fmt_missing$column[[.x]], + rows = !!x$table_styling$fmt_missing$row_numbers[[.x]], + missing_text = !!x$table_styling$fmt_missing$symbol[[.x]] + )) + ) + ) + + # cols_align ----------------------------------------------------------------- + df_cols_align <- + x$table_styling$header %>% + select("column", "align") %>% + group_by(.data$align) %>% + nest() %>% + mutate(cols = map(.data$data, ~ pull(.x, column))) + + gt_calls[["cols_align"]] <- + map( + seq_len(nrow(df_cols_align)), + ~ expr(gt::cols_align( + columns = !!df_cols_align$cols[[.x]], + align = !!df_cols_align$align[[.x]] + )) + ) + + # indent --------------------------------------------------------------------- + df_indent <- x$table_styling$text_format %>% filter(.data$format_type == "indent") + gt_calls[["indent"]] <- + map( + seq_len(nrow(df_indent)), + ~ expr(gt::text_transform( + locations = gt::cells_body( + columns = !!df_indent$column[[.x]], + rows = !!df_indent$row_numbers[[.x]] + ), + fn = function(x) paste0("\U00A0\U00A0\U00A0\U00A0", x) + )) + ) + + # indent2 -------------------------------------------------------------------- + df_indent2 <- x$table_styling$text_format %>% filter(.data$format_type == "indent2") + gt_calls[["indent2"]] <- + map( + seq_len(nrow(df_indent2)), + ~ expr(gt::text_transform( + locations = gt::cells_body( + columns = !!df_indent2$column[[.x]], + rows = !!df_indent2$row_numbers[[.x]] + ), + fn = function(x) paste0("\U00A0\U00A0\U00A0\U00A0\U00A0\U00A0\U00A0\U00A0", x) + )) + ) + + # fmt ------------------------------------------------------------------------ + gt_calls[["fmt"]] <- + map( + seq_len(nrow(x$table_styling$fmt_fun)), + ~ expr(gt::fmt( + columns = !!x$table_styling$fmt_fun$column[[.x]], + rows = !!x$table_styling$fmt_fun$row_numbers[[.x]], + fns = !!x$table_styling$fmt_fun$fmt_fun[[.x]] + )) + ) + + # tab_style_bold ------------------------------------------------------------- + df_bold <- x$table_styling$text_format %>% filter(.data$format_type == "bold") + gt_calls[["tab_style_bold"]] <- + map( + seq_len(nrow(df_bold)), + ~ expr(gt::tab_style( + style = gt::cell_text(weight = "bold"), + locations = gt::cells_body( + columns = !!df_bold$column[[.x]], + rows = !!df_bold$row_numbers[[.x]] + ) + )) + ) + + # tab_style_italic ----------------------------------------------------------- + df_italic <- x$table_styling$text_format %>% filter(.data$format_type == "italic") + gt_calls[["tab_style_italic"]] <- + map( + seq_len(nrow(df_italic)), + ~ expr(gt::tab_style( + style = gt::cell_text(style = "italic"), + locations = gt::cells_body( + columns = !!df_italic$column[[.x]], + rows = !!df_italic$row_numbers[[.x]] + ) + )) + ) + + # cols_label ----------------------------------------------------------------- + gt_calls[["cols_label"]] <- + map2( + x$table_styling$header$interpret_label, + x$table_styling$header$label, + ~ call2(parse_expr(.x), .y) + ) %>% + set_names(x$table_styling$header$column) %>% + { + call2(expr(gt::cols_label), !!!.) + } + + # tab_footnote --------------------------------------------------------------- + if (nrow(x$table_styling$footnote) == 0 && + nrow(x$table_styling$footnote_abbrev) == 0) { + gt_calls[["tab_footnote"]] <- list() + } else { + df_footnotes <- + bind_rows( + x$table_styling$footnote, + x$table_styling$footnote_abbrev + ) %>% + nest(data = c("column", "row_numbers")) %>% + rowwise() %>% + mutate( + columns = .data$data %>% pull("column") %>% unique() %>% list(), + rows = .data$data %>% pull("row_numbers") %>% unique() %>% list() + ) %>% + ungroup() + df_footnotes$footnote_exp <- + map2( + df_footnotes$text_interpret, + df_footnotes$footnote, + ~ call2(parse_expr(.x), .y) + ) + + + gt_calls[["tab_footnote"]] <- + pmap( + list( + df_footnotes$tab_location, df_footnotes$footnote_exp, + df_footnotes$columns, df_footnotes$rows + ), + function(tab_location, footnote, columns, rows) { + if (tab_location == "header") { + return(expr( + gt::tab_footnote( + footnote = !!footnote, + locations = gt::cells_column_labels(columns = !!columns) + ) + )) + } + if (tab_location == "body") { + return(expr( + gt::tab_footnote( + footnote = !!footnote, + locations = gt::cells_body(columns = !!columns, rows = !!rows) + ) + )) + } + } + ) + } + + # spanning_header ------------------------------------------------------------ + df_spanning_header <- + x$table_styling$header %>% + select("column", "interpret_spanning_header", "spanning_header") %>% + filter(!is.na(.data$spanning_header)) %>% + nest(cols = "column") %>% + mutate( + spanning_header = map2( + .data$interpret_spanning_header, .data$spanning_header, + ~ call2(parse_expr(.x), .y) + ), + cols = map(.data$cols, ~ pull(.x)) + ) %>% + select("spanning_header", "cols") + + gt_calls[["tab_spanner"]] <- + map( + seq_len(nrow(df_spanning_header)), + ~ expr(gt::tab_spanner( + columns = !!df_spanning_header$cols[[.x]], + label = gt::md(!!df_spanning_header$spanning_header[[.x]]), + gather = FALSE + )) + ) + + # horizontal_line ------------------------------------------------------------ + if (!is.null(x$table_styling$horizontal_line_above)) { + gt_calls[["horizontal_line"]] <- + expr( + gt::tab_style( + style = gt::cell_borders(sides = "top", color = "#D3D3D3", weight = gt::px(2)), + locations = gt::cells_body(rows = !!x$table_styling$horizontal_line_above) + ) + ) + } + + # tab_source_note ----------------------------------------------------------- + # adding other calls from x$table_styling$source_note + if (!is.null(x$table_styling$source_note)) { + source_note <- + rlang::call2(attr(x$table_styling$source_note, "text_interpret"), x$table_styling$source_note) + gt_calls[["tab_source_note"]] <- expr(gt::tab_source_note(source_note = !!source_note)) + } + + # cols_hide ------------------------------------------------------------------ + gt_calls[["cols_hide"]] <- + names(x$table_body) %>% + setdiff(.cols_to_show(x)) %>% + { + .purrr_when( + rlang::is_empty(.) ~ NULL, + TRUE ~ expr(gt::cols_hide(columns = !!.)) + ) + } + + # return list of gt expressions + gt_calls +} diff --git a/R/as_hux_table.R b/_archive/R/as_hux_table.R similarity index 100% rename from R/as_hux_table.R rename to _archive/R/as_hux_table.R diff --git a/R/as_kable.R b/_archive/R/as_kable.R similarity index 100% rename from R/as_kable.R rename to _archive/R/as_kable.R diff --git a/R/as_kable_extra.R b/_archive/R/as_kable_extra.R similarity index 100% rename from R/as_kable_extra.R rename to _archive/R/as_kable_extra.R diff --git a/R/as_tibble.R b/_archive/R/as_tibble.R similarity index 100% rename from R/as_tibble.R rename to _archive/R/as_tibble.R diff --git a/R/assert_package.R b/_archive/R/assert_package.R similarity index 100% rename from R/assert_package.R rename to _archive/R/assert_package.R diff --git a/R/bold_italicise_labels_levels.R b/_archive/R/bold_italicise_labels_levels.R similarity index 100% rename from R/bold_italicise_labels_levels.R rename to _archive/R/bold_italicise_labels_levels.R diff --git a/R/bold_p.R b/_archive/R/bold_p.R similarity index 100% rename from R/bold_p.R rename to _archive/R/bold_p.R diff --git a/R/combine_terms.R b/_archive/R/combine_terms.R similarity index 100% rename from R/combine_terms.R rename to _archive/R/combine_terms.R diff --git a/R/custom_tidiers.R b/_archive/R/custom_tidiers.R similarity index 100% rename from R/custom_tidiers.R rename to _archive/R/custom_tidiers.R diff --git a/R/data.R b/_archive/R/data.R similarity index 100% rename from R/data.R rename to _archive/R/data.R diff --git a/R/deprecated.R b/_archive/R/deprecated.R similarity index 100% rename from R/deprecated.R rename to _archive/R/deprecated.R diff --git a/_archive/R/gtsummary-package.R b/_archive/R/gtsummary-package.R new file mode 100644 index 0000000000..34ac0d04e1 --- /dev/null +++ b/_archive/R/gtsummary-package.R @@ -0,0 +1,41 @@ +#' @importFrom dplyr mutate select n group_by ungroup filter pull case_when +#' if_else full_join left_join distinct bind_rows count coalesce arrange rename +#' rename_at bind_cols mutate_all mutate_at slice desc rowwise inner_join +#' row_number +#' @importFrom purrr map imap map2 pmap map_chr map_dfr map_lgl map_dbl map_if +#' imap_dfr imap_lgl map2_chr pmap_lgl pmap_chr pmap_dbl compact keep discard +#' every some pluck flatten negate partial cross_df reduce chuck +#' @importFrom tidyr nest unnest complete spread +#' @importFrom tibble tibble tribble as_tibble enframe deframe +#' @importFrom rlang .data .env %||% set_names sym syms parse_expr expr exprs +#' call2 := inform abort is_function is_string enexpr inject is_empty +#' is_function is_list is_named is_character check_dots_empty +#' quo_is_null enquo eval_tidy quo_text +#' @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 +#' str_sub +#' @importFrom broom.helpers .formula_list_to_named_list .select_to_varnames +#' .generic_selector +#' @importFrom cli cli_alert_info cli_alert_danger cli_code cli_ul +#' @importFrom gt md html +#' @keywords internal +"_PACKAGE" + +# allowing for the use of the dot when piping +utils::globalVariables(".") + +## usethis namespace: start +#' @importFrom lifecycle deprecate_soft +## usethis namespace: end +NULL + +release_bullets <- function() { + c( + "Check the output from `devtools::check()` and look for warnings or messages", + "Review deprecation schedule", + "Run the code styler", + "Updated the gt help file images", + "Check build size is less than 5MB" + ) +} diff --git a/R/inline_text.R b/_archive/R/inline_text.R similarity index 100% rename from R/inline_text.R rename to _archive/R/inline_text.R diff --git a/R/modify.R b/_archive/R/modify.R similarity index 100% rename from R/modify.R rename to _archive/R/modify.R diff --git a/R/modify_column_alignment.R b/_archive/R/modify_column_alignment.R similarity index 100% rename from R/modify_column_alignment.R rename to _archive/R/modify_column_alignment.R diff --git a/_archive/R/modify_column_hide.R b/_archive/R/modify_column_hide.R new file mode 100644 index 0000000000..6badc4dd9d --- /dev/null +++ b/_archive/R/modify_column_hide.R @@ -0,0 +1,59 @@ +#' Modify Hidden Columns +#' +#' \lifecycle{maturing} +#' Use these functions to hide or unhide columns in a gtsummary table. +#' +#' @inheritParams modify_table_styling +#' +#' @name modify_column_hide +#' @family Advanced modifiers +#' @examples +#' \donttest{ +#' # Example 1 ---------------------------------- +#' # hide 95% CI, and replace with standard error +#' modify_column_hide_ex1 <- +#' lm(age ~ marker + grade, trial) %>% +#' tbl_regression() %>% +#' modify_column_hide(columns = ci) %>% +#' modify_column_unhide(columns = std.error) +#' } +#' @section Example Output: +#' \if{html}{Example 1} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "modify_column_hide_ex1.png", width = "45")` +#' }} +NULL + +#' @rdname modify_column_hide +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @export +modify_column_hide <- function(x, columns) { + .assert_class(x, "gtsummary") + updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) + x <- + modify_table_styling( + x = x, + columns = {{ columns }}, + hide = TRUE + ) + + x$call_list <- updated_call_list + x +} + +#' @rdname modify_column_hide +#' @export +modify_column_unhide <- function(x, columns) { + .assert_class(x, "gtsummary") + updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) + x <- + modify_table_styling( + x = x, + columns = {{ columns }}, + hide = FALSE + ) + + x$call_list <- updated_call_list + x +} diff --git a/R/modify_column_indent.R b/_archive/R/modify_column_indent.R similarity index 100% rename from R/modify_column_indent.R rename to _archive/R/modify_column_indent.R diff --git a/R/modify_column_merge.R b/_archive/R/modify_column_merge.R similarity index 100% rename from R/modify_column_merge.R rename to _archive/R/modify_column_merge.R diff --git a/R/modify_fmt_fun.R b/_archive/R/modify_fmt_fun.R similarity index 100% rename from R/modify_fmt_fun.R rename to _archive/R/modify_fmt_fun.R diff --git a/R/modify_table_body.R b/_archive/R/modify_table_body.R similarity index 100% rename from R/modify_table_body.R rename to _archive/R/modify_table_body.R diff --git a/R/modify_table_header.R b/_archive/R/modify_table_header.R similarity index 100% rename from R/modify_table_header.R rename to _archive/R/modify_table_header.R diff --git a/_archive/R/modify_table_styling.R b/_archive/R/modify_table_styling.R new file mode 100644 index 0000000000..f10456a3c7 --- /dev/null +++ b/_archive/R/modify_table_styling.R @@ -0,0 +1,313 @@ +#' Modify Table Styling +#' +#' This is a function meant for advanced users to gain +#' more control over the characteristics of the resulting +#' gtsummary table by directly modifying `.$table_styling` +#' +#' Review the +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition} +#' vignette for information on `.$table_styling` objects. +#' +#' @param x gtsummary object +#' @param columns vector or selector of columns in `x$table_body` +#' @param rows predicate expression to select rows in `x$table_body`. +#' Can be used to style footnote, formatting functions, missing symbols, +#' and text formatting. Default is `NULL`. See details below. +#' @param label string of column label(s) +#' @param hide logical indicating whether to hide column from output +#' @param align string indicating alignment of column, must be one of +#' `c("left", "right", "center")` +#' @param text_format string indicated which type of text formatting to apply to the rows and columns. +#' Must be one of `c("bold", "italic", "indent", "indent2")`. Do not assign +#' both `"indent"` and `"indent2"` to the same cell. +#' @param text_interpret string, must be one of `"md"` or `"html"` +#' @param fmt_fun function that formats the statistics in the +#' columns/rows in `columns=` and `rows=` +#' @param footnote_abbrev string with abbreviation definition, e.g. +#' `"CI = Confidence Interval"` +#' @param footnote string with text for footnote +#' @param spanning_header string with text for spanning header +#' @param missing_symbol string indicating how missing values are formatted. +#' @param undo_text_format rarely used. Logical that undoes the indent, bold, +#' and italic styling when `TRUE` +#' @param cols_merge_pattern \lifecycle{experimental} glue-syntax string +#' indicating how to merge +#' columns in `x$table_body`. For example, to construct a confidence interval +#' use `"{conf.low}, {conf.high}"`. The first column listed in the pattern +#' string must match the single column name passed in `columns=`. +#' +#' @seealso `modify_table_body()` +#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @export +#' @family Advanced modifiers +#' +#' @section rows argument: +#' The rows argument accepts a predicate expression that is used to specify +#' rows to apply formatting. The expression must evaluate to a logical when +#' evaluated in `x$table_body`. For example, to apply formatting to the age rows +#' pass `rows = variable == "age"`. A vector of row numbers is NOT acceptable. +#' +#' A couple of things to note when using the `rows=` argument. +#' 1. You can use saved objects to create the predicate argument, e.g. +#' `rows = variable == letters[1]`. +#' 2. The saved object cannot share a name with a column in `x$table_body`. +#' The reason for this is that in `tbl_merge()` the columns are renamed, +#' and the renaming process cannot disambiguate the `variable` column from +#' an external object named `variable` in the following expression +#' `rows = .data$variable = .env$variable`. +#' +#' @section cols_merge_pattern argument: +#' +#' There are planned updates to the implementation of column merging. +#' Currently, this function replaces the numeric column with a +#' formatted character column following `cols_merge_pattern=`. +#' Once `gt::cols_merge()` gains the `rows=` argument the +#' implementation will be updated to use it, which will keep +#' numeric columns numeric. For the _vast majority_ of users, +#' _the planned change will be go unnoticed_. +#' +#' If this functionality is used in conjunction with `tbl_stack()` (which +#' includes `tbl_uvregression()`), there is potential issue with printing. +#' When columns are stack AND when the column-merging is +#' defined with a quosure, you may run into issues due to the loss of the +#' environment when 2 or more quosures are combined. If the expression +#' version of the quosure is the same as the quosure (i.e. no evaluated +#' objects), there should be no issues. Regardless, this argument is used +#' internally with care, and it is _not_ recommended for users. + + +modify_table_styling <- function(x, + columns, + rows = NULL, + label = NULL, + spanning_header = NULL, + hide = NULL, + footnote = NULL, + footnote_abbrev = NULL, + align = NULL, + missing_symbol = NULL, + fmt_fun = NULL, + text_format = NULL, + undo_text_format = FALSE, + text_interpret = c("md", "html"), + cols_merge_pattern = NULL) { + updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) + # checking inputs ------------------------------------------------------------ + .assert_class(x, "gtsummary") + + text_interpret <- match.arg(text_interpret) %>% + { + paste0("gt::", .) + } + if (!is.null(text_format)) { + text_format <- match.arg(text_format, + choices = c("bold", "italic", "indent", "indent2"), + several.ok = TRUE + ) + } + rows <- enquo(rows) + rows_eval_error <- + tryCatch( + eval_tidy(rows, data = x$table_body) %>% + { + !is.null(.) && !is.logical(.) + }, + error = function(e) TRUE + ) + if (rows_eval_error) { + abort("The `rows=` predicate expression must result in logical vector when evaluated with `x$table_body`") + } + + # update table_styling ------------------------------------------------------- + x <- .update_table_styling(x) + + # convert column input to string --------------------------------------------- + columns <- + .select_to_varnames( + select = {{ columns }}, + data = x$table_body, + arg_name = "columns" + ) + + # if no columns selected, returning unaltered + if (is.null(columns)) { + return(x) + } + + # label ---------------------------------------------------------------------- + if (!is.null(label)) { + x$table_styling$header <- + x$table_styling$header %>% + dplyr::rows_update( + tibble(column = columns, interpret_label = text_interpret, label = label), + by = "column" + ) + } + + # spanning_header ------------------------------------------------------------ + if (!is.null(spanning_header)) { + x$table_styling$header <- + x$table_styling$header %>% + dplyr::rows_update( + tibble(column = columns, interpret_label = text_interpret, spanning_header = spanning_header), + by = "column" + ) + } + + # hide ----------------------------------------------------------------------- + if (!is.null(hide)) { + x$table_styling$header <- + x$table_styling$header %>% + dplyr::rows_update( + tibble(column = columns, hide = hide), + by = "column" + ) + } + + # align ---------------------------------------------------------------------- + if (!is.null(align)) { + x$table_styling$header <- + x$table_styling$header %>% + dplyr::rows_update( + tibble(column = columns, align = align), + by = "column" + ) + } + + # footnote ------------------------------------------------------------------- + if (!is.null(footnote)) { + x$table_styling$footnote <- + bind_rows( + x$table_styling$footnote, + tibble( + column = columns, + rows = list(rows), + text_interpret = text_interpret, + footnote = footnote + ) + ) + } + + # footnote_abbrev ------------------------------------------------------------ + if (!is.null(footnote_abbrev)) { + x$table_styling$footnote_abbrev <- + bind_rows( + x$table_styling$footnote_abbrev, + tibble( + column = columns, + rows = list(rows), + text_interpret = text_interpret, + footnote = footnote_abbrev + ) + ) + } + + # fmt_fun -------------------------------------------------------------------- + if (!is.null(fmt_fun)) { + if (rlang::is_function(fmt_fun)) fmt_fun <- list(fmt_fun) + x$table_styling$fmt_fun <- + bind_rows( + x$table_styling$fmt_fun, + tibble( + column = columns, + rows = list(rows), + fmt_fun = fmt_fun + ) + ) + } + + # text_format ---------------------------------------------------------------- + if (!is.null(text_format)) { + x$table_styling$text_format <- + list( + column = columns, + rows = list(rows), + format_type = text_format, + undo_text_format = undo_text_format + ) %>% + { + tidyr::expand_grid(!!!.) + } %>% + { + bind_rows(x$table_styling$text_format, .) + } + } + + # missing_symbol ------------------------------------------------------------- + if (!is.null(missing_symbol)) { + x$table_styling$fmt_missing <- + list( + column = columns, + rows = list(rows), + symbol = missing_symbol + ) %>% + { + tidyr::expand_grid(!!!.) + } %>% + { + bind_rows(x$table_styling$fmt_missing, .) + } + } + + # cols_merge_pattern --------------------------------------------------------- + if (!is.null(cols_merge_pattern)) { + x <- + .modify_cols_merge( + x, + column = columns, + rows = !!rows, + pattern = cols_merge_pattern + ) + } + + # return x ------------------------------------------------------------------- + x$call_list <- updated_call_list + x +} + + +# function to add merging columns instructions +.modify_cols_merge <- function(x, column, rows, pattern) { + rows <- enquo(rows) + all_columns <- + str_extract_all(pattern, "\\{.*?\\}") %>% + map(~ str_remove_all(.x, pattern = fixed("}"))) %>% + map(~ str_remove_all(.x, pattern = fixed("{"))) %>% + unlist() + + if (!is.na(pattern) && !all(all_columns %in% x$table_styling$header$column)) { + paste( + "All columns specified in `cols_merge_pattern=`", + "must be present in `x$table_body`" + ) %>% + abort() + } + + if (!is.na(pattern) && !identical(column, all_columns[1])) { + paste( + "A single column must be passed when using `cols_merge_pattern=`,", + "and that column must be the first to appear in the pattern argument." + ) %>% + abort() + } + + x$table_styling$cols_merge <- + x$table_styling$cols_merge %>% + # remove previous merging for specified column + filter(!.data$column %in% .env$column) %>% + # append new merge instructions + bind_rows( + tibble( + column = column, + rows = list(rows), + pattern = pattern + ) + ) + + # hiding all but the first column + x <- modify_column_hide(x, columns = all_columns[-1]) + + # return gtsummary table + x +} diff --git a/R/plot.R b/_archive/R/plot.R similarity index 100% rename from R/plot.R rename to _archive/R/plot.R diff --git a/_archive/R/print.R b/_archive/R/print.R new file mode 100644 index 0000000000..ef0aee8123 --- /dev/null +++ b/_archive/R/print.R @@ -0,0 +1,118 @@ +#' print and knit_print methods for gtsummary objects +#' +#' @name print_gtsummary +#' @keywords internal +#' @param x An object created using gtsummary functions +#' @param print_engine String indicating the print method. Must be one of +#' `"gt"`, `"kable"`, `"kable_extra"`, `"flextable"`, `"tibble"` +#' @param ... Not used +#' @author Daniel D. Sjoberg +#' @seealso [tbl_summary] [tbl_regression] [tbl_uvregression] [tbl_merge] [tbl_stack] +NULL + +#' @rdname print_gtsummary +#' @export +print.gtsummary <- function(x, print_engine = NULL, ...) { + check_dots_empty(error = function(e) inform(c(e$message, e$body))) + # select print engine + print_engine <- + print_engine %||% + .get_deprecated_option("gtsummary.print_engine") %||% + get_theme_element("pkgwide-str:print_engine") %||% + "gt" # default printer is gt + + # checking engine + accepted_print_engines <- + c("gt", "kable", "kable_extra", "flextable", "huxtable", "tibble") + if (!rlang::is_string(print_engine) || !print_engine %in% accepted_print_engines) { + stop(glue( + "Select a valid print engine. ", + "Please select one of {quoted_list(accepted_print_engines)}" + )) + } + + # printing results + switch(print_engine, + "gt" = as_gt(x), + "kable" = as_kable(x), + "flextable" = as_flex_table(x), + "kable_extra" = as_kable_extra(x), + "huxtable" = as_hux_table(x), + "tibble" = as_tibble(x) + ) %>% + print() +} + +#' @rdname print_gtsummary +#' @export +knit_print.gtsummary <- function(x, ...) { + # assigning print engine ----------------------------------------------------- + # select print engine + print_engine <- + .get_deprecated_option("gtsummary.print_engine") %||% + get_theme_element("pkgwide-str:print_engine") + + # gt is the default printer for html output + if (is.null(print_engine) && knitr::is_html_output() == TRUE) { + print_engine <- "gt" + } + + # PDF uses kable as default printer (is_latex_output catches pdf_document and beamer...maybe more?) + else if (is.null(print_engine) && knitr::is_latex_output() == TRUE) { + rlang::inform(paste( + "Table printed with `knitr::kable()`, not {gt}. Learn why at", + "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", + "To suppress this message, include `message = FALSE` in code chunk header.", + sep = "\n" + )) + print_engine <- "kable" + } + + # don't use word_document with gt engine + else if (identical(print_engine %||% "gt", "gt") && + "docx" %in% knitr::opts_knit$get("rmarkdown.pandoc.to")) { + if (assert_package("flextable", boolean = TRUE)) { + rlang::inform(paste( + "Table printed with {flextable}, not {gt}. Learn why at", + "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", + "To suppress this message, include `message = FALSE` in the code chunk header.", + sep = "\n" + )) + print_engine <- "flextable" + } else { + rlang::inform(paste( + "Table printed with `knitr::kable()`, not {gt}. Learn why at", + "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", + "To suppress this message, include `message = FALSE` in the code chunk header.", + sep = "\n" + )) + print_engine <- "kable" + } + } + + # RTF warning when using gt + else if (identical(print_engine %||% "gt", "gt") && + "rtf" %in% knitr::opts_knit$get("rmarkdown.pandoc.to")) { + rlang::inform(paste( + "Table printed with `knitr::kable()`, not {gt}. Learn why at", + "https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html", + "To suppress this message, include `message = FALSE` in code chunk header.", + sep = "\n" + )) + print_engine <- "kable" + } + + # all other types (if any), will attempt to print with gt + else if (is.null(print_engine)) print_engine <- "gt" + + # printing gtsummary table with appropriate engine + switch(print_engine, + "gt" = as_gt(x), + "kable" = as_kable(x), + "flextable" = as_flex_table(x), + "kable_extra" = as_kable_extra(x), + "huxtable" = as_hux_table(x), + "tibble" = as_tibble(x) + ) %>% + knitr::knit_print() +} diff --git a/_archive/R/reexport.R b/_archive/R/reexport.R new file mode 100644 index 0000000000..c6c96d3a15 --- /dev/null +++ b/_archive/R/reexport.R @@ -0,0 +1,66 @@ +# tibble ----------------------------------------------------------------------- +#' @export +#' @importFrom tibble as_tibble +tibble::as_tibble + +# knitr ------------------------------------------------------------------------ +#' @export +#' @importFrom knitr knit_print +knitr::knit_print + +# dplyr ------------------------------------------------------------------------ +#' @export +#' @importFrom dplyr %>% +dplyr::`%>%` + +#' @importFrom dplyr vars +#' @export +dplyr::vars + +#' @importFrom dplyr select +#' @export +dplyr::select + +#' @importFrom dplyr mutate +#' @export +dplyr::mutate + +#' @importFrom dplyr starts_with +#' @export +dplyr::starts_with + +#' @importFrom dplyr ends_with +#' @export +dplyr::ends_with + +#' @importFrom dplyr contains +#' @export +dplyr::contains + +#' @importFrom dplyr matches +#' @export +dplyr::matches + +#' @importFrom dplyr num_range +#' @export +dplyr::num_range + +#' @importFrom dplyr all_of +#' @export +dplyr::all_of + +#' @importFrom dplyr any_of +#' @export +dplyr::any_of + +#' @importFrom dplyr everything +#' @export +dplyr::everything + +#' @importFrom dplyr last_col +#' @export +dplyr::last_col + +#' @importFrom dplyr one_of +#' @export +dplyr::one_of diff --git a/R/remove_row_type.R b/_archive/R/remove_row_type.R similarity index 100% rename from R/remove_row_type.R rename to _archive/R/remove_row_type.R diff --git a/_archive/R/select_helpers.R b/_archive/R/select_helpers.R new file mode 100644 index 0000000000..84ef2bc720 --- /dev/null +++ b/_archive/R/select_helpers.R @@ -0,0 +1,124 @@ +#' Select helper functions +#' +#' @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_tests()` selects variables by the name of the test performed +#' - `all_stat_cols()` selects columns from `tbl_summary`/`tbl_svysummary` object with summary statistics (i.e. `"stat_0"`, `"stat_1"`, `"stat_2"`, etc.) +#' - `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 +#' @param tests string indicating the test type of the variables to select, e.g. +#' select all variables being compared with `"t.test"` +#' @param stat_0 When `FALSE`, will not select the `"stat_0"` column. Default is `TRUE` +#' @param continuous2 Logical indicating whether to include continuous2 variables. Default is `TRUE` +#' @param dichotomous Logical indicating whether to include dichotomous variables. +#' Default is `TRUE` +#' @param contrasts_type type of contrast to select. When `NULL`, all variables with a +#' contrast will be selected. Default is `NULL`. Select among contrast types +#' `c("treatment", "sum", "poly", "helmert", "other")` +#' @name select_helpers +#' @return A character vector of column names selected +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @examples +#' select_ex1 <- +#' trial %>% +#' select(age, response, grade) %>% +#' tbl_summary( +#' statistic = all_continuous() ~ "{mean} ({sd})", +#' type = all_dichotomous() ~ "categorical" +#' ) +#' @section Example Output: +#' \if{html}{Example 1} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "select_ex1.png", width = "55")` +#' }} +NULL + +#' @rdname select_helpers +#' @export +all_continuous <- function(continuous2 = TRUE) { + if (continuous2 == TRUE) { + return(broom.helpers::all_continuous()) + } else { + return( + .generic_selector("variable", "var_type", + .data$var_type %in% "continuous", + fun_name = "all_continuous" + ) + ) + } +} + +#' @rdname select_helpers +#' @export +all_continuous2 <- function() { + .generic_selector("variable", "var_type", + .data$var_type %in% "continuous2", + fun_name = "all_continuous" + ) +} + +#' @rdname select_helpers +#' @export +all_categorical <- broom.helpers::all_categorical + +#' @rdname select_helpers +#' @export +all_dichotomous <- broom.helpers::all_dichotomous + +#' @rdname select_helpers +#' @export +all_tests <- function(tests = NULL) { + if (is.null(tests) || !is.character(tests) || any(!tests %in% df_add_p_tests$test_name)) { + paste( + "The `tests=` argument must be one or more of the following:", + paste(shQuote(df_add_p_tests$test_name), collapse = ", ") + ) %>% + stop(call. = FALSE) + } + + .generic_selector("variable", "test_name", + .data$test_name %in% .env$tests, + fun_name = "all_tests" + ) +} + +#' @rdname select_helpers +#' @export +all_stat_cols <- function(stat_0 = TRUE) { + # finds stat_0, stat_1, stat_2, etc. + if (stat_0 == TRUE) { + return( + union( + dplyr::matches("^stat_\\d+$"), + dplyr::matches("^stat_\\d+_.*$") + ) + ) + } + # finds stat_1, stat_2, etc. + if (stat_0 == FALSE) { + return( + union( + dplyr::matches("^stat_\\d*[1-9]\\d*$"), + dplyr::matches("^stat_\\d*[1-9]\\d*_.*$") + ) + ) + } +} + +#' @rdname select_helpers +#' @export +all_interaction <- broom.helpers::all_interaction + +#' @rdname select_helpers +#' @export +all_intercepts <- broom.helpers::all_intercepts + +#' @rdname select_helpers +#' @export +all_contrasts <- broom.helpers::all_contrasts diff --git a/R/separate_p_footnotes.R b/_archive/R/separate_p_footnotes.R similarity index 100% rename from R/separate_p_footnotes.R rename to _archive/R/separate_p_footnotes.R diff --git a/R/set_gtsummary_theme.R b/_archive/R/set_gtsummary_theme.R similarity index 100% rename from R/set_gtsummary_theme.R rename to _archive/R/set_gtsummary_theme.R diff --git a/R/sort_filter_p.R b/_archive/R/sort_filter_p.R similarity index 100% rename from R/sort_filter_p.R rename to _archive/R/sort_filter_p.R diff --git a/R/style_number.R b/_archive/R/style_number.R similarity index 100% rename from R/style_number.R rename to _archive/R/style_number.R diff --git a/R/style_percent.R b/_archive/R/style_percent.R similarity index 100% rename from R/style_percent.R rename to _archive/R/style_percent.R diff --git a/R/style_pvalue.R b/_archive/R/style_pvalue.R similarity index 100% rename from R/style_pvalue.R rename to _archive/R/style_pvalue.R diff --git a/R/style_ratio.R b/_archive/R/style_ratio.R similarity index 100% rename from R/style_ratio.R rename to _archive/R/style_ratio.R diff --git a/R/style_sigfig.R b/_archive/R/style_sigfig.R similarity index 100% rename from R/style_sigfig.R rename to _archive/R/style_sigfig.R diff --git a/R/syntax.R b/_archive/R/syntax.R similarity index 100% rename from R/syntax.R rename to _archive/R/syntax.R diff --git a/R/sysdata.rda b/_archive/R/sysdata.rda similarity index 100% rename from R/sysdata.rda rename to _archive/R/sysdata.rda diff --git a/R/tbl_butcher.R b/_archive/R/tbl_butcher.R similarity index 100% rename from R/tbl_butcher.R rename to _archive/R/tbl_butcher.R diff --git a/R/tbl_continuous.R b/_archive/R/tbl_continuous.R similarity index 100% rename from R/tbl_continuous.R rename to _archive/R/tbl_continuous.R diff --git a/R/tbl_cross.R b/_archive/R/tbl_cross.R similarity index 100% rename from R/tbl_cross.R rename to _archive/R/tbl_cross.R diff --git a/R/tbl_custom_summary.R b/_archive/R/tbl_custom_summary.R similarity index 100% rename from R/tbl_custom_summary.R rename to _archive/R/tbl_custom_summary.R diff --git a/R/tbl_merge.R b/_archive/R/tbl_merge.R similarity index 100% rename from R/tbl_merge.R rename to _archive/R/tbl_merge.R diff --git a/R/tbl_regression.R b/_archive/R/tbl_regression.R similarity index 100% rename from R/tbl_regression.R rename to _archive/R/tbl_regression.R diff --git a/R/tbl_regression_methods.R b/_archive/R/tbl_regression_methods.R similarity index 100% rename from R/tbl_regression_methods.R rename to _archive/R/tbl_regression_methods.R diff --git a/R/tbl_split.R b/_archive/R/tbl_split.R similarity index 100% rename from R/tbl_split.R rename to _archive/R/tbl_split.R diff --git a/R/tbl_stack.R b/_archive/R/tbl_stack.R similarity index 100% rename from R/tbl_stack.R rename to _archive/R/tbl_stack.R diff --git a/R/tbl_strata.R b/_archive/R/tbl_strata.R similarity index 100% rename from R/tbl_strata.R rename to _archive/R/tbl_strata.R diff --git a/_archive/R/tbl_summary.R b/_archive/R/tbl_summary.R new file mode 100644 index 0000000000..d15a514938 --- /dev/null +++ b/_archive/R/tbl_summary.R @@ -0,0 +1,484 @@ +#' Create a table of summary statistics +#' +#' The `tbl_summary` function calculates descriptive statistics for +#' continuous, categorical, and dichotomous variables. Review the +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} +#' for detailed examples. +#' +#' @param data A data frame +#' @param by A column name (quoted or unquoted) in `data`. +#' Summary statistics will be calculated separately for each level of the `by` +#' variable (e.g. `by = trt`). If `NULL`, summary statistics +#' are calculated using all observations. To stratify a table by two or more +#' variables, use `tbl_strata()` +#' @param label List of formulas specifying variables labels, +#' e.g. `list(age ~ "Age", stage ~ "Path T Stage")`. If a +#' variable's label is not specified here, the label attribute +#' (`attr(data$age, "label")`) is used. If +#' attribute label is `NULL`, the variable name will be used. +#' @param type List of formulas specifying variable types. Accepted values +#' are `c("continuous", "continuous2", "categorical", "dichotomous")`, +#' e.g. `type = list(age ~ "continuous", female ~ "dichotomous")`. +#' If type not specified for a variable, the function +#' will default to an appropriate summary type. See below for details. +#' @param value List of formulas specifying the value to display for dichotomous +#' variables. gtsummary selectors, e.g. `all_dichotomous()`, cannot be used +#' with this argument. See below for details. +#' @param statistic List of formulas specifying types of summary statistics to +#' display for each variable. The default is +#' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. +#' See below for details. +#' @param digits List of formulas specifying the number of decimal +#' places to round summary statistics. If not specified, +#' `tbl_summary` guesses an appropriate number of decimals to round statistics. +#' When multiple statistics are displayed for a single variable, supply a vector +#' rather than an integer. For example, if the +#' statistic being calculated is `"{mean} ({sd})"` and you want the mean rounded +#' to 1 decimal place, and the SD to 2 use `digits = list(age ~ c(1, 2))`. User +#' may also pass a styling function: `digits = age ~ style_sigfig` +#' @param missing Indicates whether to include counts of `NA` values in the table. +#' Allowed values are `"no"` (never display NA values), +#' `"ifany"` (only display if any NA values), and `"always"` +#' (includes NA count row for all variables). Default is `"ifany"`. +#' @param missing_text String to display for count of missing observations. +#' Default is `"Unknown"`. +#' @param sort List of formulas specifying the type of sorting to perform for +#' categorical data. Options are `frequency` where results are sorted in +#' descending order of frequency and `alphanumeric`, +#' e.g. `sort = list(everything() ~ "frequency")` +#' @param percent Indicates the type of percentage to return. Must be one of +#' `"column"`, `"row"`, or `"cell"`. Default is `"column"`. +#' @param include variables to include in the summary table. Default is `everything()` +#' +#' @section select helpers: +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#select_helpers}{Select helpers} +#' from the \\{tidyselect\\} package and \\{gtsummary\\} package are available to +#' modify default behavior for groups of variables. +#' For example, by default continuous variables are reported with the median +#' and IQR. To change all continuous variables to mean and standard deviation use +#' `statistic = list(all_continuous() ~ "{mean} ({sd})")`. +#' +#' All columns with class logical are displayed as dichotomous variables showing +#' the proportion of events that are `TRUE` on a single row. To show both rows +#' (i.e. a row for `TRUE` and a row for `FALSE`) use +#' `type = list(where(is.logical) ~ "categorical")`. +#' +#' The select helpers are available for use in any argument that accepts a list +#' of formulas (e.g. `statistic`, `type`, `digits`, `value`, `sort`, etc.) +#' +#' Read more on the [syntax] used through the package. +#' +#' @section type argument: +#' The `tbl_summary()` function has four summary types: +#' - `"continuous"` summaries are shown on a *single row*. Most numeric +#' variables default to summary type continuous. +#' - `"continuous2"` summaries are shown on *2 or more rows* +#' - `"categorical"` *multi-line* summaries of nominal data. Character variables, +#' factor variables, and numeric variables with fewer than 10 unique levels default to +#' type categorical. To change a numeric variable to continuous that +#' defaulted to categorical, use `type = list(varname ~ "continuous")` +#' - `"dichotomous"` categorical variables that are displayed on a *single row*, +#' rather than one row per level of the variable. +#' Variables coded as `TRUE`/`FALSE`, `0`/`1`, or `yes`/`no` are assumed to be dichotomous, +#' and the `TRUE`, `1`, and `yes` rows are displayed. +#' Otherwise, the value to display must be specified in the `value` +#' argument, e.g. `value = list(varname ~ "level to show")` +#' +#' @section statistic argument: +#' The statistic argument specifies the statistics presented in the table. The +#' input is a list of formulas that specify the statistics to report. For example, +#' `statistic = list(age ~ "{mean} ({sd})")` would report the mean and +#' standard deviation for age; `statistic = list(all_continuous() ~ "{mean} ({sd})")` +#' would report the mean and standard deviation for all continuous variables. +#' A statistic name that appears between curly brackets +#' will be replaced with the numeric statistic (see [glue::glue]). +#' +#' For categorical variables the following statistics are available to display. +#' \itemize{ +#' \item `{n}` frequency +#' \item `{N}` denominator, or cohort size +#' \item `{p}` formatted percentage +#' } +#' For continuous variables the following statistics are available to display. +#' \itemize{ +#' \item `{median}` median +#' \item `{mean}` mean +#' \item `{sd}` standard deviation +#' \item `{var}` variance +#' \item `{min}` minimum +#' \item `{max}` maximum +#' \item `{sum}` sum +#' \item `{p##}` any integer percentile, where `##` is an integer from 0 to 100 +#' \item `{foo}` any function of the form `foo(x)` is accepted where `x` is a numeric vector +#' } +#' When the summary type is `"continuous2"`, pass a vector of statistics. Each element +#' of the vector will result in a separate row in the summary table. +#' +#' For both categorical and continuous variables, statistics on the number of +#' missing and non-missing observations and their proportions are available to +#' display. +#' \itemize{ +#' \item `{N_obs}` total number of observations +#' \item `{N_miss}` number of missing observations +#' \item `{N_nonmiss}` number of non-missing observations +#' \item `{p_miss}` percentage of observations missing +#' \item `{p_nonmiss}` percentage of observations not missing +#' } +#' +#' Note that for categorical variables, `{N_obs}`, `{N_miss}` and `{N_nonmiss}` refer +#' to the total number, number missing and number non missing observations +#' in the denominator, not at each level of the categorical variable. +#' +#' @export +#' @return A `tbl_summary` object +#' @family tbl_summary tools +#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial +#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @author Daniel D. Sjoberg +#' @examples +#' \donttest{ +#' # Example 1 ---------------------------------- +#' tbl_summary_ex1 <- +#' trial %>% +#' select(age, grade, response) %>% +#' tbl_summary() +#' +#' # Example 2 ---------------------------------- +#' tbl_summary_ex2 <- +#' trial %>% +#' select(age, grade, response, trt) %>% +#' tbl_summary( +#' by = trt, +#' label = list(age ~ "Patient Age"), +#' statistic = list(all_continuous() ~ "{mean} ({sd})"), +#' digits = list(age ~ c(0, 1)) +#' ) +#' +#' # Example 3 ---------------------------------- +#' # for convenience, you can also pass named lists to any arguments +#' # that accept formulas (e.g label, digits, etc.) +#' tbl_summary_ex3 <- +#' trial %>% +#' select(age, trt) %>% +#' tbl_summary( +#' by = trt, +#' label = list(age = "Patient Age") +#' ) +#' +#' # Example 4 ---------------------------------- +#' # multi-line summaries of continuous data with type 'continuous2' +#' tbl_summary_ex4 <- +#' trial %>% +#' select(age, marker) %>% +#' tbl_summary( +#' type = all_continuous() ~ "continuous2", +#' statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), +#' missing = "no" +#' ) +#' } +#' @section Example Output: +#' \if{html}{Example 1} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "tbl_summary_ex1.png", width = "31")` +#' }} +#' +#' \if{html}{Example 2} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "tbl_summary_ex2.png", width = "45")` +#' }} +#' +#' \if{html}{Example 3} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "tbl_summary_ex3.png", width = "45")` +#' }} +#' +#' \if{html}{Example 4} +#' +#' \if{html}{\out{ +#' `r man_create_image_tag(file = "tbl_summary_ex4.png", width = "31")` +#' }} + +tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, + digits = NULL, type = NULL, value = NULL, + missing = NULL, missing_text = NULL, sort = NULL, + percent = NULL, include = everything()) { + # ungrouping data ------------------------------------------------------------ + data <- data %>% ungroup() + + # eval ----------------------------------------------------------------------- + by <- + .select_to_varnames( + select = {{ by }}, + data = data, + arg_name = "by", + select_single = TRUE + ) + include <- + .select_to_varnames( + select = {{ include }}, + data = data, + arg_name = "include" + ) %>% + union(by) # include by variable by default + + # setting defaults from gtsummary theme -------------------------------------- + label <- label %||% get_theme_element("tbl_summary-arg:label") + statistic <- statistic %||% get_theme_element("tbl_summary-arg:statistic") + digits <- digits %||% get_theme_element("tbl_summary-arg:digits") + type <- type %||% get_theme_element("tbl_summary-arg:type") + value <- value %||% get_theme_element("tbl_summary-arg:value") + missing <- + missing %||% + get_theme_element("tbl_summary-arg:missing", default = "ifany") + missing_text <- + missing_text %||% + get_theme_element("tbl_summary-arg:missing_text", + default = translate_text("Unknown") + ) + sort <- sort %||% get_theme_element("tbl_summary-arg:sort") + percent <- percent %||% get_theme_element("tbl_summary-arg:percent", + default = "column" + ) + + # matching arguments --------------------------------------------------------- + missing <- match.arg(missing, choices = c("ifany", "always", "no")) + percent <- match.arg(percent, choices = c("column", "row", "cell")) + + # checking input data -------------------------------------------------------- + tbl_summary_data_checks(data) + + # deleting obs with missing by values ---------------------------------------- + # saving variable labels + if (!is.null(by) && sum(is.na(data[[by]])) > 0) { + message(glue( + "{sum(is.na(data[[by]]))} observations missing `{by}` have been removed. ", + "To include these observations, use `forcats::fct_na_value_to_level()` on `{by}` ", + "column before passing to `tbl_summary()`." + )) + + data <- filter(data, !is.na(.data[[by]])) + } + + # will return call, and all object passed to in tbl_summary call ------------- + # the object func_inputs is a list of every object passed to the function + tbl_summary_inputs <- as.list(environment()) + + # checking function inputs --------------------------------------------------- + tbl_summary_input_checks(data, by, missing_text, include) + + # generate meta_data -------------------------------------------------------- + meta_data <- generate_metadata( + data = data %>% select(all_of(include)), + value = value, by = by, + type = type, label = label, statistic = statistic, + digits = digits, percent = percent, sort = sort + ) + + # calculating summary statistics --------------------------------------------- + table_body <- + meta_data %>% + mutate( + tbl_stats = pmap( + list( + .data$summary_type, .data$variable, + .data$var_label, .data$stat_display, .data$df_stats + ), + function(summary_type, variable, var_label, stat_display, df_stats) { + df_stats_to_tbl( + data = data, variable = variable, summary_type = summary_type, by = by, + var_label = var_label, stat_display = stat_display, + df_stats = df_stats, missing = missing, missing_text = missing_text + ) + } + ) + ) %>% + select(var_type = "summary_type", "var_label", "tbl_stats") %>% + unnest("tbl_stats") %>% + select("variable", "var_type", "var_label", everything()) + + # table of column headers ---------------------------------------------------- + x <- + .create_gtsummary_object( + table_body = table_body, + meta_data = meta_data, + inputs = tbl_summary_inputs, + N = nrow(data), + call_list = list(tbl_summary = match.call()), + by = by, + df_by = df_by(data, by) + ) + + # adding "modify_stat_" information ------------------------------------------ + x$table_styling$header$modify_stat_N <- nrow(data) + if (!is.null(by)) { + x$table_styling$header <- + x$table_styling$header %>% + dplyr::left_join( + x$df_by %>% + select( + column = "by_col", + modify_stat_n = "n", + modify_stat_p = "p", + modify_stat_level = "by_chr" + ), + by = "column" + ) + } else { + x$table_styling$header <- + x$table_styling$header %>% + mutate( + modify_stat_n = .data$modify_stat_N, + modify_stat_p = .data$modify_stat_n / .data$modify_stat_N, + modify_stat_level = ifelse(.data$column %in% "stat_0", translate_text("Overall"), NA_character_) + ) + } + + # adding headers and footnote ------------------------------------------------ + x <- + modify_table_styling( + x, + columns = all_stat_cols(), + footnote = footnote_stat_label(meta_data) + ) %>% + modify_header( + label = paste0("**", translate_text("Characteristic"), "**"), + all_stat_cols() ~ + ifelse(is.null(by), + get_theme_element("tbl_summary-str:header-noby", + default = "**N = {style_number(N)}**" + ), + get_theme_element("tbl_summary-str:header-withby", + default = "**{level}**, N = {style_number(n)}" + ) + ) + ) + + # assign class and return final tbl ------------------------------------------ + class(x) <- c("tbl_summary", class(x)) + + # running any additional mods + x <- + get_theme_element("tbl_summary-fn:addnl-fn-to-run", default = identity) %>% + do.call(list(x)) + + x +} + + +# generate metadata table -------------------------------------------------------------- +# for survey objects pass the full survey object to `survey` argument, and `design$variables` to `data` argument +generate_metadata <- function(data, value, by, type, label, + statistic, digits, percent, sort, survey = NULL) { + # converting tidyselect formula lists to named lists ------------------------- + 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( + variable = names(data), + # assigning our best guess of the type, the final type is assigned below + # we make a guess first, so users may use the gtsummary tidyselect functions for type + summary_type = assign_summary_type( + data = data, variable = .data$variable, + summary_type = NULL, value = value + ) + ) + # excluding by variable + if (!is.null(by)) meta_data <- filter(meta_data, .data$variable != by) + + # updating type -------------------------------------------------------------- + # updating type of user supplied one + # converting tidyselect formula lists to named lists + type <- + .formula_list_to_named_list( + x = type, + data = data, + var_info = meta_data_to_var_info(meta_data), + arg_name = "type", + type_check = chuck(type_check, "is_string_summary_type", "fn"), + type_check_msg = chuck(type_check, "is_string_summary_type", "msg") + ) + + # updating meta data object with new types + meta_data <- + meta_data %>% + mutate( + summary_type = assign_summary_type( + data = data, variable = .data$variable, + summary_type = type, value = value, check_assignment = TRUE + ) + ) + + # converting tidyselect formula lists to named lists ------------------------- + label <- .formula_list_to_named_list( + x = label, + data = data, + var_info = meta_data_to_var_info(meta_data), + arg_name = "label", + type_check = chuck(type_check, "is_character", "fn"), + type_check_msg = chuck(type_check, "is_character", "msg") + ) + statistic <- .formula_list_to_named_list( + x = statistic, + data = data, + var_info = meta_data_to_var_info(meta_data), + arg_name = "statistic", + type_check = chuck(type_check, "is_character", "fn"), + type_check_msg = chuck(type_check, "is_character", "msg") + ) + digits <- .formula_list_to_named_list( + x = digits, + data = data, + var_info = meta_data_to_var_info(meta_data), + arg_name = "digits", + type_check = chuck(type_check, "digits", "fn"), + type_check_msg = chuck(type_check, "digits", "msg") + ) + sort <- .formula_list_to_named_list( + x = sort, + data = data, + var_info = meta_data_to_var_info(meta_data), + arg_name = "sort", + type_check = chuck(type_check, "is_string_summary_sort", "fn"), + type_check_msg = chuck(type_check, "is_string_summary_sort", "msg") + ) + + # assigning variable characteristics ----------------------------------------- + if (is.null(survey)) { + df_stats_function <- df_stats_fun + data_for_df_stats <- data + } else { + df_stats_function <- df_stats_fun_survey + data_for_df_stats <- survey + } + + meta_data <- + meta_data %>% + mutate( + dichotomous_value = assign_dichotomous_value(data, .data$variable, .data$summary_type, value), + var_label = assign_var_label(data, .data$variable, label), + stat_display = assign_stat_display(data, .data$variable, .data$summary_type, statistic), + stat_label = stat_label_match(.data$stat_display), + sort = assign_sort(.data$variable, .data$summary_type, sort), + df_stats = pmap( + list( + .data$summary_type, .data$variable, + .data$dichotomous_value, + .data$sort, .data$stat_display, .data$var_label + ), + ~ df_stats_function( + summary_type = ..1, variable = ..2, + dichotomous_value = ..3, + sort = ..4, stat_display = ..5, + data = data_for_df_stats, by = by, + percent = percent, digits = digits, + var_label = ..6 + ) + ) + ) + + meta_data +} diff --git a/R/tbl_survfit.R b/_archive/R/tbl_survfit.R similarity index 100% rename from R/tbl_survfit.R rename to _archive/R/tbl_survfit.R diff --git a/R/tbl_survfit_errors.R b/_archive/R/tbl_survfit_errors.R similarity index 100% rename from R/tbl_survfit_errors.R rename to _archive/R/tbl_survfit_errors.R diff --git a/R/tbl_survival.R b/_archive/R/tbl_survival.R similarity index 100% rename from R/tbl_survival.R rename to _archive/R/tbl_survival.R diff --git a/R/tbl_svysummary.R b/_archive/R/tbl_svysummary.R similarity index 100% rename from R/tbl_svysummary.R rename to _archive/R/tbl_svysummary.R diff --git a/R/tbl_uvregression.R b/_archive/R/tbl_uvregression.R similarity index 100% rename from R/tbl_uvregression.R rename to _archive/R/tbl_uvregression.R diff --git a/R/tests.R b/_archive/R/tests.R similarity index 100% rename from R/tests.R rename to _archive/R/tests.R diff --git a/R/theme_gtsummary.R b/_archive/R/theme_gtsummary.R similarity index 100% rename from R/theme_gtsummary.R rename to _archive/R/theme_gtsummary.R diff --git a/R/tidy_plus_plus_dots.R b/_archive/R/tidy_plus_plus_dots.R similarity index 100% rename from R/tidy_plus_plus_dots.R rename to _archive/R/tidy_plus_plus_dots.R diff --git a/R/utils-add_p.R b/_archive/R/utils-add_p.R similarity index 100% rename from R/utils-add_p.R rename to _archive/R/utils-add_p.R diff --git a/R/utils-add_p_tests.R b/_archive/R/utils-add_p_tests.R similarity index 100% rename from R/utils-add_p_tests.R rename to _archive/R/utils-add_p_tests.R diff --git a/_archive/R/utils-as.R b/_archive/R/utils-as.R new file mode 100644 index 0000000000..3655cbd69a --- /dev/null +++ b/_archive/R/utils-as.R @@ -0,0 +1,307 @@ +.convert_header_to_rows_one_column <- function(x, column) { + if (column %in% c("footnote", "footnote_abbrev")) { + x$table_styling[[column]] <- + x$table_header %>% + select(all_of(c("column", .env$column))) %>% + set_names(c("column", "footnote")) %>% + filter(!is.na(.data$footnote)) %>% + mutate( + rows = list(expr(NULL)), + text_interpret = "gt::md" + ) %>% + select(all_of(c("column", "rows", "text_interpret", "footnote"))) + } else if (column %in% c("indent", "bold", "italic")) { + x$table_styling$text_format <- + x$table_header %>% + select(all_of(c("column", .env$column))) %>% + filter(!is.na(.data[[column]])) %>% + set_names(c("column", "rows")) %>% + mutate( + rows = map(.data$rows, ~ parse_expr(.x)), + format_type = .env$column, + undo_text_format = FALSE + ) %>% + bind_rows(x$table_styling$text_format) + } else if (column %in% "missing_emdash") { + x$table_styling[["fmt_missing"]] <- + x$table_header %>% + select(all_of(c("column", .env$column))) %>% + filter(!is.na(.data[[column]])) %>% + set_names(c("column", "rows")) %>% + mutate( + rows = map(.data$rows, ~ parse_expr(.x)), + symbol = get_theme_element("tbl_regression-str:ref_row_text", + default = "\U2014" + ) + ) + } else if (column %in% "fmt_fun") { + x$table_styling[[column]] <- + x$table_header %>% + select(all_of(c("column", .env$column))) %>% + filter(!map_lgl(.data[[column]], is.null)) %>% + mutate(rows = list(expr(NULL))) %>% + select(all_of(c("column", "rows", .env$column))) + } + + # return gtsummary table + x +} + +# takes a table_body and a character rows expression, and returns the resulting row numbers +.rows_expr_to_row_numbers <- function(table_body, rows, return_when_null = NA) { + rows_evaluated <- rlang::eval_tidy(rows, data = table_body) + + if (is.null(rows_evaluated)) { + return(return_when_null) + } + which(rows_evaluated) +} + +.cols_to_show <- function(x) { + x$table_styling$header %>% + filter(!.data$hide) %>% + pull("column") +} + + +# 1. Converts row expressions to row numbers, and only keeps the most recent. +# 2. Deletes NA footnote, text_formatting undoings, etc. as they will not be used + + +#' Object Convert Helper +#' +#' Ahead of a gtsummary object being converted to an output type, +#' each logical expression saved in `x$table_styling` is converted to a +#' list of row numbers. +#' +#' @param x a gtsummary object +#' +#' @return a gtsummary object +#' @keywords internal +#' @export +#' +#' @examples +#' tbl <- +#' trial %>% +#' tbl_summary(include = c(age, grade)) %>% +#' .table_styling_expr_to_row_number() +.table_styling_expr_to_row_number <- function(x) { + # text_format ---------------------------------------------------------------- + x$table_styling$text_format <- + x$table_styling$text_format %>% + filter(.data$column %in% .cols_to_show(x)) %>% + rowwise() %>% + mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers( + x$table_body, .data$rows, + return_when_null = seq_len(nrow(x$table_body)) + ) %>% + list(), + ) %>% + select(-"rows") %>% + unnest("row_numbers") %>% + group_by(.data$column, .data$row_numbers, .data$format_type) %>% + filter(row_number() == n()) %>% + filter(.data$undo_text_format == FALSE) %>% + # dropping undoing cmds + group_by(.data$column, .data$format_type) %>% + nest(row_numbers = "row_numbers") %>% + mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) %>% + select("column", "row_numbers", everything()) %>% + ungroup() + + # fmt_missing ---------------------------------------------------------------- + x$table_styling$fmt_missing <- + x$table_styling$fmt_missing %>% + filter(.data$column %in% .cols_to_show(x)) %>% + rowwise() %>% + mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(), + ) %>% + select(-"rows") %>% + unnest("row_numbers") %>% + group_by(.data$column, .data$row_numbers) %>% + filter(row_number() == n()) %>% + select("column", "row_numbers", "symbol") %>% + ungroup() %>% + tidyr::nest(row_numbers = "row_numbers") %>% + rowwise() %>% + dplyr::mutate(row_numbers = unlist(.data$row_numbers) %>% unname() %>% list()) %>% + ungroup() + + # footnote ------------------------------------------------------------------- + x$table_styling$footnote <- + .table_styling_expr_to_row_number_footnote(x, "footnote") + + # footnote_abbrev ------------------------------------------------------------ + x$table_styling$footnote_abbrev <- + .table_styling_expr_to_row_number_footnote(x, "footnote_abbrev") + + # fmt_fun -------------------------------------------------------------------- + x$table_styling$fmt_fun <- + x$table_styling$fmt_fun %>% + # filter(.data$column %in% .cols_to_show(x)) %>% + rowwise() %>% + mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers(x$table_body, .data$rows, + return_when_null = seq_len(nrow(x$table_body)) + ) %>% list() + ) %>% + select(-"rows") %>% + unnest("row_numbers") %>% + group_by(.data$column, .data$row_numbers) %>% + filter(row_number() == n()) %>% + ungroup() %>% + nest(row_numbers = "row_numbers") %>% + mutate(row_numbers = map(.data$row_numbers, ~ unlist(.x) %>% unname())) + + # cols_merge ----------------------------------------------------------------- + x$table_styling$cols_merge <- + x$table_styling$cols_merge %>% + group_by(.data$column) %>% + filter(dplyr::row_number() == dplyr::n(), !is.na(.data$pattern)) %>% + rowwise() %>% + mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers( + x$table_body, .data$rows, + return_when_null = seq_len(nrow(x$table_body)) + ) %>% + list(), + ) %>% + select(-"rows", rows = "row_numbers") + + x +} + +.table_styling_expr_to_row_number_footnote <- function(x, footnote_type) { + df_clean <- + x$table_styling[[footnote_type]] %>% + filter(.data$column %in% .cols_to_show(x)) + if (nrow(df_clean) == 0) { + return(tibble( + column = character(0), tab_location = character(0), row_numbers = logical(0), + text_interpret = character(0), footnote = character(0) + )) + } + + df_clean <- + df_clean %>% + rowwise() %>% + mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(), + tab_location = ifelse(identical(.data$row_numbers, NA), "header", "body") + ) %>% + select(-"rows") %>% + unnest(cols = "row_numbers") %>% + group_by(.data$column, .data$tab_location, .data$row_numbers) %>% + filter(row_number() == n()) %>% + # keeping the most recent addition + filter(!is.na(.data$footnote)) # keep non-missing additions + + if (footnote_type == "footnote_abbrev") { + # order the footnotes by where they first appear in the table, + df_clean <- + df_clean %>% + inner_join( + x$table_styling$header %>% + select("column") %>% + mutate(column_id = row_number()), + by = "column" + ) %>% + arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% + ungroup() %>% + mutate(footnote = paste(unique(.data$footnote), collapse = ", ")) + } + + df_clean %>% + select(all_of(c("column", "tab_location", "row_numbers", "text_interpret", "footnote"))) +} + +# this function orders the footnotes by where they first appear in the table, +# and assigns them an sequential ID +.number_footnotes <- function(x) { + if (nrow(x$table_styling$footnote) == 0 && + nrow(x$table_styling$footnote_abbrev) == 0) { + return(tibble( + footnote_id = integer(), footnote = character(), column = character(), + tab_location = character(), row_numbers = integer() + )) + } + bind_rows( + x$table_styling$footnote, + x$table_styling$footnote_abbrev + ) %>% + inner_join( + x$table_styling$header %>% + select("column") %>% + mutate(column_id = row_number()), + by = "column" + ) %>% + arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% + group_by(.data$footnote) %>% + nest() %>% + ungroup() %>% + mutate(footnote_id = row_number()) %>% + unnest(cols = "data") %>% + select( + "footnote_id", "footnote", "column", + "tab_location", "row_numbers" + ) +} + +.table_styling_cols_merge <- function(x) { + if (is.null(x$table_styling$cols_merge) || nrow(x$table_styling$cols_merge) == 0) { + return(x) + } + x_cleaned <- .table_styling_expr_to_row_number(x) + if (nrow(x_cleaned$table_styling$cols_merge) == 0) { + return(x) + } + + # replacing numeric columns with formatted/character,merged columns + merging_columns <- x_cleaned$table_styling$cols_merge$column + df_merged <- as_tibble(x, include = c("tibble", "fmt", "cols_merge")) + x$table_body[merging_columns] <- df_merged[merging_columns] + + # removing merging instructions ---------------------------------------------- + x$table_styling$cols_merge <- + x$table_styling$cols_merge %>% + filter(FALSE) + + # replacing formatting functions for merged columns -------------------------- + x <- modify_fmt_fun(x, update = inject(!!merging_columns ~ as.character)) + + # return merged gtsummary table ---------------------------------------------- + x +} + + +# this function takes a list expressions and evaluates them with a `%>%` between them +.eval_list_of_exprs <- function(exprs, env = rlang::caller_env()) { + exprs %>% + # removing NULL elements + unlist() %>% + compact() %>% + # concatenating expressions with %>% between each of them + reduce(function(x, y) rlang::inject(!!x %>% !!y, env = env)) +} diff --git a/_archive/R/utils-gtsummary_core.R b/_archive/R/utils-gtsummary_core.R new file mode 100644 index 0000000000..11d2d8823b --- /dev/null +++ b/_archive/R/utils-gtsummary_core.R @@ -0,0 +1,154 @@ +# THIS FILE CONTAINS A FEW SCRIPTS THAT ASSIST IN SETTING UP A GENERAL +# GTSUMMARY OBJECT. IF YOU'RE CREATING A GTSUMMARY-LIKE FUNCTION, YOU'LL +# WANT TO GRAB A COPY OF THIS FILE AND PLACE IT IN YOUR PACKAGE. + +# LAST UPDATED: 2020-12-19 + +# .create_gtsummary_object ----------------------------------------------------- +#' Function uses `table_body` to create a gtsummary object +#' +#' @param table_body the table_body tibble +#' @param ... other objects that will be added to the gtsummary object list +#' +#' @export +#' @keywords internal +#' @return gtsummary object +.create_gtsummary_object <- function(table_body, ...) { + x <- list() # empty gtsummary object + + # table_body ----------------------------------------------------------------- + x$table_body <- table_body + + # table_styling -------------------------------------------------------------- + x$table_styling$header <- + tibble( + column = names(x$table_body), + hide = TRUE, + align = "center", + interpret_label = "gt::md", + label = names(x$table_body), + interpret_spanning_header = "gt::md", + spanning_header = NA_character_ + ) %>% + mutate( + hide = ifelse(.data$column == "label", FALSE, .data$hide), + align = ifelse(.data$column == "label", "left", .data$align) + ) + + x$table_styling$footnote <- + tibble( + column = character(), rows = list(), + text_interpret = character(), footnote = character() + ) + x$table_styling$footnote_abbrev <- + tibble( + column = character(), rows = list(), + text_interpret = character(), footnote = character() + ) + x$table_styling$text_format <- + .purrr_when( + isTRUE(all(c("label", "row_type") %in% x$table_styling$header$column)) ~ + tibble( + column = "label", + rows = list(rlang::expr(.data$row_type %in% c("level", "missing"))), + format_type = "indent", undo_text_format = FALSE + ), + isFALSE(all(c("label", "row_type") %in% x$table_styling$header$column)) ~ + tibble( + column = character(), rows = list(), + format_type = character(), undo_text_format = logical() + ) + ) + + x$table_styling$fmt_missing <- + tibble(column = character(), rows = list(), symbol = character()) + x$table_styling$fmt_fun <- + tibble(column = character(), rows = list(), fmt_fun = list()) + x$table_styling$cols_merge <- + tibble(column = character(), rows = list(), pattern = character()) + + # adding other objects to list ----------------------------------------------- + x <- c(x, list(...)) + + # returning gtsummary object ------------------------------------------------- + class(x) <- "gtsummary" + x +} + +# this fn updates `table_styling` list to match `table_body` +.update_table_styling <- function(x) { + # vector of columns deleted in update + deleted_columns <- + x$table_styling$header$column %>% + setdiff(names(x$table_body)) + + # if a column was deleted, omit all styling instructions for that column ----- + if (!is_empty(deleted_columns)) { + for (styling_element in names(x$table_styling)) { + # if element is a tibble with a column called 'column' + if (is.data.frame(x$table_styling[[styling_element]]) && + "column" %in% names(x$table_styling[[styling_element]])) { + x$table_styling[[styling_element]] <- + x$table_styling[[styling_element]] %>% + filter(!.data$column %in% deleted_columns) + } + } + } + + # update styling header table with new variables ----------------------------- + x$table_styling$header <- + tibble( + column = names(x$table_body), + hide = TRUE, + align = "center", + interpret_label = "gt::md", + label = names(x$table_body), + interpret_spanning_header = "gt::md", + spanning_header = NA_character_ + ) %>% + .rows_update_table_styling_header(x$table_styling$header) + + # return x ------------------------------------------------------------------- + x +} + +.rows_update_table_styling_header <- function(x, y) { + common_columns <- intersect(names(x), names(y)) + + x %>% + # updating rows in header + dplyr::rows_update( + y %>% select(all_of(common_columns)), + by = "column" + ) %>% + # re-adding the columns not in the original header table + dplyr::left_join( + y %>% select(-all_of(setdiff(common_columns, "column"))), + by = "column" + ) +} + + +.purrr_when <- function(...) { + lst_formulas <- rlang::dots_list(...) + + for (i in seq_len(length(lst_formulas))) { + if (isTRUE(eval_tidy(.f_lhs_as_quo(lst_formulas[[i]])))) { + return(eval_tidy(.f_rhs_as_quo(lst_formulas[[i]]))) + } + } + # if not matches, return NULL + NULL +} +.f_lhs_as_quo <- function(x) { + rlang::new_quosure( + expr = rlang::f_lhs(x), + env = attr(x, ".Environment") + ) +} +.f_rhs_as_quo <- function(x) { + rlang::new_quosure( + expr = rlang::f_rhs(x), + env = attr(x, ".Environment") + ) +} diff --git a/R/utils-man_images.R b/_archive/R/utils-man_images.R similarity index 100% rename from R/utils-man_images.R rename to _archive/R/utils-man_images.R diff --git a/_archive/R/utils-misc.R b/_archive/R/utils-misc.R new file mode 100644 index 0000000000..e45d69b4e8 --- /dev/null +++ b/_archive/R/utils-misc.R @@ -0,0 +1,150 @@ +# converts a character vector into a quotes list separated by a comma, eg 'a', 'b' +quoted_list <- function(x) { + paste(shQuote(x, type = "csh"), collapse = ", ") +} + +# used in the as_flex_table (and friends) functions for inserting calls +add_expr_after <- function(calls, add_after, expr, new_name = NULL) { + # checking input + if (!rlang::is_string(add_after) || !add_after %in% names(calls)) { + stop(glue("`add_after=` must be one of {quoted_list(names(calls))}")) + } + + # position to insert, and name of list + index <- which(names(calls) == add_after) + new_name <- new_name %||% "user_added" + new_list <- list(expr) %>% set_names(new_name) + + # insert list + append(calls, new_list, after = index) +} + + +# this function is used to fill in missing values in the +# x$table_styling$header$modify_stat_* columns +.fill_table_header_modify_stats <- + function(x, modify_stats = c( + "modify_stat_N", "modify_stat_N_event", + "modify_stat_N_unweighted" + )) { + modify_stats <- + x$table_styling$header %>% + select(any_of(modify_stats) & where(.single_value)) %>% + names() + + x$table_styling$header <- + x$table_styling$header %>% + tidyr::fill(any_of(modify_stats), .direction = "downup") + + return(x) + } + +.single_value <- function(x) { + if (length(unique(stats::na.omit(x))) == 1L) { + return(TRUE) + } + FALSE +} + +#' gtsummary wrapper for purrr::as_mapper +#' +#' This wrapper only accepts a function or formula notation function, +#' and returns an informative message when incorrect inputs passed +#' +#' @param x function or anon. function using formula notation. +#' @param context string indicating function and arg, e.g. `context = "foo(arg=)"` +#' @noRd +#' @keywords internal + +gts_mapper <- function(x, context) { + # checking input, and giving informative error msg + if (!rlang::is_function(x) && !rlang::is_formula(x)) { + paste( + "Expecting a function in argument `{context}`,\n", + "e.g. `fun = function(x) style_pvalue(x, digits = 2)`, or\n", + "`fun = ~style_pvalue(., digits = 2)`" + ) %>% + stringr::str_glue() %>% + rlang::abort() + } + + purrr::as_mapper(x) +} + +# All documentation of the global options was removed in v1.3.1. +# This messaging was added in v1.6.0 +.get_deprecated_option <- function(x, default = NULL) { + if (!is.null(getOption(x, default = NULL))) { + paste( + "Global option {.val {x}} is soft deprecated and will", + "{.emph soon} be removed from {.pkg gtsummary}.\nThe functionality", + "has been migrated to a function argument or a gtsummary theme.", + "\n{.url https://www.danieldsjoberg.com/gtsummary/articles/themes.html}" + ) %>% + cli::cli_alert_danger() + } + getOption(x, default = default) +} + +.assert_class <- function(x, class, arg_name = "x") { + if (!inherits(x, class)) { + cls_clps <- + glue::glue_collapse(shQuote(class, type = "csh"), sep = ", ", last = ", or ") + glue("Error in argument '{arg_name}='. Expecting object of class {cls_clps}") %>% + stop(call. = FALSE) + } +} + +vec_paste0 <- function(..., collapse = NULL) { + args <- vctrs::vec_recycle_common(...) + rlang::inject(paste0(!!!args, collapse = collapse)) +} + +type_check <- + list( + is_string = + list( + msg = "Expecting a string as the passed value.", + fn = function(x) is_string(x) + ), + is_string_summary_type = + list( + msg = "Expecting one of `c('categorical', 'dichotomous', 'continuous', 'continuous2')` as the passed value.", + fn = function(x) is_string(x) && x %in% c("categorical", "dichotomous", "continuous", "continuous2") + ), + is_string_summary_sort = + list( + msg = "Expecting one of `c('frequency', 'alphanumeric')` as the passed value.", + fn = function(x) is_string(x) && x %in% c("frequency", "alphanumeric") + ), + is_character = + list( + msg = "Expecting a character as the passed value.", + fn = function(x) is.character(x) + ), + is_function = + list( + msg = "Expecting a function as the passed value.", + fn = function(x) is.function(x) + ), + is_function_or_string = + list( + msg = "Expecting a function or a string of a function name.", + fn = function(x) is_string(x) || is.function(x) + ), + is_string_or_na = + list( + msg = "Expecting a string or NA as the passed value.", + fn = function(x) is_string(x) || is.na(x) + ), + is_named = + list( + msg = "Expecting a named vector or list as the passed value.", + fn = function(x) is_named(x) + ), + digits = + list( + msg = "Expecting an integer, function, or a vector/list of intergers/functions as the passed value.", + fn = function(x) rlang::is_integerish(x) || is.function(x) || purrr::every(x, ~ rlang::is_integerish(.x) || is.function(.x)) + ) + ) diff --git a/R/utils-tbl_custom_summary.R b/_archive/R/utils-tbl_custom_summary.R similarity index 100% rename from R/utils-tbl_custom_summary.R rename to _archive/R/utils-tbl_custom_summary.R diff --git a/R/utils-tbl_regression.R b/_archive/R/utils-tbl_regression.R similarity index 100% rename from R/utils-tbl_regression.R rename to _archive/R/utils-tbl_regression.R diff --git a/R/utils-tbl_summary.R b/_archive/R/utils-tbl_summary.R similarity index 100% rename from R/utils-tbl_summary.R rename to _archive/R/utils-tbl_summary.R diff --git a/R/zzz.R b/_archive/R/zzz.R similarity index 100% rename from R/zzz.R rename to _archive/R/zzz.R diff --git a/README.Rmd b/_archive/README.Rmd similarity index 100% rename from README.Rmd rename to _archive/README.Rmd diff --git a/_archive/README.md b/_archive/README.md new file mode 100644 index 0000000000..f34f05f19e --- /dev/null +++ b/_archive/README.md @@ -0,0 +1,266 @@ + + + + +[![R-CMD-check](https://github.com/ddsjoberg/gtsummary/workflows/R-CMD-check/badge.svg)](https://github.com/ddsjoberg/gtsummary/actions) +[![CRAN +status](https://www.r-pkg.org/badges/version/gtsummary)](https://cran.r-project.org/package=gtsummary) +[![Codecov test +coverage](https://codecov.io/gh/ddsjoberg/gtsummary/branch/main/graph/badge.svg)](https://app.codecov.io/gh/ddsjoberg/gtsummary?branch=main) +[![](https://cranlogs.r-pkg.org/badges/gtsummary)](https://cran.r-project.org/package=gtsummary) +[![DOI:10.32614/RJ-2021-053](https://zenodo.org/badge/DOI/10.32614/RJ-2021-053.svg)](https://doi.org/10.32614/RJ-2021-053) + + +## gtsummary + +The {gtsummary} package provides an elegant and flexible way to create +publication-ready analytical and summary tables using the **R** +programming language. The {gtsummary} package summarizes data sets, +regression models, and more, using sensible defaults with highly +customizable capabilities. + +- [**Summarize data frames or + tibbles**](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html) + easily in **R**. Perfect for presenting descriptive statistics, + comparing group **demographics** (e.g creating a **Table 1** for + medical journals), and more. Automatically detects continuous, + categorical, and dichotomous variables in your data set, calculates + appropriate descriptive statistics, and also includes amount of + missingness in each variable. + +- [**Summarize regression + models**](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) + in R and include reference rows for categorical variables. Common + regression models, such as logistic regression and Cox proportional + hazards regression, are automatically identified and the tables are + pre-filled with appropriate column headers (i.e. Odds Ratio and Hazard + Ratio). + +- [**Customize gtsummary + tables**](https://www.danieldsjoberg.com/gtsummary/reference/index.html#section-general-formatting-styling-functions) + using a growing list of formatting/styling functions. + **[Bold](https://www.danieldsjoberg.com/gtsummary/reference/bold_italicize_labels_levels.html)** + labels, + **[italicize](https://www.danieldsjoberg.com/gtsummary/reference/bold_italicize_labels_levels.html)** + levels, **[add + p-value](https://www.danieldsjoberg.com/gtsummary/reference/add_p.html)** + to summary tables, + **[style](https://www.danieldsjoberg.com/gtsummary/reference/style_percent.html)** + the statistics however you choose, + **[merge](https://www.danieldsjoberg.com/gtsummary/reference/tbl_merge.html)** + or + **[stack](https://www.danieldsjoberg.com/gtsummary/reference/tbl_stack.html)** + tables to present results side by side… there are so many + possibilities to create the table of your dreams! + +- **[Report statistics + inline](https://www.danieldsjoberg.com/gtsummary/articles/inline_text.html)** + from summary tables and regression summary tables in **R markdown**. + Make your reports completely reproducible! + +By leveraging [{broom}](https://broom.tidymodels.org/), +[{gt}](https://gt.rstudio.com/), and +[{labelled}](http://larmarange.github.io/labelled/) packages, +{gtsummary} creates beautifully formatted, ready-to-share summary and +result tables in a single line of R code! + +Check out the examples below, review the +[vignettes](https://www.danieldsjoberg.com/gtsummary/articles/) for a +detailed exploration of the output options, and view the +[gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html) +for various customization examples. + +## Installation + +The {gtsummary} package was written as a companion to the +[{gt}](https://gt.rstudio.com/) package from RStudio. You can install +{gtsummary} with the following code. + +``` r +install.packages("gtsummary") +``` + +Install the development version of {gtsummary} with: + +``` r +remotes::install_github("ddsjoberg/gtsummary") +``` + +## Examples + +### Summary Table + +Use +[`tbl_summary()`](https://www.danieldsjoberg.com/gtsummary/reference/tbl_summary.html) +to summarize a data frame. + +animated + +Example basic table: + +``` r +library(gtsummary) + +# summarize the data with our package +table1 <- + trial %>% + tbl_summary(include = c(age, grade, response)) +``` + + + +There are many **customization options** to **add information** (like +comparing groups) and **format results** (like bold labels) in your +table. See the +[`tbl_summary()`](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html) +tutorial for many more options, or below for one example. + +``` r +table2 <- + tbl_summary( + trial, + include = c(age, grade, response), + by = trt, # split table by group + missing = "no" # don't list missing data separately + ) %>% + add_n() %>% # add column with total number of non-missing observations + add_p() %>% # test for a difference between groups + modify_header(label = "**Variable**") %>% # update the column header + bold_labels() +``` + + + +### Regression Models + +Use +[`tbl_regression()`](https://www.danieldsjoberg.com/gtsummary/reference/tbl_regression.html) +to easily and beautifully display regression model results in a table. +See the +[tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) +for customization options. + +``` r +mod1 <- glm(response ~ trt + age + grade, trial, family = binomial) + +t1 <- tbl_regression(mod1, exponentiate = TRUE) +``` + + + +### Side-by-side Regression Models + +You can also present side-by-side regression model results using +`tbl_merge()` + +``` r +library(survival) + +# build survival model table +t2 <- + coxph(Surv(ttdeath, death) ~ trt + grade + age, trial) %>% + tbl_regression(exponentiate = TRUE) + +# merge tables +tbl_merge_ex1 <- + tbl_merge( + tbls = list(t1, t2), + tab_spanner = c("**Tumor Response**", "**Time to Death**") + ) +``` + + + +Review even more output options in the **[table +gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html)**. + +## gtsummary + R Markdown + +The **{gtsummary}** package was written to be a companion to the +**{gt}** package from RStudio. But not all output types are supported by +the **{gt}** package. Therefore, we have made it possible to print +**{gtsummary}** tables with various engines. + +Review the **[gtsummary + R +Markdown](https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html)** +vignette for details. + + + + +## Save Individual Tables + +{gtsummary} tables can also be saved directly to file as an image, HTML, +Word, RTF, and LaTeX file. + +``` r +tbl %>% + as_gt() %>% + gt::gtsave(filename = ".") # use extensions .png, .html, .docx, .rtf, .tex, .ltx +``` + +## Additional Resources + +- The best resources are the gtsummary vignettes: [table + gallery](https://www.danieldsjoberg.com/gtsummary/articles/gallery.html), + [`tbl_summary()` + tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html), + [`tbl_regression()` + tutorial](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html), + [`inline_text()` + tutorial](https://www.danieldsjoberg.com/gtsummary/articles/inline_text.html), + [gtsummary + themes](https://www.danieldsjoberg.com/gtsummary/articles/themes.html), + [gtsummary+R + markdown](https://www.danieldsjoberg.com/gtsummary/articles/rmarkdown.html). + +- The R Journal Article [*Reproducible Summary Tables with the gtsummary + Package*](https://github.com/ddsjoberg/gtsummary/raw/main/data-raw/RJ-2021-053.pdf). + +- The [RStudio Education + Blog](https://education.rstudio.com/blog/2020/07/gtsummary/) includes + a post with a brief introduction to the package. + +- A [recording of a + presentation](https://www.youtube.com/watch?v=tANo9E1SYJE) given to + the Weill Cornell Biostatistics Department and the Memorial Sloan + Kettering R Users Group. + + + +## Cite gtsummary + +``` text +> citation("gtsummary") + +To cite gtsummary in publications use: + + Sjoberg DD, Whiting K, Curry M, Lavery JA, Larmarange J. Reproducible summary tables with the gtsummary package. + The R Journal 2021;13:570–80. https://doi.org/10.32614/RJ-2021-053. + +A BibTeX entry for LaTeX users is + + @Article{gtsummary, + author = {Daniel D. Sjoberg and Karissa Whiting and Michael Curry and Jessica A. Lavery and Joseph Larmarange}, + title = {Reproducible Summary Tables with the gtsummary Package}, + journal = {{The R Journal}}, + year = {2021}, + url = {https://doi.org/10.32614/RJ-2021-053}, + doi = {10.32614/RJ-2021-053}, + volume = {13}, + issue = {1}, + pages = {570-580}, + } +``` + +## Contributing + +Big thank you to +[@jeffreybears](https://www.etsy.com/shop/jeffreybears/) for the hex +sticker! + +Please note that the {gtsummary} project is released with a [Contributor +Code of +Conduct](https://www.danieldsjoberg.com/gtsummary/CODE_OF_CONDUCT.html). +By contributing to this project, you agree to abide by its terms. Thank +you to all contributors! diff --git a/benchmark/README.md b/_archive/benchmark/README.md similarity index 100% rename from benchmark/README.md rename to _archive/benchmark/README.md diff --git a/benchmark/README_.Rmd b/_archive/benchmark/README_.Rmd similarity index 100% rename from benchmark/README_.Rmd rename to _archive/benchmark/README_.Rmd diff --git a/benchmark/README_files/figure-gfm/unnamed-chunk-1-1.png b/_archive/benchmark/README_files/figure-gfm/unnamed-chunk-1-1.png similarity index 100% rename from benchmark/README_files/figure-gfm/unnamed-chunk-1-1.png rename to _archive/benchmark/README_files/figure-gfm/unnamed-chunk-1-1.png diff --git a/benchmark/README_files/figure-markdown_strict/unnamed-chunk-1-1.png b/_archive/benchmark/README_files/figure-markdown_strict/unnamed-chunk-1-1.png similarity index 100% rename from benchmark/README_files/figure-markdown_strict/unnamed-chunk-1-1.png rename to _archive/benchmark/README_files/figure-markdown_strict/unnamed-chunk-1-1.png diff --git a/benchmark/benchmark_gts.R b/_archive/benchmark/benchmark_gts.R similarity index 100% rename from benchmark/benchmark_gts.R rename to _archive/benchmark/benchmark_gts.R diff --git a/benchmark/results/benchmark_current.csv b/_archive/benchmark/results/benchmark_current.csv similarity index 100% rename from benchmark/results/benchmark_current.csv rename to _archive/benchmark/results/benchmark_current.csv diff --git a/benchmark/results/benchmark_master.csv b/_archive/benchmark/results/benchmark_master.csv similarity index 100% rename from benchmark/results/benchmark_master.csv rename to _archive/benchmark/results/benchmark_master.csv diff --git a/benchmark/results/benchmark_v1.2.0.csv b/_archive/benchmark/results/benchmark_v1.2.0.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.0.csv rename to _archive/benchmark/results/benchmark_v1.2.0.csv diff --git a/benchmark/results/benchmark_v1.2.1.csv b/_archive/benchmark/results/benchmark_v1.2.1.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.1.csv rename to _archive/benchmark/results/benchmark_v1.2.1.csv diff --git a/benchmark/results/benchmark_v1.2.2.csv b/_archive/benchmark/results/benchmark_v1.2.2.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.2.csv rename to _archive/benchmark/results/benchmark_v1.2.2.csv diff --git a/benchmark/results/benchmark_v1.2.3.csv b/_archive/benchmark/results/benchmark_v1.2.3.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.3.csv rename to _archive/benchmark/results/benchmark_v1.2.3.csv diff --git a/benchmark/results/benchmark_v1.2.4.csv b/_archive/benchmark/results/benchmark_v1.2.4.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.4.csv rename to _archive/benchmark/results/benchmark_v1.2.4.csv diff --git a/benchmark/results/benchmark_v1.2.5.csv b/_archive/benchmark/results/benchmark_v1.2.5.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.5.csv rename to _archive/benchmark/results/benchmark_v1.2.5.csv diff --git a/benchmark/results/benchmark_v1.2.6.csv b/_archive/benchmark/results/benchmark_v1.2.6.csv similarity index 100% rename from benchmark/results/benchmark_v1.2.6.csv rename to _archive/benchmark/results/benchmark_v1.2.6.csv diff --git a/benchmark/results/benchmark_v1.3.0.csv b/_archive/benchmark/results/benchmark_v1.3.0.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.0.csv rename to _archive/benchmark/results/benchmark_v1.3.0.csv diff --git a/benchmark/results/benchmark_v1.3.1.csv b/_archive/benchmark/results/benchmark_v1.3.1.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.1.csv rename to _archive/benchmark/results/benchmark_v1.3.1.csv diff --git a/benchmark/results/benchmark_v1.3.2.csv b/_archive/benchmark/results/benchmark_v1.3.2.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.2.csv rename to _archive/benchmark/results/benchmark_v1.3.2.csv diff --git a/benchmark/results/benchmark_v1.3.3.csv b/_archive/benchmark/results/benchmark_v1.3.3.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.3.csv rename to _archive/benchmark/results/benchmark_v1.3.3.csv diff --git a/benchmark/results/benchmark_v1.3.4.csv b/_archive/benchmark/results/benchmark_v1.3.4.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.4.csv rename to _archive/benchmark/results/benchmark_v1.3.4.csv diff --git a/benchmark/results/benchmark_v1.3.5.csv b/_archive/benchmark/results/benchmark_v1.3.5.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.5.csv rename to _archive/benchmark/results/benchmark_v1.3.5.csv diff --git a/benchmark/results/benchmark_v1.3.6.csv b/_archive/benchmark/results/benchmark_v1.3.6.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.6.csv rename to _archive/benchmark/results/benchmark_v1.3.6.csv diff --git a/benchmark/results/benchmark_v1.3.7.csv b/_archive/benchmark/results/benchmark_v1.3.7.csv similarity index 100% rename from benchmark/results/benchmark_v1.3.7.csv rename to _archive/benchmark/results/benchmark_v1.3.7.csv diff --git a/benchmark/results/benchmark_v1.4.0.csv b/_archive/benchmark/results/benchmark_v1.4.0.csv similarity index 100% rename from benchmark/results/benchmark_v1.4.0.csv rename to _archive/benchmark/results/benchmark_v1.4.0.csv diff --git a/benchmark/results/benchmark_v1.4.1.csv b/_archive/benchmark/results/benchmark_v1.4.1.csv similarity index 100% rename from benchmark/results/benchmark_v1.4.1.csv rename to _archive/benchmark/results/benchmark_v1.4.1.csv diff --git a/benchmark/results/benchmark_v1.4.2.csv b/_archive/benchmark/results/benchmark_v1.4.2.csv similarity index 100% rename from benchmark/results/benchmark_v1.4.2.csv rename to _archive/benchmark/results/benchmark_v1.4.2.csv diff --git a/benchmark/results/benchmark_v1.5.0.csv b/_archive/benchmark/results/benchmark_v1.5.0.csv similarity index 100% rename from benchmark/results/benchmark_v1.5.0.csv rename to _archive/benchmark/results/benchmark_v1.5.0.csv diff --git a/benchmark/results/benchmark_v1.5.1.csv b/_archive/benchmark/results/benchmark_v1.5.1.csv similarity index 100% rename from benchmark/results/benchmark_v1.5.1.csv rename to _archive/benchmark/results/benchmark_v1.5.1.csv diff --git a/benchmark/results/benchmark_v1.5.2.csv b/_archive/benchmark/results/benchmark_v1.5.2.csv similarity index 100% rename from benchmark/results/benchmark_v1.5.2.csv rename to _archive/benchmark/results/benchmark_v1.5.2.csv diff --git a/benchmark/results/benchmark_v1.6.0.csv b/_archive/benchmark/results/benchmark_v1.6.0.csv similarity index 100% rename from benchmark/results/benchmark_v1.6.0.csv rename to _archive/benchmark/results/benchmark_v1.6.0.csv diff --git a/codecov.yml b/_archive/codecov.yml similarity index 100% rename from codecov.yml rename to _archive/codecov.yml diff --git a/codemeta.json b/_archive/codemeta.json similarity index 100% rename from codemeta.json rename to _archive/codemeta.json diff --git a/cran-comments.md b/_archive/cran-comments.md similarity index 100% rename from cran-comments.md rename to _archive/cran-comments.md diff --git a/data-raw/RJ-2021-053.pdf b/_archive/data-raw/RJ-2021-053.pdf similarity index 100% rename from data-raw/RJ-2021-053.pdf rename to _archive/data-raw/RJ-2021-053.pdf diff --git a/data-raw/crayon_images/Dan-SummaryTables.ai b/_archive/data-raw/crayon_images/Dan-SummaryTables.ai similarity index 100% rename from data-raw/crayon_images/Dan-SummaryTables.ai rename to _archive/data-raw/crayon_images/Dan-SummaryTables.ai diff --git a/data-raw/crayon_images/crayon-selectors-min.png b/_archive/data-raw/crayon_images/crayon-selectors-min.png similarity index 100% rename from data-raw/crayon_images/crayon-selectors-min.png rename to _archive/data-raw/crayon_images/crayon-selectors-min.png diff --git a/data-raw/crayon_images/crayon-selectors.png b/_archive/data-raw/crayon_images/crayon-selectors.png similarity index 100% rename from data-raw/crayon_images/crayon-selectors.png rename to _archive/data-raw/crayon_images/crayon-selectors.png diff --git a/data-raw/crayon_images/crayon-tbl_merge.png b/_archive/data-raw/crayon_images/crayon-tbl_merge.png similarity index 100% rename from data-raw/crayon_images/crayon-tbl_merge.png rename to _archive/data-raw/crayon_images/crayon-tbl_merge.png diff --git a/data-raw/crayon_images/crayon-tbl_regression.png b/_archive/data-raw/crayon_images/crayon-tbl_regression.png similarity index 100% rename from data-raw/crayon_images/crayon-tbl_regression.png rename to _archive/data-raw/crayon_images/crayon-tbl_regression.png diff --git a/data-raw/crayon_images/crayon-tbl_summary-args.png b/_archive/data-raw/crayon_images/crayon-tbl_summary-args.png similarity index 100% rename from data-raw/crayon_images/crayon-tbl_summary-args.png rename to _archive/data-raw/crayon_images/crayon-tbl_summary-args.png diff --git a/data-raw/crayon_images/crayon-tbl_summary-fns.png b/_archive/data-raw/crayon_images/crayon-tbl_summary-fns.png similarity index 100% rename from data-raw/crayon_images/crayon-tbl_summary-fns.png rename to _archive/data-raw/crayon_images/crayon-tbl_summary-fns.png diff --git a/data-raw/gt_doc_images.R b/_archive/data-raw/gt_doc_images.R similarity index 100% rename from data-raw/gt_doc_images.R rename to _archive/data-raw/gt_doc_images.R diff --git a/data-raw/gtsummary_tests.csv b/_archive/data-raw/gtsummary_tests.csv similarity index 100% rename from data-raw/gtsummary_tests.csv rename to _archive/data-raw/gtsummary_tests.csv diff --git a/data-raw/gtsummary_theme_elements.csv b/_archive/data-raw/gtsummary_theme_elements.csv similarity index 100% rename from data-raw/gtsummary_theme_elements.csv rename to _archive/data-raw/gtsummary_theme_elements.csv diff --git a/data-raw/gtsummary_translated.xlsx b/_archive/data-raw/gtsummary_translated.xlsx similarity index 100% rename from data-raw/gtsummary_translated.xlsx rename to _archive/data-raw/gtsummary_translated.xlsx diff --git a/data-raw/internal_data.R b/_archive/data-raw/internal_data.R similarity index 100% rename from data-raw/internal_data.R rename to _archive/data-raw/internal_data.R diff --git a/data-raw/misc_files/gtsummary-HexSticker.jpg b/_archive/data-raw/misc_files/gtsummary-HexSticker.jpg similarity index 100% rename from data-raw/misc_files/gtsummary-HexSticker.jpg rename to _archive/data-raw/misc_files/gtsummary-HexSticker.jpg diff --git a/data-raw/misc_files/gtsummary-HexSticker.pdf b/_archive/data-raw/misc_files/gtsummary-HexSticker.pdf similarity index 100% rename from data-raw/misc_files/gtsummary-HexSticker.pdf rename to _archive/data-raw/misc_files/gtsummary-HexSticker.pdf diff --git a/data-raw/misc_files/gtsummary-HexSticker.png b/_archive/data-raw/misc_files/gtsummary-HexSticker.png similarity index 100% rename from data-raw/misc_files/gtsummary-HexSticker.png rename to _archive/data-raw/misc_files/gtsummary-HexSticker.png diff --git a/data-raw/misc_files/inline_text_demo1.png b/_archive/data-raw/misc_files/inline_text_demo1.png similarity index 100% rename from data-raw/misc_files/inline_text_demo1.png rename to _archive/data-raw/misc_files/inline_text_demo1.png diff --git a/data-raw/misc_files/inlinetext_demo.gif b/_archive/data-raw/misc_files/inlinetext_demo.gif similarity index 100% rename from data-raw/misc_files/inlinetext_demo.gif rename to _archive/data-raw/misc_files/inlinetext_demo.gif diff --git a/data-raw/misc_files/model_sanity_check.Rmd b/_archive/data-raw/misc_files/model_sanity_check.Rmd similarity index 100% rename from data-raw/misc_files/model_sanity_check.Rmd rename to _archive/data-raw/misc_files/model_sanity_check.Rmd diff --git a/data-raw/misc_files/model_sanity_check.html b/_archive/data-raw/misc_files/model_sanity_check.html similarity index 100% rename from data-raw/misc_files/model_sanity_check.html rename to _archive/data-raw/misc_files/model_sanity_check.html diff --git a/data-raw/misc_files/tbl_mvregression_demo.gif b/_archive/data-raw/misc_files/tbl_mvregression_demo.gif similarity index 100% rename from data-raw/misc_files/tbl_mvregression_demo.gif rename to _archive/data-raw/misc_files/tbl_mvregression_demo.gif diff --git a/data-raw/misc_files/tbl_regression_demo2.gif b/_archive/data-raw/misc_files/tbl_regression_demo2.gif similarity index 100% rename from data-raw/misc_files/tbl_regression_demo2.gif rename to _archive/data-raw/misc_files/tbl_regression_demo2.gif diff --git a/data-raw/misc_files/tbl_regression_demo4.gif b/_archive/data-raw/misc_files/tbl_regression_demo4.gif similarity index 100% rename from data-raw/misc_files/tbl_regression_demo4.gif rename to _archive/data-raw/misc_files/tbl_regression_demo4.gif diff --git a/data-raw/misc_files/tbl_summary_demo1.gif b/_archive/data-raw/misc_files/tbl_summary_demo1.gif similarity index 100% rename from data-raw/misc_files/tbl_summary_demo1.gif rename to _archive/data-raw/misc_files/tbl_summary_demo1.gif diff --git a/data-raw/misc_files/tbl_summary_demo3.gif b/_archive/data-raw/misc_files/tbl_summary_demo3.gif similarity index 100% rename from data-raw/misc_files/tbl_summary_demo3.gif rename to _archive/data-raw/misc_files/tbl_summary_demo3.gif diff --git a/data-raw/misc_files/tbl_summary_demo4.gif b/_archive/data-raw/misc_files/tbl_summary_demo4.gif similarity index 100% rename from data-raw/misc_files/tbl_summary_demo4.gif rename to _archive/data-raw/misc_files/tbl_summary_demo4.gif diff --git a/data-raw/misc_files/tbl_summary_demo_fast.gif b/_archive/data-raw/misc_files/tbl_summary_demo_fast.gif similarity index 100% rename from data-raw/misc_files/tbl_summary_demo_fast.gif rename to _archive/data-raw/misc_files/tbl_summary_demo_fast.gif diff --git a/data-raw/trial.R b/_archive/data-raw/trial.R similarity index 100% rename from data-raw/trial.R rename to _archive/data-raw/trial.R diff --git a/data/trial.rda b/_archive/data/trial.rda similarity index 100% rename from data/trial.rda rename to _archive/data/trial.rda diff --git a/inst/CITATION b/_archive/inst/CITATION similarity index 100% rename from inst/CITATION rename to _archive/inst/CITATION diff --git a/inst/WORDLIST b/_archive/inst/WORDLIST similarity index 100% rename from inst/WORDLIST rename to _archive/inst/WORDLIST diff --git a/inst/rmarkdown_example/.gitignore b/_archive/inst/rmarkdown_example/.gitignore similarity index 100% rename from inst/rmarkdown_example/.gitignore rename to _archive/inst/rmarkdown_example/.gitignore diff --git a/inst/rmarkdown_example/gtsummary_rmarkdown_html.Rmd b/_archive/inst/rmarkdown_example/gtsummary_rmarkdown_html.Rmd similarity index 100% rename from inst/rmarkdown_example/gtsummary_rmarkdown_html.Rmd rename to _archive/inst/rmarkdown_example/gtsummary_rmarkdown_html.Rmd diff --git a/man-images/add_ci_ex1.png b/_archive/man-images/add_ci_ex1.png similarity index 100% rename from man-images/add_ci_ex1.png rename to _archive/man-images/add_ci_ex1.png diff --git a/man-images/add_ci_ex2.png b/_archive/man-images/add_ci_ex2.png similarity index 100% rename from man-images/add_ci_ex2.png rename to _archive/man-images/add_ci_ex2.png diff --git a/man-images/add_ci_ex3.png b/_archive/man-images/add_ci_ex3.png similarity index 100% rename from man-images/add_ci_ex3.png rename to _archive/man-images/add_ci_ex3.png diff --git a/man-images/add_difference_ex1.png b/_archive/man-images/add_difference_ex1.png similarity index 100% rename from man-images/add_difference_ex1.png rename to _archive/man-images/add_difference_ex1.png diff --git a/man-images/add_difference_ex2.png b/_archive/man-images/add_difference_ex2.png similarity index 100% rename from man-images/add_difference_ex2.png rename to _archive/man-images/add_difference_ex2.png diff --git a/man-images/add_glance_ex1.png b/_archive/man-images/add_glance_ex1.png similarity index 100% rename from man-images/add_glance_ex1.png rename to _archive/man-images/add_glance_ex1.png diff --git a/man-images/add_glance_ex2.png b/_archive/man-images/add_glance_ex2.png similarity index 100% rename from man-images/add_glance_ex2.png rename to _archive/man-images/add_glance_ex2.png diff --git a/man-images/add_n.tbl_regression_ex1.png b/_archive/man-images/add_n.tbl_regression_ex1.png similarity index 100% rename from man-images/add_n.tbl_regression_ex1.png rename to _archive/man-images/add_n.tbl_regression_ex1.png diff --git a/man-images/add_n.tbl_regression_ex2.png b/_archive/man-images/add_n.tbl_regression_ex2.png similarity index 100% rename from man-images/add_n.tbl_regression_ex2.png rename to _archive/man-images/add_n.tbl_regression_ex2.png diff --git a/man-images/add_n.tbl_survfit_ex1.png b/_archive/man-images/add_n.tbl_survfit_ex1.png similarity index 100% rename from man-images/add_n.tbl_survfit_ex1.png rename to _archive/man-images/add_n.tbl_survfit_ex1.png diff --git a/man-images/add_nevent.tbl_regression_ex1.png b/_archive/man-images/add_nevent.tbl_regression_ex1.png similarity index 100% rename from man-images/add_nevent.tbl_regression_ex1.png rename to _archive/man-images/add_nevent.tbl_regression_ex1.png diff --git a/man-images/add_nevent.tbl_regression_ex2.png b/_archive/man-images/add_nevent.tbl_regression_ex2.png similarity index 100% rename from man-images/add_nevent.tbl_regression_ex2.png rename to _archive/man-images/add_nevent.tbl_regression_ex2.png diff --git a/man-images/add_nevent.tbl_survfit_ex1.png b/_archive/man-images/add_nevent.tbl_survfit_ex1.png similarity index 100% rename from man-images/add_nevent.tbl_survfit_ex1.png rename to _archive/man-images/add_nevent.tbl_survfit_ex1.png diff --git a/man-images/add_p_continuous_ex1.png b/_archive/man-images/add_p_continuous_ex1.png similarity index 100% rename from man-images/add_p_continuous_ex1.png rename to _archive/man-images/add_p_continuous_ex1.png diff --git a/man-images/add_p_cross_ex1.png b/_archive/man-images/add_p_cross_ex1.png similarity index 100% rename from man-images/add_p_cross_ex1.png rename to _archive/man-images/add_p_cross_ex1.png diff --git a/man-images/add_p_cross_ex2.png b/_archive/man-images/add_p_cross_ex2.png similarity index 100% rename from man-images/add_p_cross_ex2.png rename to _archive/man-images/add_p_cross_ex2.png diff --git a/man-images/add_p_ex1.png b/_archive/man-images/add_p_ex1.png similarity index 100% rename from man-images/add_p_ex1.png rename to _archive/man-images/add_p_ex1.png diff --git a/man-images/add_p_ex2.png b/_archive/man-images/add_p_ex2.png similarity index 100% rename from man-images/add_p_ex2.png rename to _archive/man-images/add_p_ex2.png diff --git a/man-images/add_p_svysummary_ex1.png b/_archive/man-images/add_p_svysummary_ex1.png similarity index 100% rename from man-images/add_p_svysummary_ex1.png rename to _archive/man-images/add_p_svysummary_ex1.png diff --git a/man-images/add_p_svysummary_ex2.png b/_archive/man-images/add_p_svysummary_ex2.png similarity index 100% rename from man-images/add_p_svysummary_ex2.png rename to _archive/man-images/add_p_svysummary_ex2.png diff --git a/man-images/add_p_svysummary_ex3.png b/_archive/man-images/add_p_svysummary_ex3.png similarity index 100% rename from man-images/add_p_svysummary_ex3.png rename to _archive/man-images/add_p_svysummary_ex3.png diff --git a/man-images/add_p_tbl_survfit_ex1.png b/_archive/man-images/add_p_tbl_survfit_ex1.png similarity index 100% rename from man-images/add_p_tbl_survfit_ex1.png rename to _archive/man-images/add_p_tbl_survfit_ex1.png diff --git a/man-images/add_p_tbl_survfit_ex2.png b/_archive/man-images/add_p_tbl_survfit_ex2.png similarity index 100% rename from man-images/add_p_tbl_survfit_ex2.png rename to _archive/man-images/add_p_tbl_survfit_ex2.png diff --git a/man-images/add_q_ex1.png b/_archive/man-images/add_q_ex1.png similarity index 100% rename from man-images/add_q_ex1.png rename to _archive/man-images/add_q_ex1.png diff --git a/man-images/add_q_ex2.png b/_archive/man-images/add_q_ex2.png similarity index 100% rename from man-images/add_q_ex2.png rename to _archive/man-images/add_q_ex2.png diff --git a/man-images/add_significance_stars_ex1.png b/_archive/man-images/add_significance_stars_ex1.png similarity index 100% rename from man-images/add_significance_stars_ex1.png rename to _archive/man-images/add_significance_stars_ex1.png diff --git a/man-images/add_significance_stars_ex2.png b/_archive/man-images/add_significance_stars_ex2.png similarity index 100% rename from man-images/add_significance_stars_ex2.png rename to _archive/man-images/add_significance_stars_ex2.png diff --git a/man-images/add_significance_stars_ex3.png b/_archive/man-images/add_significance_stars_ex3.png similarity index 100% rename from man-images/add_significance_stars_ex3.png rename to _archive/man-images/add_significance_stars_ex3.png diff --git a/man-images/add_significance_stars_ex4.png b/_archive/man-images/add_significance_stars_ex4.png similarity index 100% rename from man-images/add_significance_stars_ex4.png rename to _archive/man-images/add_significance_stars_ex4.png diff --git a/man-images/add_stat_ex1.png b/_archive/man-images/add_stat_ex1.png similarity index 100% rename from man-images/add_stat_ex1.png rename to _archive/man-images/add_stat_ex1.png diff --git a/man-images/add_stat_ex2.png b/_archive/man-images/add_stat_ex2.png similarity index 100% rename from man-images/add_stat_ex2.png rename to _archive/man-images/add_stat_ex2.png diff --git a/man-images/add_stat_ex3.png b/_archive/man-images/add_stat_ex3.png similarity index 100% rename from man-images/add_stat_ex3.png rename to _archive/man-images/add_stat_ex3.png diff --git a/man-images/add_stat_label_ex1.png b/_archive/man-images/add_stat_label_ex1.png similarity index 100% rename from man-images/add_stat_label_ex1.png rename to _archive/man-images/add_stat_label_ex1.png diff --git a/man-images/add_stat_label_ex2.png b/_archive/man-images/add_stat_label_ex2.png similarity index 100% rename from man-images/add_stat_label_ex2.png rename to _archive/man-images/add_stat_label_ex2.png diff --git a/man-images/add_stat_label_ex3.png b/_archive/man-images/add_stat_label_ex3.png similarity index 100% rename from man-images/add_stat_label_ex3.png rename to _archive/man-images/add_stat_label_ex3.png diff --git a/man-images/add_vif_ex1.png b/_archive/man-images/add_vif_ex1.png similarity index 100% rename from man-images/add_vif_ex1.png rename to _archive/man-images/add_vif_ex1.png diff --git a/man-images/add_vif_ex2.png b/_archive/man-images/add_vif_ex2.png similarity index 100% rename from man-images/add_vif_ex2.png rename to _archive/man-images/add_vif_ex2.png diff --git a/man-images/as_flex_table_ex1.png b/_archive/man-images/as_flex_table_ex1.png similarity index 100% rename from man-images/as_flex_table_ex1.png rename to _archive/man-images/as_flex_table_ex1.png diff --git a/man-images/as_gt_ex1.png b/_archive/man-images/as_gt_ex1.png similarity index 100% rename from man-images/as_gt_ex1.png rename to _archive/man-images/as_gt_ex1.png diff --git a/man-images/as_kable_extra_ex1_pdf.png b/_archive/man-images/as_kable_extra_ex1_pdf.png similarity index 100% rename from man-images/as_kable_extra_ex1_pdf.png rename to _archive/man-images/as_kable_extra_ex1_pdf.png diff --git a/man-images/as_kable_extra_ex2_pdf.png b/_archive/man-images/as_kable_extra_ex2_pdf.png similarity index 100% rename from man-images/as_kable_extra_ex2_pdf.png rename to _archive/man-images/as_kable_extra_ex2_pdf.png diff --git a/man-images/bold_p_ex1.png b/_archive/man-images/bold_p_ex1.png similarity index 100% rename from man-images/bold_p_ex1.png rename to _archive/man-images/bold_p_ex1.png diff --git a/man-images/bold_p_ex2.png b/_archive/man-images/bold_p_ex2.png similarity index 100% rename from man-images/bold_p_ex2.png rename to _archive/man-images/bold_p_ex2.png diff --git a/man-images/combine_terms_ex1.png b/_archive/man-images/combine_terms_ex1.png similarity index 100% rename from man-images/combine_terms_ex1.png rename to _archive/man-images/combine_terms_ex1.png diff --git a/man-images/continuous_summary_ex1.png b/_archive/man-images/continuous_summary_ex1.png similarity index 100% rename from man-images/continuous_summary_ex1.png rename to _archive/man-images/continuous_summary_ex1.png diff --git a/man-images/inline_text_ex1.png b/_archive/man-images/inline_text_ex1.png similarity index 100% rename from man-images/inline_text_ex1.png rename to _archive/man-images/inline_text_ex1.png diff --git a/man-images/modify_column_hide_ex1.png b/_archive/man-images/modify_column_hide_ex1.png similarity index 100% rename from man-images/modify_column_hide_ex1.png rename to _archive/man-images/modify_column_hide_ex1.png diff --git a/man-images/modify_column_indent_ex1.png b/_archive/man-images/modify_column_indent_ex1.png similarity index 100% rename from man-images/modify_column_indent_ex1.png rename to _archive/man-images/modify_column_indent_ex1.png diff --git a/man-images/modify_column_merge_ex1.png b/_archive/man-images/modify_column_merge_ex1.png similarity index 100% rename from man-images/modify_column_merge_ex1.png rename to _archive/man-images/modify_column_merge_ex1.png diff --git a/man-images/modify_column_merge_ex2.png b/_archive/man-images/modify_column_merge_ex2.png similarity index 100% rename from man-images/modify_column_merge_ex2.png rename to _archive/man-images/modify_column_merge_ex2.png diff --git a/man-images/modify_ex1.png b/_archive/man-images/modify_ex1.png similarity index 100% rename from man-images/modify_ex1.png rename to _archive/man-images/modify_ex1.png diff --git a/man-images/modify_ex2.png b/_archive/man-images/modify_ex2.png similarity index 100% rename from man-images/modify_ex2.png rename to _archive/man-images/modify_ex2.png diff --git a/man-images/modify_ex3.png b/_archive/man-images/modify_ex3.png similarity index 100% rename from man-images/modify_ex3.png rename to _archive/man-images/modify_ex3.png diff --git a/man-images/modify_fmt_fun_ex1.png b/_archive/man-images/modify_fmt_fun_ex1.png similarity index 100% rename from man-images/modify_fmt_fun_ex1.png rename to _archive/man-images/modify_fmt_fun_ex1.png diff --git a/man-images/modify_table_body_ex1.png b/_archive/man-images/modify_table_body_ex1.png similarity index 100% rename from man-images/modify_table_body_ex1.png rename to _archive/man-images/modify_table_body_ex1.png diff --git a/man-images/pool_and_tidy_mice_ex3.png b/_archive/man-images/pool_and_tidy_mice_ex3.png similarity index 100% rename from man-images/pool_and_tidy_mice_ex3.png rename to _archive/man-images/pool_and_tidy_mice_ex3.png diff --git a/man-images/proportion_summary_ex1.png b/_archive/man-images/proportion_summary_ex1.png similarity index 100% rename from man-images/proportion_summary_ex1.png rename to _archive/man-images/proportion_summary_ex1.png diff --git a/man-images/ratio_summary_ex1.png b/_archive/man-images/ratio_summary_ex1.png similarity index 100% rename from man-images/ratio_summary_ex1.png rename to _archive/man-images/ratio_summary_ex1.png diff --git a/man-images/remove_row_type_ex1.png b/_archive/man-images/remove_row_type_ex1.png similarity index 100% rename from man-images/remove_row_type_ex1.png rename to _archive/man-images/remove_row_type_ex1.png diff --git a/man-images/select_ex1.png b/_archive/man-images/select_ex1.png similarity index 100% rename from man-images/select_ex1.png rename to _archive/man-images/select_ex1.png diff --git a/man-images/separate_p_footnotes_ex1.png b/_archive/man-images/separate_p_footnotes_ex1.png similarity index 100% rename from man-images/separate_p_footnotes_ex1.png rename to _archive/man-images/separate_p_footnotes_ex1.png diff --git a/man-images/set_gtsummary_theme_ex1.png b/_archive/man-images/set_gtsummary_theme_ex1.png similarity index 100% rename from man-images/set_gtsummary_theme_ex1.png rename to _archive/man-images/set_gtsummary_theme_ex1.png diff --git a/man-images/sort_filter_p_ex1.png b/_archive/man-images/sort_filter_p_ex1.png similarity index 100% rename from man-images/sort_filter_p_ex1.png rename to _archive/man-images/sort_filter_p_ex1.png diff --git a/man-images/sort_p_ex2.png b/_archive/man-images/sort_p_ex2.png similarity index 100% rename from man-images/sort_p_ex2.png rename to _archive/man-images/sort_p_ex2.png diff --git a/man-images/survfit_cr_ex4.png b/_archive/man-images/survfit_cr_ex4.png similarity index 100% rename from man-images/survfit_cr_ex4.png rename to _archive/man-images/survfit_cr_ex4.png diff --git a/man-images/tbl_bold_ital_ex1.png b/_archive/man-images/tbl_bold_ital_ex1.png similarity index 100% rename from man-images/tbl_bold_ital_ex1.png rename to _archive/man-images/tbl_bold_ital_ex1.png diff --git a/man-images/tbl_continuous_ex1.png b/_archive/man-images/tbl_continuous_ex1.png similarity index 100% rename from man-images/tbl_continuous_ex1.png rename to _archive/man-images/tbl_continuous_ex1.png diff --git a/man-images/tbl_continuous_ex2.png b/_archive/man-images/tbl_continuous_ex2.png similarity index 100% rename from man-images/tbl_continuous_ex2.png rename to _archive/man-images/tbl_continuous_ex2.png diff --git a/man-images/tbl_cross_ex1.png b/_archive/man-images/tbl_cross_ex1.png similarity index 100% rename from man-images/tbl_cross_ex1.png rename to _archive/man-images/tbl_cross_ex1.png diff --git a/man-images/tbl_cross_ex2.png b/_archive/man-images/tbl_cross_ex2.png similarity index 100% rename from man-images/tbl_cross_ex2.png rename to _archive/man-images/tbl_cross_ex2.png diff --git a/man-images/tbl_custom_summary_ex1.png b/_archive/man-images/tbl_custom_summary_ex1.png similarity index 100% rename from man-images/tbl_custom_summary_ex1.png rename to _archive/man-images/tbl_custom_summary_ex1.png diff --git a/man-images/tbl_custom_summary_ex2.png b/_archive/man-images/tbl_custom_summary_ex2.png similarity index 100% rename from man-images/tbl_custom_summary_ex2.png rename to _archive/man-images/tbl_custom_summary_ex2.png diff --git a/man-images/tbl_custom_summary_ex3.png b/_archive/man-images/tbl_custom_summary_ex3.png similarity index 100% rename from man-images/tbl_custom_summary_ex3.png rename to _archive/man-images/tbl_custom_summary_ex3.png diff --git a/man-images/tbl_lm_global_ex1.png b/_archive/man-images/tbl_lm_global_ex1.png similarity index 100% rename from man-images/tbl_lm_global_ex1.png rename to _archive/man-images/tbl_lm_global_ex1.png diff --git a/man-images/tbl_merge_ex1.png b/_archive/man-images/tbl_merge_ex1.png similarity index 100% rename from man-images/tbl_merge_ex1.png rename to _archive/man-images/tbl_merge_ex1.png diff --git a/man-images/tbl_merge_ex2.png b/_archive/man-images/tbl_merge_ex2.png similarity index 100% rename from man-images/tbl_merge_ex2.png rename to _archive/man-images/tbl_merge_ex2.png diff --git a/man-images/tbl_n_ex.png b/_archive/man-images/tbl_n_ex.png similarity index 100% rename from man-images/tbl_n_ex.png rename to _archive/man-images/tbl_n_ex.png diff --git a/man-images/tbl_overall_ex1.png b/_archive/man-images/tbl_overall_ex1.png similarity index 100% rename from man-images/tbl_overall_ex1.png rename to _archive/man-images/tbl_overall_ex1.png diff --git a/man-images/tbl_overall_ex2.png b/_archive/man-images/tbl_overall_ex2.png similarity index 100% rename from man-images/tbl_overall_ex2.png rename to _archive/man-images/tbl_overall_ex2.png diff --git a/man-images/tbl_overall_ex3.png b/_archive/man-images/tbl_overall_ex3.png similarity index 100% rename from man-images/tbl_overall_ex3.png rename to _archive/man-images/tbl_overall_ex3.png diff --git a/man-images/tbl_regression_ex1.png b/_archive/man-images/tbl_regression_ex1.png similarity index 100% rename from man-images/tbl_regression_ex1.png rename to _archive/man-images/tbl_regression_ex1.png diff --git a/man-images/tbl_regression_ex2.png b/_archive/man-images/tbl_regression_ex2.png similarity index 100% rename from man-images/tbl_regression_ex2.png rename to _archive/man-images/tbl_regression_ex2.png diff --git a/man-images/tbl_regression_ex3.png b/_archive/man-images/tbl_regression_ex3.png similarity index 100% rename from man-images/tbl_regression_ex3.png rename to _archive/man-images/tbl_regression_ex3.png diff --git a/man-images/tbl_stack_ex1.png b/_archive/man-images/tbl_stack_ex1.png similarity index 100% rename from man-images/tbl_stack_ex1.png rename to _archive/man-images/tbl_stack_ex1.png diff --git a/man-images/tbl_stack_ex2.png b/_archive/man-images/tbl_stack_ex2.png similarity index 100% rename from man-images/tbl_stack_ex2.png rename to _archive/man-images/tbl_stack_ex2.png diff --git a/man-images/tbl_strata_ex1.png b/_archive/man-images/tbl_strata_ex1.png similarity index 100% rename from man-images/tbl_strata_ex1.png rename to _archive/man-images/tbl_strata_ex1.png diff --git a/man-images/tbl_strata_ex2.png b/_archive/man-images/tbl_strata_ex2.png similarity index 100% rename from man-images/tbl_strata_ex2.png rename to _archive/man-images/tbl_strata_ex2.png diff --git a/man-images/tbl_summary_ex1.png b/_archive/man-images/tbl_summary_ex1.png similarity index 100% rename from man-images/tbl_summary_ex1.png rename to _archive/man-images/tbl_summary_ex1.png diff --git a/man-images/tbl_summary_ex2.png b/_archive/man-images/tbl_summary_ex2.png similarity index 100% rename from man-images/tbl_summary_ex2.png rename to _archive/man-images/tbl_summary_ex2.png diff --git a/man-images/tbl_summary_ex3.png b/_archive/man-images/tbl_summary_ex3.png similarity index 100% rename from man-images/tbl_summary_ex3.png rename to _archive/man-images/tbl_summary_ex3.png diff --git a/man-images/tbl_summary_ex4.png b/_archive/man-images/tbl_summary_ex4.png similarity index 100% rename from man-images/tbl_summary_ex4.png rename to _archive/man-images/tbl_summary_ex4.png diff --git a/man-images/tbl_survfit_ex1.png b/_archive/man-images/tbl_survfit_ex1.png similarity index 100% rename from man-images/tbl_survfit_ex1.png rename to _archive/man-images/tbl_survfit_ex1.png diff --git a/man-images/tbl_survfit_ex2.png b/_archive/man-images/tbl_survfit_ex2.png similarity index 100% rename from man-images/tbl_survfit_ex2.png rename to _archive/man-images/tbl_survfit_ex2.png diff --git a/man-images/tbl_survfit_ex3.png b/_archive/man-images/tbl_survfit_ex3.png similarity index 100% rename from man-images/tbl_survfit_ex3.png rename to _archive/man-images/tbl_survfit_ex3.png diff --git a/man-images/tbl_svysummary_ex1.png b/_archive/man-images/tbl_svysummary_ex1.png similarity index 100% rename from man-images/tbl_svysummary_ex1.png rename to _archive/man-images/tbl_svysummary_ex1.png diff --git a/man-images/tbl_svysummary_ex2.png b/_archive/man-images/tbl_svysummary_ex2.png similarity index 100% rename from man-images/tbl_svysummary_ex2.png rename to _archive/man-images/tbl_svysummary_ex2.png diff --git a/man-images/tbl_uv_ex1.png b/_archive/man-images/tbl_uv_ex1.png similarity index 100% rename from man-images/tbl_uv_ex1.png rename to _archive/man-images/tbl_uv_ex1.png diff --git a/man-images/tbl_uv_ex2.png b/_archive/man-images/tbl_uv_ex2.png similarity index 100% rename from man-images/tbl_uv_ex2.png rename to _archive/man-images/tbl_uv_ex2.png diff --git a/man-images/tbl_uv_global_ex2.png b/_archive/man-images/tbl_uv_global_ex2.png similarity index 100% rename from man-images/tbl_uv_global_ex2.png rename to _archive/man-images/tbl_uv_global_ex2.png diff --git a/man-images/tidy_standardize_ex1.png b/_archive/man-images/tidy_standardize_ex1.png similarity index 100% rename from man-images/tidy_standardize_ex1.png rename to _archive/man-images/tidy_standardize_ex1.png diff --git a/man-images/tidy_standardize_ex2.png b/_archive/man-images/tidy_standardize_ex2.png similarity index 100% rename from man-images/tidy_standardize_ex2.png rename to _archive/man-images/tidy_standardize_ex2.png diff --git a/man/add_ci.Rd b/_archive/man/add_ci.Rd similarity index 100% rename from man/add_ci.Rd rename to _archive/man/add_ci.Rd diff --git a/man/add_difference.Rd b/_archive/man/add_difference.Rd similarity index 100% rename from man/add_difference.Rd rename to _archive/man/add_difference.Rd diff --git a/man/add_glance.Rd b/_archive/man/add_glance.Rd similarity index 100% rename from man/add_glance.Rd rename to _archive/man/add_glance.Rd diff --git a/man/add_global_p.Rd b/_archive/man/add_global_p.Rd similarity index 100% rename from man/add_global_p.Rd rename to _archive/man/add_global_p.Rd diff --git a/man/add_n.Rd b/_archive/man/add_n.Rd similarity index 100% rename from man/add_n.Rd rename to _archive/man/add_n.Rd diff --git a/man/add_n.tbl_summary.Rd b/_archive/man/add_n.tbl_summary.Rd similarity index 100% rename from man/add_n.tbl_summary.Rd rename to _archive/man/add_n.tbl_summary.Rd diff --git a/man/add_n.tbl_survfit.Rd b/_archive/man/add_n.tbl_survfit.Rd similarity index 100% rename from man/add_n.tbl_survfit.Rd rename to _archive/man/add_n.tbl_survfit.Rd diff --git a/man/add_n_regression.Rd b/_archive/man/add_n_regression.Rd similarity index 100% rename from man/add_n_regression.Rd rename to _archive/man/add_n_regression.Rd diff --git a/man/add_nevent.Rd b/_archive/man/add_nevent.Rd similarity index 100% rename from man/add_nevent.Rd rename to _archive/man/add_nevent.Rd diff --git a/man/add_nevent.tbl_survfit.Rd b/_archive/man/add_nevent.tbl_survfit.Rd similarity index 100% rename from man/add_nevent.tbl_survfit.Rd rename to _archive/man/add_nevent.tbl_survfit.Rd diff --git a/man/add_nevent_regression.Rd b/_archive/man/add_nevent_regression.Rd similarity index 100% rename from man/add_nevent_regression.Rd rename to _archive/man/add_nevent_regression.Rd diff --git a/man/add_overall.Rd b/_archive/man/add_overall.Rd similarity index 100% rename from man/add_overall.Rd rename to _archive/man/add_overall.Rd diff --git a/man/add_p.Rd b/_archive/man/add_p.Rd similarity index 100% rename from man/add_p.Rd rename to _archive/man/add_p.Rd diff --git a/man/add_p.tbl_continuous.Rd b/_archive/man/add_p.tbl_continuous.Rd similarity index 100% rename from man/add_p.tbl_continuous.Rd rename to _archive/man/add_p.tbl_continuous.Rd diff --git a/man/add_p.tbl_cross.Rd b/_archive/man/add_p.tbl_cross.Rd similarity index 100% rename from man/add_p.tbl_cross.Rd rename to _archive/man/add_p.tbl_cross.Rd diff --git a/man/add_p.tbl_summary.Rd b/_archive/man/add_p.tbl_summary.Rd similarity index 100% rename from man/add_p.tbl_summary.Rd rename to _archive/man/add_p.tbl_summary.Rd diff --git a/man/add_p.tbl_survfit.Rd b/_archive/man/add_p.tbl_survfit.Rd similarity index 100% rename from man/add_p.tbl_survfit.Rd rename to _archive/man/add_p.tbl_survfit.Rd diff --git a/man/add_p.tbl_svysummary.Rd b/_archive/man/add_p.tbl_svysummary.Rd similarity index 100% rename from man/add_p.tbl_svysummary.Rd rename to _archive/man/add_p.tbl_svysummary.Rd diff --git a/man/add_q.Rd b/_archive/man/add_q.Rd similarity index 100% rename from man/add_q.Rd rename to _archive/man/add_q.Rd diff --git a/man/add_significance_stars.Rd b/_archive/man/add_significance_stars.Rd similarity index 100% rename from man/add_significance_stars.Rd rename to _archive/man/add_significance_stars.Rd diff --git a/man/add_stat.Rd b/_archive/man/add_stat.Rd similarity index 100% rename from man/add_stat.Rd rename to _archive/man/add_stat.Rd diff --git a/man/add_stat_label.Rd b/_archive/man/add_stat_label.Rd similarity index 100% rename from man/add_stat_label.Rd rename to _archive/man/add_stat_label.Rd diff --git a/man/add_vif.Rd b/_archive/man/add_vif.Rd similarity index 100% rename from man/add_vif.Rd rename to _archive/man/add_vif.Rd diff --git a/man/as_flex_table.Rd b/_archive/man/as_flex_table.Rd similarity index 100% rename from man/as_flex_table.Rd rename to _archive/man/as_flex_table.Rd diff --git a/_archive/man/as_gt.Rd b/_archive/man/as_gt.Rd new file mode 100644 index 0000000000..d73e51c97c --- /dev/null +++ b/_archive/man/as_gt.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/as_gt.R +\name{as_gt} +\alias{as_gt} +\title{Convert gtsummary object to a gt object} +\usage{ +as_gt(x, include = everything(), return_calls = FALSE, ...) +} +\arguments{ +\item{x}{Object created by a function from the gtsummary package +(e.g. \link{tbl_summary} or \link{tbl_regression})} + +\item{include}{Commands to include in output. Input may be a vector of +quoted or unquoted names. tidyselect and gtsummary select helper +functions are also accepted. +Default is \code{everything()}.} + +\item{return_calls}{Logical. Default is \code{FALSE}. If \code{TRUE}, the calls are returned +as a list of expressions.} + +\item{...}{Arguments passed on to \link[gt:gt]{gt::gt}} +} +\value{ +A \code{gt_tbl} object +} +\description{ +Function converts a gtsummary object to a \code{"gt_tbl"} object, +that is, a table created with \code{gt::gt()}. +Function is used in the background when the results are printed or knit. +A user can use this function if they wish to add customized formatting +available via the \href{https://gt.rstudio.com/index.html}{gt package}. + +Review the +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#advanced}{tbl_summary vignette} +or +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html#advanced}{tbl_regression vignette} +for detailed examples in the 'Advanced Customization' section. +} +\section{Example Output}{ + + +\if{html}{Example 1} + +\if{html}{\out{ +image of rendered example table +}} +} + +\examples{ +# Example 1 ---------------------------------- +as_gt_ex1 <- + trial[c("trt", "age", "response", "grade")] \%>\% + tbl_summary(by = trt) \%>\% + as_gt() +} +\seealso{ +Other gtsummary output types: +\code{\link{as_flex_table}()}, +\code{\link{as_hux_table}()}, +\code{\link{as_kable_extra}()}, +\code{\link{as_kable}()}, +\code{\link{as_tibble.gtsummary}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{gtsummary output types} diff --git a/man/as_hux_table.Rd b/_archive/man/as_hux_table.Rd similarity index 100% rename from man/as_hux_table.Rd rename to _archive/man/as_hux_table.Rd diff --git a/man/as_kable.Rd b/_archive/man/as_kable.Rd similarity index 100% rename from man/as_kable.Rd rename to _archive/man/as_kable.Rd diff --git a/man/as_kable_extra.Rd b/_archive/man/as_kable_extra.Rd similarity index 100% rename from man/as_kable_extra.Rd rename to _archive/man/as_kable_extra.Rd diff --git a/man/as_tibble.gtsummary.Rd b/_archive/man/as_tibble.gtsummary.Rd similarity index 100% rename from man/as_tibble.gtsummary.Rd rename to _archive/man/as_tibble.gtsummary.Rd diff --git a/man/bold_italicize_labels_levels.Rd b/_archive/man/bold_italicize_labels_levels.Rd similarity index 100% rename from man/bold_italicize_labels_levels.Rd rename to _archive/man/bold_italicize_labels_levels.Rd diff --git a/man/bold_p.Rd b/_archive/man/bold_p.Rd similarity index 100% rename from man/bold_p.Rd rename to _archive/man/bold_p.Rd diff --git a/man/combine_terms.Rd b/_archive/man/combine_terms.Rd similarity index 100% rename from man/combine_terms.Rd rename to _archive/man/combine_terms.Rd diff --git a/man/continuous_summary.Rd b/_archive/man/continuous_summary.Rd similarity index 100% rename from man/continuous_summary.Rd rename to _archive/man/continuous_summary.Rd diff --git a/man/custom_tidiers.Rd b/_archive/man/custom_tidiers.Rd similarity index 100% rename from man/custom_tidiers.Rd rename to _archive/man/custom_tidiers.Rd diff --git a/man/deprecated.Rd b/_archive/man/deprecated.Rd similarity index 100% rename from man/deprecated.Rd rename to _archive/man/deprecated.Rd diff --git a/man/dot-create_gtsummary_object.Rd b/_archive/man/dot-create_gtsummary_object.Rd similarity index 100% rename from man/dot-create_gtsummary_object.Rd rename to _archive/man/dot-create_gtsummary_object.Rd diff --git a/_archive/man/dot-table_styling_expr_to_row_number.Rd b/_archive/man/dot-table_styling_expr_to_row_number.Rd new file mode 100644 index 0000000000..426fc79c5e --- /dev/null +++ b/_archive/man/dot-table_styling_expr_to_row_number.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-as.R +\name{.table_styling_expr_to_row_number} +\alias{.table_styling_expr_to_row_number} +\title{Object Convert Helper} +\usage{ +.table_styling_expr_to_row_number(x) +} +\arguments{ +\item{x}{a gtsummary object} +} +\value{ +a gtsummary object +} +\description{ +Ahead of a gtsummary object being converted to an output type, +each logical expression saved in \code{x$table_styling} is converted to a +list of row numbers. +} +\examples{ +tbl <- + trial \%>\% + tbl_summary(include = c(age, grade)) \%>\% + .table_styling_expr_to_row_number() +} +\keyword{internal} diff --git a/man/figures/README-tbl_merge_ex1-1.png b/_archive/man/figures/README-tbl_merge_ex1-1.png similarity index 100% rename from man/figures/README-tbl_merge_ex1-1.png rename to _archive/man/figures/README-tbl_merge_ex1-1.png diff --git a/man/figures/README-tbl_regression_printa-1.png b/_archive/man/figures/README-tbl_regression_printa-1.png similarity index 100% rename from man/figures/README-tbl_regression_printa-1.png rename to _archive/man/figures/README-tbl_regression_printa-1.png diff --git a/man/figures/README-tbl_summary_print_extra-1.png b/_archive/man/figures/README-tbl_summary_print_extra-1.png similarity index 100% rename from man/figures/README-tbl_summary_print_extra-1.png rename to _archive/man/figures/README-tbl_summary_print_extra-1.png diff --git a/man/figures/README-tbl_summary_print_simple-1.png b/_archive/man/figures/README-tbl_summary_print_simple-1.png similarity index 100% rename from man/figures/README-tbl_summary_print_simple-1.png rename to _archive/man/figures/README-tbl_summary_print_simple-1.png diff --git a/man/figures/gt_output_formats.PNG b/_archive/man/figures/gt_output_formats.PNG similarity index 100% rename from man/figures/gt_output_formats.PNG rename to _archive/man/figures/gt_output_formats.PNG diff --git a/man/figures/gtsummary_logo.PNG b/_archive/man/figures/gtsummary_logo.PNG similarity index 100% rename from man/figures/gtsummary_logo.PNG rename to _archive/man/figures/gtsummary_logo.PNG diff --git a/man/figures/lifecycle-archived.svg b/_archive/man/figures/lifecycle-archived.svg similarity index 100% rename from man/figures/lifecycle-archived.svg rename to _archive/man/figures/lifecycle-archived.svg diff --git a/man/figures/lifecycle-defunct.svg b/_archive/man/figures/lifecycle-defunct.svg similarity index 100% rename from man/figures/lifecycle-defunct.svg rename to _archive/man/figures/lifecycle-defunct.svg diff --git a/man/figures/lifecycle-deprecated.svg b/_archive/man/figures/lifecycle-deprecated.svg similarity index 100% rename from man/figures/lifecycle-deprecated.svg rename to _archive/man/figures/lifecycle-deprecated.svg diff --git a/man/figures/lifecycle-experimental.svg b/_archive/man/figures/lifecycle-experimental.svg similarity index 100% rename from man/figures/lifecycle-experimental.svg rename to _archive/man/figures/lifecycle-experimental.svg diff --git a/man/figures/lifecycle-maturing.svg b/_archive/man/figures/lifecycle-maturing.svg similarity index 100% rename from man/figures/lifecycle-maturing.svg rename to _archive/man/figures/lifecycle-maturing.svg diff --git a/man/figures/lifecycle-questioning.svg b/_archive/man/figures/lifecycle-questioning.svg similarity index 100% rename from man/figures/lifecycle-questioning.svg rename to _archive/man/figures/lifecycle-questioning.svg diff --git a/man/figures/lifecycle-retired.svg b/_archive/man/figures/lifecycle-retired.svg similarity index 100% rename from man/figures/lifecycle-retired.svg rename to _archive/man/figures/lifecycle-retired.svg diff --git a/man/figures/lifecycle-soft-deprecated.svg b/_archive/man/figures/lifecycle-soft-deprecated.svg similarity index 100% rename from man/figures/lifecycle-soft-deprecated.svg rename to _archive/man/figures/lifecycle-soft-deprecated.svg diff --git a/man/figures/lifecycle-stable.svg b/_archive/man/figures/lifecycle-stable.svg similarity index 100% rename from man/figures/lifecycle-stable.svg rename to _archive/man/figures/lifecycle-stable.svg diff --git a/man/figures/logo.png b/_archive/man/figures/logo.png similarity index 100% rename from man/figures/logo.png rename to _archive/man/figures/logo.png diff --git a/_archive/man/gtsummary-package.Rd b/_archive/man/gtsummary-package.Rd new file mode 100644 index 0000000000..c4d8eeb1e0 --- /dev/null +++ b/_archive/man/gtsummary-package.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gtsummary-package.R +\docType{package} +\name{gtsummary-package} +\alias{gtsummary} +\alias{gtsummary-package} +\title{gtsummary: Presentation-Ready Data Summary and Analytic Result Tables} +\description{ +\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} + +Creates presentation-ready tables summarizing data sets, regression models, and more. The code to create the tables is concise and highly customizable. Data frames can be summarized with any function, e.g. mean(), median(), even user-written functions. Regression models are summarized and include the reference rows for categorical variables. Common regression models, such as logistic regression and Cox proportional hazards regression, are automatically identified and the tables are pre-filled with appropriate column headers. +} +\seealso{ +Useful links: +\itemize{ + \item \url{https://github.com/ddsjoberg/gtsummary} + \item \url{https://www.danieldsjoberg.com/gtsummary/} + \item Report bugs at \url{https://github.com/ddsjoberg/gtsummary/issues} +} + +} +\author{ +\strong{Maintainer}: Daniel D. Sjoberg \email{danield.sjoberg@gmail.com} (\href{https://orcid.org/0000-0003-0862-2018}{ORCID}) + +Authors: +\itemize{ + \item Joseph Larmarange (\href{https://orcid.org/0000-0001-7097-700X}{ORCID}) + \item Michael Curry (\href{https://orcid.org/0000-0002-0261-4044}{ORCID}) + \item Jessica Lavery (\href{https://orcid.org/0000-0002-2746-5647}{ORCID}) + \item Karissa Whiting (\href{https://orcid.org/0000-0002-4683-1868}{ORCID}) + \item Emily C. Zabor (\href{https://orcid.org/0000-0002-1402-4498}{ORCID}) +} + +Other contributors: +\itemize{ + \item Xing Bai [contributor] + \item Esther Drill (\href{https://orcid.org/0000-0002-3315-4538}{ORCID}) [contributor] + \item Jessica Flynn (\href{https://orcid.org/0000-0001-8310-6684}{ORCID}) [contributor] + \item Margie Hannum (\href{https://orcid.org/0000-0002-2953-0449}{ORCID}) [contributor] + \item Stephanie Lobaugh [contributor] + \item Shannon Pileggi (\href{https://orcid.org/0000-0002-7732-4164}{ORCID}) [contributor] + \item Amy Tin (\href{https://orcid.org/0000-0002-8005-0694}{ORCID}) [contributor] + \item Gustavo Zapata Wainberg (\href{https://orcid.org/0000-0002-2524-3637}{ORCID}) [contributor] +} + +} +\keyword{internal} diff --git a/man/inline_text.Rd b/_archive/man/inline_text.Rd similarity index 100% rename from man/inline_text.Rd rename to _archive/man/inline_text.Rd diff --git a/man/inline_text.gtsummary.Rd b/_archive/man/inline_text.gtsummary.Rd similarity index 100% rename from man/inline_text.gtsummary.Rd rename to _archive/man/inline_text.gtsummary.Rd diff --git a/man/inline_text.tbl_cross.Rd b/_archive/man/inline_text.tbl_cross.Rd similarity index 100% rename from man/inline_text.tbl_cross.Rd rename to _archive/man/inline_text.tbl_cross.Rd diff --git a/man/inline_text.tbl_regression.Rd b/_archive/man/inline_text.tbl_regression.Rd similarity index 100% rename from man/inline_text.tbl_regression.Rd rename to _archive/man/inline_text.tbl_regression.Rd diff --git a/man/inline_text.tbl_summary.Rd b/_archive/man/inline_text.tbl_summary.Rd similarity index 100% rename from man/inline_text.tbl_summary.Rd rename to _archive/man/inline_text.tbl_summary.Rd diff --git a/man/inline_text.tbl_survfit.Rd b/_archive/man/inline_text.tbl_survfit.Rd similarity index 100% rename from man/inline_text.tbl_survfit.Rd rename to _archive/man/inline_text.tbl_survfit.Rd diff --git a/man/inline_text.tbl_survival.Rd b/_archive/man/inline_text.tbl_survival.Rd similarity index 100% rename from man/inline_text.tbl_survival.Rd rename to _archive/man/inline_text.tbl_survival.Rd diff --git a/man/inline_text.tbl_uvregression.Rd b/_archive/man/inline_text.tbl_uvregression.Rd similarity index 100% rename from man/inline_text.tbl_uvregression.Rd rename to _archive/man/inline_text.tbl_uvregression.Rd diff --git a/man/kableExtra_utils.Rd b/_archive/man/kableExtra_utils.Rd similarity index 100% rename from man/kableExtra_utils.Rd rename to _archive/man/kableExtra_utils.Rd diff --git a/man/modify.Rd b/_archive/man/modify.Rd similarity index 100% rename from man/modify.Rd rename to _archive/man/modify.Rd diff --git a/man/modify_column_alignment.Rd b/_archive/man/modify_column_alignment.Rd similarity index 100% rename from man/modify_column_alignment.Rd rename to _archive/man/modify_column_alignment.Rd diff --git a/_archive/man/modify_column_hide.Rd b/_archive/man/modify_column_hide.Rd new file mode 100644 index 0000000000..f6c6ba067f --- /dev/null +++ b/_archive/man/modify_column_hide.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_column_hide.R +\name{modify_column_hide} +\alias{modify_column_hide} +\alias{modify_column_unhide} +\title{Modify Hidden Columns} +\usage{ +modify_column_hide(x, columns) + +modify_column_unhide(x, columns) +} +\arguments{ +\item{x}{gtsummary object} + +\item{columns}{vector or selector of columns in \code{x$table_body}} +} +\description{ +\lifecycle{maturing} +Use these functions to hide or unhide columns in a gtsummary table. +} +\section{Example Output}{ + +\if{html}{Example 1} + +\if{html}{\out{ +image of rendered example table +}} +} + +\examples{ +\donttest{ +# Example 1 ---------------------------------- +# hide 95\% CI, and replace with standard error +modify_column_hide_ex1 <- + lm(age ~ marker + grade, trial) \%>\% + tbl_regression() \%>\% + modify_column_hide(columns = ci) \%>\% + modify_column_unhide(columns = std.error) +} +} +\seealso{ +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary + +Other Advanced modifiers: +\code{\link{modify_column_alignment}()}, +\code{\link{modify_column_indent}()}, +\code{\link{modify_column_merge}()}, +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_body}()}, +\code{\link{modify_table_styling}()} +} +\concept{Advanced modifiers} diff --git a/man/modify_column_indent.Rd b/_archive/man/modify_column_indent.Rd similarity index 100% rename from man/modify_column_indent.Rd rename to _archive/man/modify_column_indent.Rd diff --git a/man/modify_column_merge.Rd b/_archive/man/modify_column_merge.Rd similarity index 100% rename from man/modify_column_merge.Rd rename to _archive/man/modify_column_merge.Rd diff --git a/man/modify_fmt_fun.Rd b/_archive/man/modify_fmt_fun.Rd similarity index 100% rename from man/modify_fmt_fun.Rd rename to _archive/man/modify_fmt_fun.Rd diff --git a/man/modify_table_body.Rd b/_archive/man/modify_table_body.Rd similarity index 100% rename from man/modify_table_body.Rd rename to _archive/man/modify_table_body.Rd diff --git a/man/modify_table_header.Rd b/_archive/man/modify_table_header.Rd similarity index 100% rename from man/modify_table_header.Rd rename to _archive/man/modify_table_header.Rd diff --git a/_archive/man/modify_table_styling.Rd b/_archive/man/modify_table_styling.Rd new file mode 100644 index 0000000000..b3f675c2d7 --- /dev/null +++ b/_archive/man/modify_table_styling.Rd @@ -0,0 +1,133 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_table_styling.R +\name{modify_table_styling} +\alias{modify_table_styling} +\title{Modify Table Styling} +\usage{ +modify_table_styling( + x, + columns, + rows = NULL, + label = NULL, + spanning_header = NULL, + hide = NULL, + footnote = NULL, + footnote_abbrev = NULL, + align = NULL, + missing_symbol = NULL, + fmt_fun = NULL, + text_format = NULL, + undo_text_format = FALSE, + text_interpret = c("md", "html"), + cols_merge_pattern = NULL +) +} +\arguments{ +\item{x}{gtsummary object} + +\item{columns}{vector or selector of columns in \code{x$table_body}} + +\item{rows}{predicate expression to select rows in \code{x$table_body}. +Can be used to style footnote, formatting functions, missing symbols, +and text formatting. Default is \code{NULL}. See details below.} + +\item{label}{string of column label(s)} + +\item{spanning_header}{string with text for spanning header} + +\item{hide}{logical indicating whether to hide column from output} + +\item{footnote}{string with text for footnote} + +\item{footnote_abbrev}{string with abbreviation definition, e.g. +\code{"CI = Confidence Interval"}} + +\item{align}{string indicating alignment of column, must be one of +\code{c("left", "right", "center")}} + +\item{missing_symbol}{string indicating how missing values are formatted.} + +\item{fmt_fun}{function that formats the statistics in the +columns/rows in \verb{columns=} and \verb{rows=}} + +\item{text_format}{string indicated which type of text formatting to apply to the rows and columns. +Must be one of \code{c("bold", "italic", "indent", "indent2")}. Do not assign +both \code{"indent"} and \code{"indent2"} to the same cell.} + +\item{undo_text_format}{rarely used. Logical that undoes the indent, bold, +and italic styling when \code{TRUE}} + +\item{text_interpret}{string, must be one of \code{"md"} or \code{"html"}} + +\item{cols_merge_pattern}{\lifecycle{experimental} glue-syntax string +indicating how to merge +columns in \code{x$table_body}. For example, to construct a confidence interval +use \code{"{conf.low}, {conf.high}"}. The first column listed in the pattern +string must match the single column name passed in \verb{columns=}.} +} +\description{ +This is a function meant for advanced users to gain +more control over the characteristics of the resulting +gtsummary table by directly modifying \code{.$table_styling} +} +\details{ +Review the +\href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition} +vignette for information on \code{.$table_styling} objects. +} +\section{rows argument}{ + +The rows argument accepts a predicate expression that is used to specify +rows to apply formatting. The expression must evaluate to a logical when +evaluated in \code{x$table_body}. For example, to apply formatting to the age rows +pass \code{rows = variable == "age"}. A vector of row numbers is NOT acceptable. + +A couple of things to note when using the \verb{rows=} argument. +\enumerate{ +\item You can use saved objects to create the predicate argument, e.g. +\code{rows = variable == letters[1]}. +\item The saved object cannot share a name with a column in \code{x$table_body}. +The reason for this is that in \code{tbl_merge()} the columns are renamed, +and the renaming process cannot disambiguate the \code{variable} column from +an external object named \code{variable} in the following expression +\code{rows = .data$variable = .env$variable}. +} +} + +\section{cols_merge_pattern argument}{ + + +There are planned updates to the implementation of column merging. +Currently, this function replaces the numeric column with a +formatted character column following \verb{cols_merge_pattern=}. +Once \code{gt::cols_merge()} gains the \verb{rows=} argument the +implementation will be updated to use it, which will keep +numeric columns numeric. For the \emph{vast majority} of users, +\emph{the planned change will be go unnoticed}. + +If this functionality is used in conjunction with \code{tbl_stack()} (which +includes \code{tbl_uvregression()}), there is potential issue with printing. +When columns are stack AND when the column-merging is +defined with a quosure, you may run into issues due to the loss of the +environment when 2 or more quosures are combined. If the expression +version of the quosure is the same as the quosure (i.e. no evaluated +objects), there should be no issues. Regardless, this argument is used +internally with care, and it is \emph{not} recommended for users. +} + +\seealso{ +\code{modify_table_body()} + +See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} + +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary + +Other Advanced modifiers: +\code{\link{modify_column_alignment}()}, +\code{\link{modify_column_hide}()}, +\code{\link{modify_column_indent}()}, +\code{\link{modify_column_merge}()}, +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_body}()} +} +\concept{Advanced modifiers} diff --git a/man/plot.Rd b/_archive/man/plot.Rd similarity index 100% rename from man/plot.Rd rename to _archive/man/plot.Rd diff --git a/_archive/man/print_gtsummary.Rd b/_archive/man/print_gtsummary.Rd new file mode 100644 index 0000000000..688d0217e6 --- /dev/null +++ b/_archive/man/print_gtsummary.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.R +\name{print_gtsummary} +\alias{print_gtsummary} +\alias{print.gtsummary} +\alias{knit_print.gtsummary} +\title{print and knit_print methods for gtsummary objects} +\usage{ +\method{print}{gtsummary}(x, print_engine = NULL, ...) + +\method{knit_print}{gtsummary}(x, ...) +} +\arguments{ +\item{x}{An object created using gtsummary functions} + +\item{print_engine}{String indicating the print method. Must be one of +\code{"gt"}, \code{"kable"}, \code{"kable_extra"}, \code{"flextable"}, \code{"tibble"}} + +\item{...}{Not used} +} +\description{ +print and knit_print methods for gtsummary objects +} +\seealso{ +\link{tbl_summary} \link{tbl_regression} \link{tbl_uvregression} \link{tbl_merge} \link{tbl_stack} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/proportion_summary.Rd b/_archive/man/proportion_summary.Rd similarity index 100% rename from man/proportion_summary.Rd rename to _archive/man/proportion_summary.Rd diff --git a/man/ratio_summary.Rd b/_archive/man/ratio_summary.Rd similarity index 100% rename from man/ratio_summary.Rd rename to _archive/man/ratio_summary.Rd diff --git a/_archive/man/reexports.Rd b/_archive/man/reexports.Rd new file mode 100644 index 0000000000..4f6c512bd3 --- /dev/null +++ b/_archive/man/reexports.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/reexport.R +\docType{import} +\name{reexports} +\alias{reexports} +\alias{as_tibble} +\alias{knit_print} +\alias{\%>\%} +\alias{vars} +\alias{select} +\alias{mutate} +\alias{starts_with} +\alias{ends_with} +\alias{contains} +\alias{matches} +\alias{num_range} +\alias{all_of} +\alias{any_of} +\alias{everything} +\alias{last_col} +\alias{one_of} +\title{Objects exported from other packages} +\keyword{internal} +\description{ +These objects are imported from other packages. Follow the links +below to see their documentation. + +\describe{ + \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]{mutate}}, \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}}} + + \item{tibble}{\code{\link[tibble]{as_tibble}}} +}} + diff --git a/man/remove_row_type.Rd b/_archive/man/remove_row_type.Rd similarity index 100% rename from man/remove_row_type.Rd rename to _archive/man/remove_row_type.Rd diff --git a/_archive/man/select_helpers.Rd b/_archive/man/select_helpers.Rd new file mode 100644 index 0000000000..61c1468d65 --- /dev/null +++ b/_archive/man/select_helpers.Rd @@ -0,0 +1,87 @@ +% Generated by roxygen2: do not edit by hand +% 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_tests} +\alias{all_stat_cols} +\alias{all_interaction} +\alias{all_intercepts} +\alias{all_contrasts} +\title{Select helper functions} +\usage{ +all_continuous(continuous2 = TRUE) + +all_continuous2() + +all_categorical(dichotomous = TRUE) + +all_dichotomous() + +all_tests(tests = NULL) + +all_stat_cols(stat_0 = TRUE) + +all_interaction() + +all_intercepts() + +all_contrasts(contrasts_type = NULL) +} +\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}} + +\item{tests}{string indicating the test type of the variables to select, e.g. +select all variables being compared with \code{"t.test"}} + +\item{stat_0}{When \code{FALSE}, will not select the \code{"stat_0"} column. Default is \code{TRUE}} + +\item{contrasts_type}{type of contrast to select. When \code{NULL}, all variables with a +contrast will be selected. Default is \code{NULL}. Select among contrast types +\code{c("treatment", "sum", "poly", "helmert", "other")}} +} +\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 (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_tests()} selects variables by the name of the test performed +\item \code{all_stat_cols()} selects columns from \code{tbl_summary}/\code{tbl_svysummary} object with summary statistics (i.e. \code{"stat_0"}, \code{"stat_1"}, \code{"stat_2"}, etc.) +\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}{\out{ +image of rendered example table +}} +} + +\examples{ +select_ex1 <- + trial \%>\% + select(age, response, grade) \%>\% + tbl_summary( + statistic = all_continuous() ~ "{mean} ({sd})", + type = all_dichotomous() ~ "categorical" + ) +} +\seealso{ +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary +} diff --git a/man/separate_p_footnotes.Rd b/_archive/man/separate_p_footnotes.Rd similarity index 100% rename from man/separate_p_footnotes.Rd rename to _archive/man/separate_p_footnotes.Rd diff --git a/man/set_gtsummary_theme.Rd b/_archive/man/set_gtsummary_theme.Rd similarity index 100% rename from man/set_gtsummary_theme.Rd rename to _archive/man/set_gtsummary_theme.Rd diff --git a/man/sort_filter_p.Rd b/_archive/man/sort_filter_p.Rd similarity index 100% rename from man/sort_filter_p.Rd rename to _archive/man/sort_filter_p.Rd diff --git a/man/style_number.Rd b/_archive/man/style_number.Rd similarity index 100% rename from man/style_number.Rd rename to _archive/man/style_number.Rd diff --git a/man/style_percent.Rd b/_archive/man/style_percent.Rd similarity index 100% rename from man/style_percent.Rd rename to _archive/man/style_percent.Rd diff --git a/man/style_pvalue.Rd b/_archive/man/style_pvalue.Rd similarity index 100% rename from man/style_pvalue.Rd rename to _archive/man/style_pvalue.Rd diff --git a/man/style_ratio.Rd b/_archive/man/style_ratio.Rd similarity index 100% rename from man/style_ratio.Rd rename to _archive/man/style_ratio.Rd diff --git a/man/style_sigfig.Rd b/_archive/man/style_sigfig.Rd similarity index 100% rename from man/style_sigfig.Rd rename to _archive/man/style_sigfig.Rd diff --git a/man/syntax.Rd b/_archive/man/syntax.Rd similarity index 100% rename from man/syntax.Rd rename to _archive/man/syntax.Rd diff --git a/man/tbl_butcher.Rd b/_archive/man/tbl_butcher.Rd similarity index 100% rename from man/tbl_butcher.Rd rename to _archive/man/tbl_butcher.Rd diff --git a/man/tbl_continuous.Rd b/_archive/man/tbl_continuous.Rd similarity index 100% rename from man/tbl_continuous.Rd rename to _archive/man/tbl_continuous.Rd diff --git a/man/tbl_cross.Rd b/_archive/man/tbl_cross.Rd similarity index 100% rename from man/tbl_cross.Rd rename to _archive/man/tbl_cross.Rd diff --git a/man/tbl_custom_summary.Rd b/_archive/man/tbl_custom_summary.Rd similarity index 100% rename from man/tbl_custom_summary.Rd rename to _archive/man/tbl_custom_summary.Rd diff --git a/man/tbl_merge.Rd b/_archive/man/tbl_merge.Rd similarity index 100% rename from man/tbl_merge.Rd rename to _archive/man/tbl_merge.Rd diff --git a/man/tbl_regression.Rd b/_archive/man/tbl_regression.Rd similarity index 100% rename from man/tbl_regression.Rd rename to _archive/man/tbl_regression.Rd diff --git a/man/tbl_regression_methods.Rd b/_archive/man/tbl_regression_methods.Rd similarity index 100% rename from man/tbl_regression_methods.Rd rename to _archive/man/tbl_regression_methods.Rd diff --git a/man/tbl_split.Rd b/_archive/man/tbl_split.Rd similarity index 100% rename from man/tbl_split.Rd rename to _archive/man/tbl_split.Rd diff --git a/man/tbl_stack.Rd b/_archive/man/tbl_stack.Rd similarity index 100% rename from man/tbl_stack.Rd rename to _archive/man/tbl_stack.Rd diff --git a/man/tbl_strata.Rd b/_archive/man/tbl_strata.Rd similarity index 100% rename from man/tbl_strata.Rd rename to _archive/man/tbl_strata.Rd diff --git a/_archive/man/tbl_summary.Rd b/_archive/man/tbl_summary.Rd new file mode 100644 index 0000000000..b59e5df7db --- /dev/null +++ b/_archive/man/tbl_summary.Rd @@ -0,0 +1,271 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tbl_summary.R +\name{tbl_summary} +\alias{tbl_summary} +\title{Create a table of summary statistics} +\usage{ +tbl_summary( + data, + by = NULL, + label = NULL, + statistic = NULL, + digits = NULL, + type = NULL, + value = NULL, + missing = NULL, + missing_text = NULL, + sort = NULL, + percent = NULL, + include = everything() +) +} +\arguments{ +\item{data}{A data frame} + +\item{by}{A column name (quoted or unquoted) in \code{data}. +Summary statistics will be calculated separately for each level of the \code{by} +variable (e.g. \code{by = trt}). If \code{NULL}, summary statistics +are calculated using all observations. To stratify a table by two or more +variables, use \code{tbl_strata()}} + +\item{label}{List of formulas specifying variables labels, +e.g. \code{list(age ~ "Age", stage ~ "Path T Stage")}. If a +variable's label is not specified here, the label attribute +(\code{attr(data$age, "label")}) is used. If +attribute label is \code{NULL}, the variable name will be used.} + +\item{statistic}{List of formulas specifying types of summary statistics to +display for each variable. The default is +\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. +See below for details.} + +\item{digits}{List of formulas specifying the number of decimal +places to round summary statistics. If not specified, +\code{tbl_summary} guesses an appropriate number of decimals to round statistics. +When multiple statistics are displayed for a single variable, supply a vector +rather than an integer. For example, if the +statistic being calculated is \code{"{mean} ({sd})"} and you want the mean rounded +to 1 decimal place, and the SD to 2 use \code{digits = list(age ~ c(1, 2))}. User +may also pass a styling function: \code{digits = age ~ style_sigfig}} + +\item{type}{List of formulas specifying variable types. Accepted values +are \code{c("continuous", "continuous2", "categorical", "dichotomous")}, +e.g. \code{type = list(age ~ "continuous", female ~ "dichotomous")}. +If type not specified for a variable, the function +will default to an appropriate summary type. See below for details.} + +\item{value}{List of formulas specifying the value to display for dichotomous +variables. gtsummary selectors, e.g. \code{all_dichotomous()}, cannot be used +with this argument. See below for details.} + +\item{missing}{Indicates whether to include counts of \code{NA} values in the table. +Allowed values are \code{"no"} (never display NA values), +\code{"ifany"} (only display if any NA values), and \code{"always"} +(includes NA count row for all variables). Default is \code{"ifany"}.} + +\item{missing_text}{String to display for count of missing observations. +Default is \code{"Unknown"}.} + +\item{sort}{List of formulas specifying the type of sorting to perform for +categorical data. Options are \code{frequency} where results are sorted in +descending order of frequency and \code{alphanumeric}, +e.g. \code{sort = list(everything() ~ "frequency")}} + +\item{percent}{Indicates the type of percentage to return. Must be one of +\code{"column"}, \code{"row"}, or \code{"cell"}. Default is \code{"column"}.} + +\item{include}{variables to include in the summary table. Default is \code{everything()}} +} +\value{ +A \code{tbl_summary} object +} +\description{ +The \code{tbl_summary} function calculates descriptive statistics for +continuous, categorical, and dichotomous variables. Review the +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} +for detailed examples. +} +\section{select helpers}{ + +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#select_helpers}{Select helpers} +from the \\{tidyselect\\} package and \\{gtsummary\\} package are available to +modify default behavior for groups of variables. +For example, by default continuous variables are reported with the median +and IQR. To change all continuous variables to mean and standard deviation use +\code{statistic = list(all_continuous() ~ "{mean} ({sd})")}. + +All columns with class logical are displayed as dichotomous variables showing +the proportion of events that are \code{TRUE} on a single row. To show both rows +(i.e. a row for \code{TRUE} and a row for \code{FALSE}) use +\code{type = list(where(is.logical) ~ "categorical")}. + +The select helpers are available for use in any argument that accepts a list +of formulas (e.g. \code{statistic}, \code{type}, \code{digits}, \code{value}, \code{sort}, etc.) + +Read more on the \link{syntax} used through the package. +} + +\section{type argument}{ + +The \code{tbl_summary()} function has four summary types: +\itemize{ +\item \code{"continuous"} summaries are shown on a \emph{single row}. Most numeric +variables default to summary type continuous. +\item \code{"continuous2"} summaries are shown on \emph{2 or more rows} +\item \code{"categorical"} \emph{multi-line} summaries of nominal data. Character variables, +factor variables, and numeric variables with fewer than 10 unique levels default to +type categorical. To change a numeric variable to continuous that +defaulted to categorical, use \code{type = list(varname ~ "continuous")} +\item \code{"dichotomous"} categorical variables that are displayed on a \emph{single row}, +rather than one row per level of the variable. +Variables coded as \code{TRUE}/\code{FALSE}, \code{0}/\code{1}, or \code{yes}/\code{no} are assumed to be dichotomous, +and the \code{TRUE}, \code{1}, and \code{yes} rows are displayed. +Otherwise, the value to display must be specified in the \code{value} +argument, e.g. \code{value = list(varname ~ "level to show")} +} +} + +\section{statistic argument}{ + +The statistic argument specifies the statistics presented in the table. The +input is a list of formulas that specify the statistics to report. For example, +\code{statistic = list(age ~ "{mean} ({sd})")} would report the mean and +standard deviation for age; \code{statistic = list(all_continuous() ~ "{mean} ({sd})")} +would report the mean and standard deviation for all continuous variables. +A statistic name that appears between curly brackets +will be replaced with the numeric statistic (see \link[glue:glue]{glue::glue}). + +For categorical variables the following statistics are available to display. +\itemize{ +\item \code{{n}} frequency +\item \code{{N}} denominator, or cohort size +\item \code{{p}} formatted percentage +} +For continuous variables the following statistics are available to display. +\itemize{ +\item \code{{median}} median +\item \code{{mean}} mean +\item \code{{sd}} standard deviation +\item \code{{var}} variance +\item \code{{min}} minimum +\item \code{{max}} maximum +\item \code{{sum}} sum +\item \verb{\{p##\}} any integer percentile, where \verb{##} is an integer from 0 to 100 +\item \code{{foo}} any function of the form \code{foo(x)} is accepted where \code{x} is a numeric vector +} +When the summary type is \code{"continuous2"}, pass a vector of statistics. Each element +of the vector will result in a separate row in the summary table. + +For both categorical and continuous variables, statistics on the number of +missing and non-missing observations and their proportions are available to +display. +\itemize{ +\item \code{{N_obs}} total number of observations +\item \code{{N_miss}} number of missing observations +\item \code{{N_nonmiss}} number of non-missing observations +\item \code{{p_miss}} percentage of observations missing +\item \code{{p_nonmiss}} percentage of observations not missing +} + +Note that for categorical variables, \code{{N_obs}}, \code{{N_miss}} and \code{{N_nonmiss}} refer +to the total number, number missing and number non missing observations +in the denominator, not at each level of the categorical variable. +} + +\section{Example Output}{ + +\if{html}{Example 1} + +\if{html}{\out{ +image of rendered example table +}} + +\if{html}{Example 2} + +\if{html}{\out{ +image of rendered example table +}} + +\if{html}{Example 3} + +\if{html}{\out{ +image of rendered example table +}} + +\if{html}{Example 4} + +\if{html}{\out{ +image of rendered example table +}} +} + +\examples{ +\donttest{ +# Example 1 ---------------------------------- +tbl_summary_ex1 <- + trial \%>\% + select(age, grade, response) \%>\% + tbl_summary() + +# Example 2 ---------------------------------- +tbl_summary_ex2 <- + trial \%>\% + select(age, grade, response, trt) \%>\% + tbl_summary( + by = trt, + label = list(age ~ "Patient Age"), + statistic = list(all_continuous() ~ "{mean} ({sd})"), + digits = list(age ~ c(0, 1)) + ) + +# Example 3 ---------------------------------- +# for convenience, you can also pass named lists to any arguments +# that accept formulas (e.g label, digits, etc.) +tbl_summary_ex3 <- + trial \%>\% + select(age, trt) \%>\% + tbl_summary( + by = trt, + label = list(age = "Patient Age") + ) + +# Example 4 ---------------------------------- +# multi-line summaries of continuous data with type 'continuous2' +tbl_summary_ex4 <- + trial \%>\% + select(age, marker) \%>\% + tbl_summary( + type = all_continuous() ~ "continuous2", + statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), + missing = "no" + ) +} +} +\seealso{ +See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial + +See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples + +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary + +Other tbl_summary tools: +\code{\link{add_n.tbl_summary}()}, +\code{\link{add_overall}()}, +\code{\link{add_p.tbl_summary}()}, +\code{\link{add_q}()}, +\code{\link{add_stat_label}()}, +\code{\link{bold_italicize_labels_levels}}, +\code{\link{inline_text.tbl_summary}()}, +\code{\link{inline_text.tbl_survfit}()}, +\code{\link{modify}}, +\code{\link{separate_p_footnotes}()}, +\code{\link{tbl_custom_summary}()}, +\code{\link{tbl_merge}()}, +\code{\link{tbl_split}()}, +\code{\link{tbl_stack}()}, +\code{\link{tbl_strata}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{tbl_summary tools} diff --git a/man/tbl_survfit.Rd b/_archive/man/tbl_survfit.Rd similarity index 100% rename from man/tbl_survfit.Rd rename to _archive/man/tbl_survfit.Rd diff --git a/man/tbl_survfit_errors.Rd b/_archive/man/tbl_survfit_errors.Rd similarity index 100% rename from man/tbl_survfit_errors.Rd rename to _archive/man/tbl_survfit_errors.Rd diff --git a/man/tbl_survival.Rd b/_archive/man/tbl_survival.Rd similarity index 100% rename from man/tbl_survival.Rd rename to _archive/man/tbl_survival.Rd diff --git a/man/tbl_svysummary.Rd b/_archive/man/tbl_svysummary.Rd similarity index 100% rename from man/tbl_svysummary.Rd rename to _archive/man/tbl_svysummary.Rd diff --git a/man/tbl_uvregression.Rd b/_archive/man/tbl_uvregression.Rd similarity index 100% rename from man/tbl_uvregression.Rd rename to _archive/man/tbl_uvregression.Rd diff --git a/man/tests.Rd b/_archive/man/tests.Rd similarity index 100% rename from man/tests.Rd rename to _archive/man/tests.Rd diff --git a/man/theme_gtsummary.Rd b/_archive/man/theme_gtsummary.Rd similarity index 100% rename from man/theme_gtsummary.Rd rename to _archive/man/theme_gtsummary.Rd diff --git a/man/tidy_plus_plus_dots.Rd b/_archive/man/tidy_plus_plus_dots.Rd similarity index 100% rename from man/tidy_plus_plus_dots.Rd rename to _archive/man/tidy_plus_plus_dots.Rd diff --git a/man/trial.Rd b/_archive/man/trial.Rd similarity index 100% rename from man/trial.Rd rename to _archive/man/trial.Rd diff --git a/pkgdown/_pkgdown.yml b/_archive/pkgdown/_pkgdown.yml similarity index 100% rename from pkgdown/_pkgdown.yml rename to _archive/pkgdown/_pkgdown.yml diff --git a/pkgdown/favicon/apple-touch-icon-120x120.png b/_archive/pkgdown/favicon/apple-touch-icon-120x120.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon-120x120.png rename to _archive/pkgdown/favicon/apple-touch-icon-120x120.png diff --git a/pkgdown/favicon/apple-touch-icon-152x152.png b/_archive/pkgdown/favicon/apple-touch-icon-152x152.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon-152x152.png rename to _archive/pkgdown/favicon/apple-touch-icon-152x152.png diff --git a/pkgdown/favicon/apple-touch-icon-180x180.png b/_archive/pkgdown/favicon/apple-touch-icon-180x180.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon-180x180.png rename to _archive/pkgdown/favicon/apple-touch-icon-180x180.png diff --git a/pkgdown/favicon/apple-touch-icon-60x60.png b/_archive/pkgdown/favicon/apple-touch-icon-60x60.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon-60x60.png rename to _archive/pkgdown/favicon/apple-touch-icon-60x60.png diff --git a/pkgdown/favicon/apple-touch-icon-76x76.png b/_archive/pkgdown/favicon/apple-touch-icon-76x76.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon-76x76.png rename to _archive/pkgdown/favicon/apple-touch-icon-76x76.png diff --git a/pkgdown/favicon/apple-touch-icon.png b/_archive/pkgdown/favicon/apple-touch-icon.png similarity index 100% rename from pkgdown/favicon/apple-touch-icon.png rename to _archive/pkgdown/favicon/apple-touch-icon.png diff --git a/pkgdown/favicon/favicon-16x16.png b/_archive/pkgdown/favicon/favicon-16x16.png similarity index 100% rename from pkgdown/favicon/favicon-16x16.png rename to _archive/pkgdown/favicon/favicon-16x16.png diff --git a/pkgdown/favicon/favicon-32x32.png b/_archive/pkgdown/favicon/favicon-32x32.png similarity index 100% rename from pkgdown/favicon/favicon-32x32.png rename to _archive/pkgdown/favicon/favicon-32x32.png diff --git a/pkgdown/favicon/favicon.ico b/_archive/pkgdown/favicon/favicon.ico similarity index 100% rename from pkgdown/favicon/favicon.ico rename to _archive/pkgdown/favicon/favicon.ico diff --git a/tests/spelling.R b/_archive/tests/spelling.R similarity index 100% rename from tests/spelling.R rename to _archive/tests/spelling.R diff --git a/_archive/tests/testthat.R b/_archive/tests/testthat.R new file mode 100644 index 0000000000..d362e38ec4 --- /dev/null +++ b/_archive/tests/testthat.R @@ -0,0 +1,5 @@ +library(testthat) +library(gtsummary) + +test_check("gtsummary") +options(usethis.quiet = TRUE) diff --git a/tests/testthat/_snaps/add_ci.md b/_archive/tests/testthat/_snaps/add_ci.md similarity index 100% rename from tests/testthat/_snaps/add_ci.md rename to _archive/tests/testthat/_snaps/add_ci.md diff --git a/tests/testthat/_snaps/add_difference.md b/_archive/tests/testthat/_snaps/add_difference.md similarity index 100% rename from tests/testthat/_snaps/add_difference.md rename to _archive/tests/testthat/_snaps/add_difference.md diff --git a/tests/testthat/_snaps/add_glance.md b/_archive/tests/testthat/_snaps/add_glance.md similarity index 100% rename from tests/testthat/_snaps/add_glance.md rename to _archive/tests/testthat/_snaps/add_glance.md diff --git a/tests/testthat/_snaps/add_global_p.md b/_archive/tests/testthat/_snaps/add_global_p.md similarity index 100% rename from tests/testthat/_snaps/add_global_p.md rename to _archive/tests/testthat/_snaps/add_global_p.md diff --git a/tests/testthat/_snaps/add_n.md b/_archive/tests/testthat/_snaps/add_n.md similarity index 100% rename from tests/testthat/_snaps/add_n.md rename to _archive/tests/testthat/_snaps/add_n.md diff --git a/tests/testthat/_snaps/add_nevent.md b/_archive/tests/testthat/_snaps/add_nevent.md similarity index 100% rename from tests/testthat/_snaps/add_nevent.md rename to _archive/tests/testthat/_snaps/add_nevent.md diff --git a/tests/testthat/_snaps/add_overall.md b/_archive/tests/testthat/_snaps/add_overall.md similarity index 100% rename from tests/testthat/_snaps/add_overall.md rename to _archive/tests/testthat/_snaps/add_overall.md diff --git a/tests/testthat/_snaps/add_p.tbl_continuous.md b/_archive/tests/testthat/_snaps/add_p.tbl_continuous.md similarity index 100% rename from tests/testthat/_snaps/add_p.tbl_continuous.md rename to _archive/tests/testthat/_snaps/add_p.tbl_continuous.md diff --git a/tests/testthat/_snaps/add_p.tbl_cross.md b/_archive/tests/testthat/_snaps/add_p.tbl_cross.md similarity index 100% rename from tests/testthat/_snaps/add_p.tbl_cross.md rename to _archive/tests/testthat/_snaps/add_p.tbl_cross.md diff --git a/tests/testthat/_snaps/add_p.tbl_summary.md b/_archive/tests/testthat/_snaps/add_p.tbl_summary.md similarity index 100% rename from tests/testthat/_snaps/add_p.tbl_summary.md rename to _archive/tests/testthat/_snaps/add_p.tbl_summary.md diff --git a/tests/testthat/_snaps/add_p.tbl_survfit.md b/_archive/tests/testthat/_snaps/add_p.tbl_survfit.md similarity index 100% rename from tests/testthat/_snaps/add_p.tbl_survfit.md rename to _archive/tests/testthat/_snaps/add_p.tbl_survfit.md diff --git a/tests/testthat/_snaps/add_p.tbl_svysummary.md b/_archive/tests/testthat/_snaps/add_p.tbl_svysummary.md similarity index 100% rename from tests/testthat/_snaps/add_p.tbl_svysummary.md rename to _archive/tests/testthat/_snaps/add_p.tbl_svysummary.md diff --git a/tests/testthat/_snaps/add_p_test_safe.md b/_archive/tests/testthat/_snaps/add_p_test_safe.md similarity index 100% rename from tests/testthat/_snaps/add_p_test_safe.md rename to _archive/tests/testthat/_snaps/add_p_test_safe.md diff --git a/tests/testthat/_snaps/add_q.md b/_archive/tests/testthat/_snaps/add_q.md similarity index 100% rename from tests/testthat/_snaps/add_q.md rename to _archive/tests/testthat/_snaps/add_q.md diff --git a/tests/testthat/_snaps/add_significance_stars.md b/_archive/tests/testthat/_snaps/add_significance_stars.md similarity index 100% rename from tests/testthat/_snaps/add_significance_stars.md rename to _archive/tests/testthat/_snaps/add_significance_stars.md diff --git a/tests/testthat/_snaps/add_stat_label.md b/_archive/tests/testthat/_snaps/add_stat_label.md similarity index 100% rename from tests/testthat/_snaps/add_stat_label.md rename to _archive/tests/testthat/_snaps/add_stat_label.md diff --git a/tests/testthat/_snaps/add_vif.md b/_archive/tests/testthat/_snaps/add_vif.md similarity index 100% rename from tests/testthat/_snaps/add_vif.md rename to _archive/tests/testthat/_snaps/add_vif.md diff --git a/tests/testthat/_snaps/as_flex_table.md b/_archive/tests/testthat/_snaps/as_flex_table.md similarity index 100% rename from tests/testthat/_snaps/as_flex_table.md rename to _archive/tests/testthat/_snaps/as_flex_table.md diff --git a/tests/testthat/_snaps/as_gt.md b/_archive/tests/testthat/_snaps/as_gt.md similarity index 100% rename from tests/testthat/_snaps/as_gt.md rename to _archive/tests/testthat/_snaps/as_gt.md diff --git a/tests/testthat/_snaps/as_hux_table.md b/_archive/tests/testthat/_snaps/as_hux_table.md similarity index 100% rename from tests/testthat/_snaps/as_hux_table.md rename to _archive/tests/testthat/_snaps/as_hux_table.md diff --git a/tests/testthat/_snaps/as_kable.md b/_archive/tests/testthat/_snaps/as_kable.md similarity index 100% rename from tests/testthat/_snaps/as_kable.md rename to _archive/tests/testthat/_snaps/as_kable.md diff --git a/tests/testthat/_snaps/as_kable_extra.md b/_archive/tests/testthat/_snaps/as_kable_extra.md similarity index 100% rename from tests/testthat/_snaps/as_kable_extra.md rename to _archive/tests/testthat/_snaps/as_kable_extra.md diff --git a/tests/testthat/_snaps/as_tibble.md b/_archive/tests/testthat/_snaps/as_tibble.md similarity index 100% rename from tests/testthat/_snaps/as_tibble.md rename to _archive/tests/testthat/_snaps/as_tibble.md diff --git a/tests/testthat/_snaps/bold_italicize_labels_levels.md b/_archive/tests/testthat/_snaps/bold_italicize_labels_levels.md similarity index 100% rename from tests/testthat/_snaps/bold_italicize_labels_levels.md rename to _archive/tests/testthat/_snaps/bold_italicize_labels_levels.md diff --git a/tests/testthat/_snaps/bold_p.md b/_archive/tests/testthat/_snaps/bold_p.md similarity index 100% rename from tests/testthat/_snaps/bold_p.md rename to _archive/tests/testthat/_snaps/bold_p.md diff --git a/tests/testthat/_snaps/combine_terms.md b/_archive/tests/testthat/_snaps/combine_terms.md similarity index 100% rename from tests/testthat/_snaps/combine_terms.md rename to _archive/tests/testthat/_snaps/combine_terms.md diff --git a/tests/testthat/_snaps/custom_tidiers.md b/_archive/tests/testthat/_snaps/custom_tidiers.md similarity index 100% rename from tests/testthat/_snaps/custom_tidiers.md rename to _archive/tests/testthat/_snaps/custom_tidiers.md diff --git a/tests/testthat/_snaps/filter_p.md b/_archive/tests/testthat/_snaps/filter_p.md similarity index 100% rename from tests/testthat/_snaps/filter_p.md rename to _archive/tests/testthat/_snaps/filter_p.md diff --git a/tests/testthat/_snaps/modify_caption.md b/_archive/tests/testthat/_snaps/modify_caption.md similarity index 100% rename from tests/testthat/_snaps/modify_caption.md rename to _archive/tests/testthat/_snaps/modify_caption.md diff --git a/tests/testthat/_snaps/modify_column_alignment.md b/_archive/tests/testthat/_snaps/modify_column_alignment.md similarity index 100% rename from tests/testthat/_snaps/modify_column_alignment.md rename to _archive/tests/testthat/_snaps/modify_column_alignment.md diff --git a/tests/testthat/_snaps/modify_column_hide.md b/_archive/tests/testthat/_snaps/modify_column_hide.md similarity index 100% rename from tests/testthat/_snaps/modify_column_hide.md rename to _archive/tests/testthat/_snaps/modify_column_hide.md diff --git a/tests/testthat/_snaps/modify_column_indent.md b/_archive/tests/testthat/_snaps/modify_column_indent.md similarity index 100% rename from tests/testthat/_snaps/modify_column_indent.md rename to _archive/tests/testthat/_snaps/modify_column_indent.md diff --git a/tests/testthat/_snaps/modify_column_merge.md b/_archive/tests/testthat/_snaps/modify_column_merge.md similarity index 100% rename from tests/testthat/_snaps/modify_column_merge.md rename to _archive/tests/testthat/_snaps/modify_column_merge.md diff --git a/tests/testthat/_snaps/modify_fmt_fun.md b/_archive/tests/testthat/_snaps/modify_fmt_fun.md similarity index 100% rename from tests/testthat/_snaps/modify_fmt_fun.md rename to _archive/tests/testthat/_snaps/modify_fmt_fun.md diff --git a/tests/testthat/_snaps/modify_footnote.md b/_archive/tests/testthat/_snaps/modify_footnote.md similarity index 100% rename from tests/testthat/_snaps/modify_footnote.md rename to _archive/tests/testthat/_snaps/modify_footnote.md diff --git a/tests/testthat/_snaps/modify_header.md b/_archive/tests/testthat/_snaps/modify_header.md similarity index 100% rename from tests/testthat/_snaps/modify_header.md rename to _archive/tests/testthat/_snaps/modify_header.md diff --git a/tests/testthat/_snaps/modify_spanning_header.md b/_archive/tests/testthat/_snaps/modify_spanning_header.md similarity index 100% rename from tests/testthat/_snaps/modify_spanning_header.md rename to _archive/tests/testthat/_snaps/modify_spanning_header.md diff --git a/tests/testthat/_snaps/modify_table_body.md b/_archive/tests/testthat/_snaps/modify_table_body.md similarity index 100% rename from tests/testthat/_snaps/modify_table_body.md rename to _archive/tests/testthat/_snaps/modify_table_body.md diff --git a/tests/testthat/_snaps/modify_table_styling.md b/_archive/tests/testthat/_snaps/modify_table_styling.md similarity index 100% rename from tests/testthat/_snaps/modify_table_styling.md rename to _archive/tests/testthat/_snaps/modify_table_styling.md diff --git a/tests/testthat/_snaps/remove_row_type.md b/_archive/tests/testthat/_snaps/remove_row_type.md similarity index 100% rename from tests/testthat/_snaps/remove_row_type.md rename to _archive/tests/testthat/_snaps/remove_row_type.md diff --git a/tests/testthat/_snaps/select_helpers.md b/_archive/tests/testthat/_snaps/select_helpers.md similarity index 100% rename from tests/testthat/_snaps/select_helpers.md rename to _archive/tests/testthat/_snaps/select_helpers.md diff --git a/tests/testthat/_snaps/separate_p_footnotes.md b/_archive/tests/testthat/_snaps/separate_p_footnotes.md similarity index 100% rename from tests/testthat/_snaps/separate_p_footnotes.md rename to _archive/tests/testthat/_snaps/separate_p_footnotes.md diff --git a/tests/testthat/_snaps/set_gtsummary_theme.md b/_archive/tests/testthat/_snaps/set_gtsummary_theme.md similarity index 100% rename from tests/testthat/_snaps/set_gtsummary_theme.md rename to _archive/tests/testthat/_snaps/set_gtsummary_theme.md diff --git a/tests/testthat/_snaps/sort_p.md b/_archive/tests/testthat/_snaps/sort_p.md similarity index 100% rename from tests/testthat/_snaps/sort_p.md rename to _archive/tests/testthat/_snaps/sort_p.md diff --git a/tests/testthat/_snaps/tbl_butcher.md b/_archive/tests/testthat/_snaps/tbl_butcher.md similarity index 100% rename from tests/testthat/_snaps/tbl_butcher.md rename to _archive/tests/testthat/_snaps/tbl_butcher.md diff --git a/tests/testthat/_snaps/tbl_continuous.md b/_archive/tests/testthat/_snaps/tbl_continuous.md similarity index 100% rename from tests/testthat/_snaps/tbl_continuous.md rename to _archive/tests/testthat/_snaps/tbl_continuous.md diff --git a/tests/testthat/_snaps/tbl_cross.md b/_archive/tests/testthat/_snaps/tbl_cross.md similarity index 100% rename from tests/testthat/_snaps/tbl_cross.md rename to _archive/tests/testthat/_snaps/tbl_cross.md diff --git a/tests/testthat/_snaps/tbl_custom_summary.md b/_archive/tests/testthat/_snaps/tbl_custom_summary.md similarity index 100% rename from tests/testthat/_snaps/tbl_custom_summary.md rename to _archive/tests/testthat/_snaps/tbl_custom_summary.md diff --git a/tests/testthat/_snaps/tbl_merge.md b/_archive/tests/testthat/_snaps/tbl_merge.md similarity index 100% rename from tests/testthat/_snaps/tbl_merge.md rename to _archive/tests/testthat/_snaps/tbl_merge.md diff --git a/tests/testthat/_snaps/tbl_regression.md b/_archive/tests/testthat/_snaps/tbl_regression.md similarity index 100% rename from tests/testthat/_snaps/tbl_regression.md rename to _archive/tests/testthat/_snaps/tbl_regression.md diff --git a/tests/testthat/_snaps/tbl_split.md b/_archive/tests/testthat/_snaps/tbl_split.md similarity index 100% rename from tests/testthat/_snaps/tbl_split.md rename to _archive/tests/testthat/_snaps/tbl_split.md diff --git a/tests/testthat/_snaps/tbl_stack.md b/_archive/tests/testthat/_snaps/tbl_stack.md similarity index 100% rename from tests/testthat/_snaps/tbl_stack.md rename to _archive/tests/testthat/_snaps/tbl_stack.md diff --git a/tests/testthat/_snaps/tbl_strata.md b/_archive/tests/testthat/_snaps/tbl_strata.md similarity index 100% rename from tests/testthat/_snaps/tbl_strata.md rename to _archive/tests/testthat/_snaps/tbl_strata.md diff --git a/tests/testthat/_snaps/tbl_summary.md b/_archive/tests/testthat/_snaps/tbl_summary.md similarity index 100% rename from tests/testthat/_snaps/tbl_summary.md rename to _archive/tests/testthat/_snaps/tbl_summary.md diff --git a/tests/testthat/_snaps/tbl_survfit.md b/_archive/tests/testthat/_snaps/tbl_survfit.md similarity index 100% rename from tests/testthat/_snaps/tbl_survfit.md rename to _archive/tests/testthat/_snaps/tbl_survfit.md diff --git a/tests/testthat/_snaps/tbl_svysummary.md b/_archive/tests/testthat/_snaps/tbl_svysummary.md similarity index 100% rename from tests/testthat/_snaps/tbl_svysummary.md rename to _archive/tests/testthat/_snaps/tbl_svysummary.md diff --git a/tests/testthat/_snaps/tbl_uvregression.md b/_archive/tests/testthat/_snaps/tbl_uvregression.md similarity index 100% rename from tests/testthat/_snaps/tbl_uvregression.md rename to _archive/tests/testthat/_snaps/tbl_uvregression.md diff --git a/tests/testthat/helper-dplyr_storms.R b/_archive/tests/testthat/helper-dplyr_storms.R similarity index 100% rename from tests/testthat/helper-dplyr_storms.R rename to _archive/tests/testthat/helper-dplyr_storms.R diff --git a/tests/testthat/helper-render_as_html.R b/_archive/tests/testthat/helper-render_as_html.R similarity index 100% rename from tests/testthat/helper-render_as_html.R rename to _archive/tests/testthat/helper-render_as_html.R diff --git a/tests/testthat/helper-vetted_models.R b/_archive/tests/testthat/helper-vetted_models.R similarity index 100% rename from tests/testthat/helper-vetted_models.R rename to _archive/tests/testthat/helper-vetted_models.R diff --git a/tests/testthat/test-add_ci.R b/_archive/tests/testthat/test-add_ci.R similarity index 100% rename from tests/testthat/test-add_ci.R rename to _archive/tests/testthat/test-add_ci.R diff --git a/tests/testthat/test-add_difference.R b/_archive/tests/testthat/test-add_difference.R similarity index 100% rename from tests/testthat/test-add_difference.R rename to _archive/tests/testthat/test-add_difference.R diff --git a/tests/testthat/test-add_glance.R b/_archive/tests/testthat/test-add_glance.R similarity index 100% rename from tests/testthat/test-add_glance.R rename to _archive/tests/testthat/test-add_glance.R diff --git a/tests/testthat/test-add_global_p.R b/_archive/tests/testthat/test-add_global_p.R similarity index 100% rename from tests/testthat/test-add_global_p.R rename to _archive/tests/testthat/test-add_global_p.R diff --git a/tests/testthat/test-add_n.R b/_archive/tests/testthat/test-add_n.R similarity index 100% rename from tests/testthat/test-add_n.R rename to _archive/tests/testthat/test-add_n.R diff --git a/tests/testthat/test-add_nevent.R b/_archive/tests/testthat/test-add_nevent.R similarity index 100% rename from tests/testthat/test-add_nevent.R rename to _archive/tests/testthat/test-add_nevent.R diff --git a/tests/testthat/test-add_overall.R b/_archive/tests/testthat/test-add_overall.R similarity index 100% rename from tests/testthat/test-add_overall.R rename to _archive/tests/testthat/test-add_overall.R diff --git a/tests/testthat/test-add_p.tbl_continuous.R b/_archive/tests/testthat/test-add_p.tbl_continuous.R similarity index 100% rename from tests/testthat/test-add_p.tbl_continuous.R rename to _archive/tests/testthat/test-add_p.tbl_continuous.R diff --git a/tests/testthat/test-add_p.tbl_cross.R b/_archive/tests/testthat/test-add_p.tbl_cross.R similarity index 100% rename from tests/testthat/test-add_p.tbl_cross.R rename to _archive/tests/testthat/test-add_p.tbl_cross.R diff --git a/tests/testthat/test-add_p.tbl_summary.R b/_archive/tests/testthat/test-add_p.tbl_summary.R similarity index 100% rename from tests/testthat/test-add_p.tbl_summary.R rename to _archive/tests/testthat/test-add_p.tbl_summary.R diff --git a/tests/testthat/test-add_p.tbl_survfit.R b/_archive/tests/testthat/test-add_p.tbl_survfit.R similarity index 100% rename from tests/testthat/test-add_p.tbl_survfit.R rename to _archive/tests/testthat/test-add_p.tbl_survfit.R diff --git a/tests/testthat/test-add_p.tbl_svysummary.R b/_archive/tests/testthat/test-add_p.tbl_svysummary.R similarity index 100% rename from tests/testthat/test-add_p.tbl_svysummary.R rename to _archive/tests/testthat/test-add_p.tbl_svysummary.R diff --git a/tests/testthat/test-add_p_test_safe.R b/_archive/tests/testthat/test-add_p_test_safe.R similarity index 100% rename from tests/testthat/test-add_p_test_safe.R rename to _archive/tests/testthat/test-add_p_test_safe.R diff --git a/tests/testthat/test-add_q.R b/_archive/tests/testthat/test-add_q.R similarity index 100% rename from tests/testthat/test-add_q.R rename to _archive/tests/testthat/test-add_q.R diff --git a/tests/testthat/test-add_significance_stars.R b/_archive/tests/testthat/test-add_significance_stars.R similarity index 100% rename from tests/testthat/test-add_significance_stars.R rename to _archive/tests/testthat/test-add_significance_stars.R diff --git a/tests/testthat/test-add_stat.R b/_archive/tests/testthat/test-add_stat.R similarity index 100% rename from tests/testthat/test-add_stat.R rename to _archive/tests/testthat/test-add_stat.R diff --git a/tests/testthat/test-add_stat_label.R b/_archive/tests/testthat/test-add_stat_label.R similarity index 100% rename from tests/testthat/test-add_stat_label.R rename to _archive/tests/testthat/test-add_stat_label.R diff --git a/tests/testthat/test-add_vif.R b/_archive/tests/testthat/test-add_vif.R similarity index 100% rename from tests/testthat/test-add_vif.R rename to _archive/tests/testthat/test-add_vif.R diff --git a/tests/testthat/test-as_flex_table.R b/_archive/tests/testthat/test-as_flex_table.R similarity index 100% rename from tests/testthat/test-as_flex_table.R rename to _archive/tests/testthat/test-as_flex_table.R diff --git a/tests/testthat/test-as_gt.R b/_archive/tests/testthat/test-as_gt.R similarity index 100% rename from tests/testthat/test-as_gt.R rename to _archive/tests/testthat/test-as_gt.R diff --git a/tests/testthat/test-as_hux_table.R b/_archive/tests/testthat/test-as_hux_table.R similarity index 100% rename from tests/testthat/test-as_hux_table.R rename to _archive/tests/testthat/test-as_hux_table.R diff --git a/tests/testthat/test-as_hux_xlsx.R b/_archive/tests/testthat/test-as_hux_xlsx.R similarity index 100% rename from tests/testthat/test-as_hux_xlsx.R rename to _archive/tests/testthat/test-as_hux_xlsx.R diff --git a/tests/testthat/test-as_kable.R b/_archive/tests/testthat/test-as_kable.R similarity index 100% rename from tests/testthat/test-as_kable.R rename to _archive/tests/testthat/test-as_kable.R diff --git a/tests/testthat/test-as_kable_extra.R b/_archive/tests/testthat/test-as_kable_extra.R similarity index 100% rename from tests/testthat/test-as_kable_extra.R rename to _archive/tests/testthat/test-as_kable_extra.R diff --git a/tests/testthat/test-as_tibble.R b/_archive/tests/testthat/test-as_tibble.R similarity index 100% rename from tests/testthat/test-as_tibble.R rename to _archive/tests/testthat/test-as_tibble.R diff --git a/tests/testthat/test-assign_dichotomous_value.R b/_archive/tests/testthat/test-assign_dichotomous_value.R similarity index 100% rename from tests/testthat/test-assign_dichotomous_value.R rename to _archive/tests/testthat/test-assign_dichotomous_value.R diff --git a/tests/testthat/test-assign_summary_type.R b/_archive/tests/testthat/test-assign_summary_type.R similarity index 100% rename from tests/testthat/test-assign_summary_type.R rename to _archive/tests/testthat/test-assign_summary_type.R diff --git a/tests/testthat/test-bold_italicize_labels_levels.R b/_archive/tests/testthat/test-bold_italicize_labels_levels.R similarity index 100% rename from tests/testthat/test-bold_italicize_labels_levels.R rename to _archive/tests/testthat/test-bold_italicize_labels_levels.R diff --git a/tests/testthat/test-bold_p.R b/_archive/tests/testthat/test-bold_p.R similarity index 100% rename from tests/testthat/test-bold_p.R rename to _archive/tests/testthat/test-bold_p.R diff --git a/tests/testthat/test-combine_terms.R b/_archive/tests/testthat/test-combine_terms.R similarity index 100% rename from tests/testthat/test-combine_terms.R rename to _archive/tests/testthat/test-combine_terms.R diff --git a/tests/testthat/test-continuous_digits_guess.R b/_archive/tests/testthat/test-continuous_digits_guess.R similarity index 100% rename from tests/testthat/test-continuous_digits_guess.R rename to _archive/tests/testthat/test-continuous_digits_guess.R diff --git a/tests/testthat/test-custom_tidiers.R b/_archive/tests/testthat/test-custom_tidiers.R similarity index 100% rename from tests/testthat/test-custom_tidiers.R rename to _archive/tests/testthat/test-custom_tidiers.R diff --git a/tests/testthat/test-filter_p.R b/_archive/tests/testthat/test-filter_p.R similarity index 100% rename from tests/testthat/test-filter_p.R rename to _archive/tests/testthat/test-filter_p.R diff --git a/tests/testthat/test-inline_text.R b/_archive/tests/testthat/test-inline_text.R similarity index 100% rename from tests/testthat/test-inline_text.R rename to _archive/tests/testthat/test-inline_text.R diff --git a/tests/testthat/test-modify_caption.R b/_archive/tests/testthat/test-modify_caption.R similarity index 100% rename from tests/testthat/test-modify_caption.R rename to _archive/tests/testthat/test-modify_caption.R diff --git a/tests/testthat/test-modify_column_alignment.R b/_archive/tests/testthat/test-modify_column_alignment.R similarity index 100% rename from tests/testthat/test-modify_column_alignment.R rename to _archive/tests/testthat/test-modify_column_alignment.R diff --git a/tests/testthat/test-modify_column_hide.R b/_archive/tests/testthat/test-modify_column_hide.R similarity index 100% rename from tests/testthat/test-modify_column_hide.R rename to _archive/tests/testthat/test-modify_column_hide.R diff --git a/tests/testthat/test-modify_column_indent.R b/_archive/tests/testthat/test-modify_column_indent.R similarity index 100% rename from tests/testthat/test-modify_column_indent.R rename to _archive/tests/testthat/test-modify_column_indent.R diff --git a/tests/testthat/test-modify_column_merge.R b/_archive/tests/testthat/test-modify_column_merge.R similarity index 100% rename from tests/testthat/test-modify_column_merge.R rename to _archive/tests/testthat/test-modify_column_merge.R diff --git a/tests/testthat/test-modify_fmt_fun.R b/_archive/tests/testthat/test-modify_fmt_fun.R similarity index 100% rename from tests/testthat/test-modify_fmt_fun.R rename to _archive/tests/testthat/test-modify_fmt_fun.R diff --git a/tests/testthat/test-modify_footnote.R b/_archive/tests/testthat/test-modify_footnote.R similarity index 100% rename from tests/testthat/test-modify_footnote.R rename to _archive/tests/testthat/test-modify_footnote.R diff --git a/tests/testthat/test-modify_header.R b/_archive/tests/testthat/test-modify_header.R similarity index 100% rename from tests/testthat/test-modify_header.R rename to _archive/tests/testthat/test-modify_header.R diff --git a/tests/testthat/test-modify_spanning_header.R b/_archive/tests/testthat/test-modify_spanning_header.R similarity index 100% rename from tests/testthat/test-modify_spanning_header.R rename to _archive/tests/testthat/test-modify_spanning_header.R diff --git a/tests/testthat/test-modify_table_body.R b/_archive/tests/testthat/test-modify_table_body.R similarity index 100% rename from tests/testthat/test-modify_table_body.R rename to _archive/tests/testthat/test-modify_table_body.R diff --git a/tests/testthat/test-modify_table_styling.R b/_archive/tests/testthat/test-modify_table_styling.R similarity index 100% rename from tests/testthat/test-modify_table_styling.R rename to _archive/tests/testthat/test-modify_table_styling.R diff --git a/tests/testthat/test-plot.R b/_archive/tests/testthat/test-plot.R similarity index 100% rename from tests/testthat/test-plot.R rename to _archive/tests/testthat/test-plot.R diff --git a/tests/testthat/test-remove_row_type.R b/_archive/tests/testthat/test-remove_row_type.R similarity index 100% rename from tests/testthat/test-remove_row_type.R rename to _archive/tests/testthat/test-remove_row_type.R diff --git a/tests/testthat/test-select_helpers.R b/_archive/tests/testthat/test-select_helpers.R similarity index 100% rename from tests/testthat/test-select_helpers.R rename to _archive/tests/testthat/test-select_helpers.R diff --git a/tests/testthat/test-separate_p_footnotes.R b/_archive/tests/testthat/test-separate_p_footnotes.R similarity index 100% rename from tests/testthat/test-separate_p_footnotes.R rename to _archive/tests/testthat/test-separate_p_footnotes.R diff --git a/tests/testthat/test-set_gtsummary_theme.R b/_archive/tests/testthat/test-set_gtsummary_theme.R similarity index 100% rename from tests/testthat/test-set_gtsummary_theme.R rename to _archive/tests/testthat/test-set_gtsummary_theme.R diff --git a/tests/testthat/test-show_header_names.R b/_archive/tests/testthat/test-show_header_names.R similarity index 100% rename from tests/testthat/test-show_header_names.R rename to _archive/tests/testthat/test-show_header_names.R diff --git a/tests/testthat/test-sort_p.R b/_archive/tests/testthat/test-sort_p.R similarity index 100% rename from tests/testthat/test-sort_p.R rename to _archive/tests/testthat/test-sort_p.R diff --git a/tests/testthat/test-style_number.R b/_archive/tests/testthat/test-style_number.R similarity index 100% rename from tests/testthat/test-style_number.R rename to _archive/tests/testthat/test-style_number.R diff --git a/tests/testthat/test-style_percent.R b/_archive/tests/testthat/test-style_percent.R similarity index 100% rename from tests/testthat/test-style_percent.R rename to _archive/tests/testthat/test-style_percent.R diff --git a/tests/testthat/test-style_pvalue.R b/_archive/tests/testthat/test-style_pvalue.R similarity index 100% rename from tests/testthat/test-style_pvalue.R rename to _archive/tests/testthat/test-style_pvalue.R diff --git a/tests/testthat/test-style_ratio.R b/_archive/tests/testthat/test-style_ratio.R similarity index 100% rename from tests/testthat/test-style_ratio.R rename to _archive/tests/testthat/test-style_ratio.R diff --git a/tests/testthat/test-style_sigfig.R b/_archive/tests/testthat/test-style_sigfig.R similarity index 100% rename from tests/testthat/test-style_sigfig.R rename to _archive/tests/testthat/test-style_sigfig.R diff --git a/tests/testthat/test-tbl_butcher.R b/_archive/tests/testthat/test-tbl_butcher.R similarity index 100% rename from tests/testthat/test-tbl_butcher.R rename to _archive/tests/testthat/test-tbl_butcher.R diff --git a/tests/testthat/test-tbl_continuous.R b/_archive/tests/testthat/test-tbl_continuous.R similarity index 100% rename from tests/testthat/test-tbl_continuous.R rename to _archive/tests/testthat/test-tbl_continuous.R diff --git a/tests/testthat/test-tbl_cross.R b/_archive/tests/testthat/test-tbl_cross.R similarity index 100% rename from tests/testthat/test-tbl_cross.R rename to _archive/tests/testthat/test-tbl_cross.R diff --git a/tests/testthat/test-tbl_custom_summary.R b/_archive/tests/testthat/test-tbl_custom_summary.R similarity index 100% rename from tests/testthat/test-tbl_custom_summary.R rename to _archive/tests/testthat/test-tbl_custom_summary.R diff --git a/tests/testthat/test-tbl_merge.R b/_archive/tests/testthat/test-tbl_merge.R similarity index 100% rename from tests/testthat/test-tbl_merge.R rename to _archive/tests/testthat/test-tbl_merge.R diff --git a/tests/testthat/test-tbl_regression.R b/_archive/tests/testthat/test-tbl_regression.R similarity index 100% rename from tests/testthat/test-tbl_regression.R rename to _archive/tests/testthat/test-tbl_regression.R diff --git a/tests/testthat/test-tbl_split.R b/_archive/tests/testthat/test-tbl_split.R similarity index 100% rename from tests/testthat/test-tbl_split.R rename to _archive/tests/testthat/test-tbl_split.R diff --git a/tests/testthat/test-tbl_stack.R b/_archive/tests/testthat/test-tbl_stack.R similarity index 100% rename from tests/testthat/test-tbl_stack.R rename to _archive/tests/testthat/test-tbl_stack.R diff --git a/tests/testthat/test-tbl_strata.R b/_archive/tests/testthat/test-tbl_strata.R similarity index 100% rename from tests/testthat/test-tbl_strata.R rename to _archive/tests/testthat/test-tbl_strata.R diff --git a/_archive/tests/testthat/test-tbl_summary.R b/_archive/tests/testthat/test-tbl_summary.R new file mode 100644 index 0000000000..1310653ead --- /dev/null +++ b/_archive/tests/testthat/test-tbl_summary.R @@ -0,0 +1,789 @@ +skip_on_cran() + +test_that("tbl_summary creates output without error/warning (no by var)", { + expect_error( + lst_tbl <- purrr::map(list(mtcars, iris), ~ tbl_summary(.x, sort = list(all_categorical() ~ "frequency"))), + NA + ) + expect_snapshot(purrr::map(lst_tbl, as.data.frame)) + expect_warning( + purrr::map(list(mtcars, iris), ~ tbl_summary(.x)), + NA + ) +}) + + +test_that("tbl_summary creates output without error/warning (with by var)", { + expect_snapshot( + tbl_summary(mtcars, by = am) %>% + as.data.frame() + ) + expect_warning( + tbl_summary(mtcars, by = am), + NA + ) +}) + +test_that("tbl_summary allows for named list input", { + expect_snapshot( + tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl")) %>% + as.data.frame() + ) + expect_warning( + tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl")), + NA + ) +}) + + +test_that("tbl_summary throws errors/messages with bad 'sort = ' specifications", { + expect_error( + tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))), + NULL + ) + expect_error( + tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")), + NULL + ) +}) + +test_that("tbl_summary value argument works properly", { + expect_snapshot( + tbl_summary(trial, value = "grade" ~ "III") %>% + as.data.frame() + ) +}) + +test_that("tbl_summary works in character inputs for `by=`", { + my_by_variable <- "trt" + + expect_snapshot( + tbl_summary(trial, by = all_of(my_by_variable)) %>% + as.data.frame() + ) + expect_snapshot( + tbl_summary(trial, by = "trt") %>% + as.data.frame() + ) + expect_snapshot( + purrr::map( + c("trt", "grade", "stage"), + ~ tbl_summary(trial, by = all_of(.x)) %>% as_tibble() + ) + ) +}) + + +test_that("tbl_summary returns errors with bad inputs", { + expect_error( + tbl_summary(tibble::tibble()), + NULL + ) + expect_error( + tbl_summary(tibble::tibble(t = integer())), + NULL + ) + expect_error( + tbl_summary(list(test = 5)), + NULL + ) + expect_error( + tbl_summary(trial, by = THIS_IS_NOT_A_VARIABLE), + NULL + ) + expect_message( + tbl_summary(trial, by = response), # should get message about missing data + NULL + ) + expect_error( + tbl_summary(trial, type = response), + NULL + ) + expect_error( + tbl_summary(trial, value = "0"), + NULL + ) + expect_error( + tbl_summary(trial, label = "Age"), + NULL + ) + expect_error( + tbl_summary(trial, statistic = "{mean}"), + NULL + ) + expect_error( + tbl_summary(trial, digits = 0), + NULL + ) + expect_error( + tbl_summary(trial, sort = list("grade" ~ "frequ55555ency")), + NULL + ) + expect_error( + tbl_summary(trial, by = c("trt", "grade")), + NULL + ) + + expect_error( + tbl_summary(trial, statistic = everything() ~ "{mean}"), + NULL + ) +}) + + +test_that("tbl_summary-testing tidyselect parsing", { + trial2 <- trial + trial2$`bad trt` <- trial2$trt + trial2$`bad grade` <- trial2$grade + + expect_error( + big_test <- + tbl_summary( + data = trial2, + by = `bad trt`, + type = vars(response, death) ~ "categorical", + statistic = list( + all_continuous() ~ "{min} {max}", + c("grade", "stage") ~ "{n}" + ), + label = list( + age ~ "Patient Age", vars(stage) ~ "Patient Stage", + vars(`bad grade`) ~ "Crazy Grade" + ), + digits = list(vars(age) ~ c(2, 3), marker ~ c(2, 3)), + value = list(`bad grade` = "III", "stage" = "T1"), + missing = "no" + ), + NA + ) + expect_snapshot(big_test %>% as.data.frame()) + + # checking missing + expect_equal( + big_test$table_body %>% + dplyr::filter(.data$row_type %in% c("missing")) %>% + nrow(), + 0 + ) + + # checking value + expect_equal( + big_test$meta_data %>% + dplyr::filter(.data$variable %in% c("bad grade", "stage")) %>% + dplyr::pull(.data$summary_type) %>% + unique(), + "dichotomous" + ) + + expect_equal( + big_test$meta_data %>% + dplyr::filter(.data$variable %in% c("bad grade", "stage")) %>% + dplyr::pull(.data$dichotomous_value) %>% + purrr::every(purrr::negate(is.null)), + TRUE + ) + + # checking digits + expect_equal( + big_test$table_body %>% + dplyr::filter(.data$variable %in% c("age", "marker")) %>% + dplyr::pull(.data$stat_1) %>% + stringr::word(1) %>% + stringr::word(2, sep = stringr::fixed(".")) %>% + nchar() %>% + unique(), + 2 + ) + + expect_equal( + big_test$table_body %>% + filter(.data$variable %in% c("age", "marker")) %>% + pull(.data$stat_1) %>% + word(2) %>% + word(2, sep = fixed(".")) %>% + nchar() %>% + unique(), + 3 + ) + + # checking label + expect_equal( + big_test$meta_data %>% + dplyr::filter(.data$variable %in% c("age", "stage", "bad grade")) %>% + dplyr::pull(.data$var_label), + c("Patient Age", "Patient Stage", "Crazy Grade") + ) + + # checking type + expect_equal( + big_test$meta_data %>% + dplyr::filter(.data$variable %in% c("response", "death")) %>% + dplyr::pull(.data$summary_type), + c("categorical", "categorical") + ) + + # checking statistic + expect_equal( + big_test$meta_data[c("summary_type", "stat_display")] %>% + dplyr::filter(.data$summary_type %in% c("continuous")) %>% + dplyr::distinct() %>% + dplyr::pull(.data$stat_display) %>% + unlist(), + c("{min} {max}") + ) + expect_equal( + big_test$meta_data[c("variable", "stat_display")] %>% + dplyr::filter(.data$variable %in% c("grade", "stage")) %>% + dplyr::pull(.data$stat_display) %>% + unique() %>% + unlist(), + c("{n}") + ) +}) + +test_that("tbl_summary-order of output columns", { + expect_equal( + trial %>% + dplyr::mutate( + grade = + dplyr::case_when(grade != "III" ~ grade), + grade_str = + dplyr::case_when( + is.na(grade) ~ "Missing Grade", + grade == "I" ~ "First Grade", + grade == "II" ~ "Second Grade" + ) + ) %>% + select(grade, grade_str) %>% + tbl_summary(by = grade_str) %>% + purrr::pluck("table_body") %>% + names() %>% + { + .[startsWith(., "stat_")] + }, + paste0("stat_", 1:3) + ) +}) + +test_that("tbl_summary-all_categorical() use with `type=`", { + # no variables should be dichotomous + expect_true( + !"dichotomous" %in% + (tbl_summary(trial, type = all_dichotomous() ~ "categorical") %>% + purrr::pluck("meta_data") %>% + dplyr::pull(summary_type)) + ) +}) + + +test_that("tbl_summary-difftime does not cause error", { + expect_snapshot( + df_dplyr_storms %>% + dplyr::mutate( + date = ISOdate(year, month, day), + date_diff = difftime(dplyr::lag(date, 5), date, units = "days") + ) %>% + tbl_summary() %>% + as.data.frame() + ) +}) + + +test_that("tbl_summary-all missing data does not cause error", { + df_missing <- + tibble( + my_by_var = c(1, 1, 2, 2), + fct = rep(NA, 4) %>% factor(levels = c("lion", "tiger", "bear")), + lgl = NA, + chr = NA_character_, + int = NA_integer_, + dbl = NA_real_ + ) + + expect_error( + all_missing_no_by <- tbl_summary(df_missing %>% select(-my_by_var)), + NA + ) + expect_snapshot(all_missing_no_by %>% as.data.frame()) + + expect_error( + all_missing_by <- tbl_summary(df_missing, by = my_by_var), + NA + ) + expect_snapshot(all_missing_by %>% as.data.frame()) + + # making categorical, variables that cannot be summarized as categorical + expect_snapshot( + tbl_summary(df_missing, by = my_by_var, type = vars(int, dbl) ~ "categorical") %>% + as.data.frame() + ) + + expect_equal( + all_missing_no_by$table_body %>% + filter(variable == "fct", row_type == "level") %>% + pull(stat_0), + c("0 (NA%)", "0 (NA%)", "0 (NA%)") + ) + + expect_equal( + all_missing_no_by$table_body %>% + filter(variable %in% c("lgl", "chr"), row_type == "label") %>% + pull(stat_0), + c("0 (NA%)", "0 (NA%)") + ) + + expect_equal( + all_missing_no_by$table_body %>% + filter(variable %in% c("int", "dbl"), row_type == "label") %>% + pull(stat_0), + c("NA (NA, NA)", "NA (NA, NA)") + ) + + expect_equal( + all_missing_by$table_body %>% + filter(variable == "fct", row_type == "level") %>% + select(starts_with("stat_")), + tibble(stat_1 = c("0 (NA%)", "0 (NA%)", "0 (NA%)"), stat_2 = stat_1) + ) + + expect_equal( + all_missing_by$table_body %>% + filter(variable %in% c("lgl", "chr"), row_type == "label") %>% + select(starts_with("stat_")), + tibble(stat_1 = c("0 (NA%)", "0 (NA%)"), stat_2 = stat_1) + ) + + expect_equal( + all_missing_by$table_body %>% + filter(variable %in% c("int", "dbl"), row_type == "label") %>% + select(starts_with("stat_")), + tibble(stat_1 = c("NA (NA, NA)", "NA (NA, NA)"), stat_2 = stat_1) + ) + + # unobserved factor level + expect_error( + missing_fct_by <- + trial %>% + mutate(response2 = factor(response) %>% forcats::fct_na_value_to_level(level = "(Missing)")) %>% + filter(!is.na(response)) %>% + tbl_summary(by = response2), + NA + ) + expect_snapshot(missing_fct_by %>% as.data.frame()) + + expect_equal( + missing_fct_by$table_body %>% select(starts_with("stat_")) %>% names(), + c("stat_1", "stat_2", "stat_3") + ) +}) + + +test_that("tbl_summary-no error when *data frame* with single column passed", { + expect_snapshot( + trial["trt"] %>% + as.data.frame() %>% + tbl_summary(label = trt ~ "TREATMENT GROUP") %>% + as.data.frame() + ) +}) + + +test_that("tbl_summary-no error when by variable is ordered factor", { + expect_snapshot( + trial %>% + dplyr::mutate(grade = as.ordered(grade)) %>% + tbl_summary(by = grade) %>% + as.data.frame() + ) +}) + +test_that("tbl_summary- works with grouped data (it ungroups it first)", { + expect_snapshot( + trial %>% dplyr::group_by(response) %>% + dplyr::select(response, death, trt) %>% + tbl_summary(by = trt) %>% + as.data.frame() + ) +}) + +test_that("tbl_summary-works with ordered factors", { + expect_snapshot( + trial %>% + select(response, trt) %>% + dplyr::mutate_at( + vars(response, trt), + ~ factor(., ordered = TRUE) + ) %>% + tbl_summary(by = trt) %>% + as.data.frame() + ) +}) + + +test_that("tbl_summary-complex environments check", { + no_fun <- function() { + grade_level <- "I" + trial %>% + dplyr::select(grade) %>% + tbl_summary( + label = grade ~ paste("Grade", grade_level) + ) + } + + expect_error(tbl_env <- no_fun(), NA) + expect_equal( + tbl_env$meta_data$var_label[tbl_env$meta_data$variable == "grade"], + "Grade I" + ) + + no_fun2 <- function() { + label_var <- "grade" + trial %>% + tbl_summary( + label = all_of(label_var) ~ "Grade, oof", + ) + } + expect_error(tbl_env2 <- no_fun2(), NA) + expect_equal( + tbl_env2$meta_data$var_label[tbl_env2$meta_data$variable == "grade"], + "Grade, oof" + ) +}) + + +test_that("tbl_summary creates output without error/warning for continuous2 (no by var)", { + expect_snapshot( + purrr::map( + list(mtcars, iris), + ~ tbl_summary(.x, + type = all_continuous() ~ "continuous2", + sort = list(all_categorical() ~ "frequency") + ) %>% + as_tibble() + ) + ) + expect_warning( + purrr::map(list(mtcars, iris), ~ tbl_summary(.x)), + NA + ) +}) + + +test_that("tbl_summary creates output without error/warning for continuous2 (with by var)", { + expect_snapshot( + tbl_summary(mtcars, by = am, type = all_continuous() ~ "continuous2") %>% + as.data.frame() + ) + expect_warning( + tbl_summary(mtcars, by = am, type = all_continuous() ~ "continuous2"), + NA + ) + + expect_error( + tbl_summary(mtcars, by = am, statistic = all_continuous() ~ c("{median}", "{mean}")), + "*" + ) +}) + + +test_that("tbl_summary(digits=) tests with fn inputs", { + expect_error( + tbl_digits <- + trial %>% + select(age, marker, grade, response) %>% + tbl_summary( + missing = "no", + statistic = list( + age ~ "{mean}", + marker ~ "{mean} {sd} {N_obs} {p_nonmiss}%", + response ~ "{n} {N} {p}% {N_obs} {p_nonmiss}%" + ), + digits = list( + age ~ function(x) format(x, digits = 2, scientific = TRUE), + marker ~ list(style_number, 2, 1, function(x) style_percent(x, digits = 2)), + grade ~ c(1, 1), + response ~ list(style_number, 1, 2, 1, function(x) style_percent(x, digits = 4)) + ) + ), + NA + ) + expect_snapshot(tbl_digits %>% as.data.frame()) + + # checking the display is correct + expect_equal( + tbl_digits$table_body %>% filter(variable == "age") %>% pull(stat_0), + with(trial, glue::glue("{format(mean(age, na.rm = TRUE), digits = 2, scientific = TRUE)}")) %>% as.character(), + ignore_attr = TRUE + ) + + expect_equal( + tbl_digits$table_body %>% filter(variable == "marker") %>% pull(stat_0), + with(trial, glue::glue( + "{round(mean(marker, na.rm = TRUE))} ", + "{round(sd(marker, na.rm = TRUE), 2)} ", + "{sprintf(length(marker), fmt = '%#.1f')} ", + "{sprintf(sum(!is.na(marker)) / length(marker) * 100, fmt = '%#.2f')}%" + )) %>% as.character(), + ignore_attr = TRUE + ) + + expect_equal( + tbl_digits$table_body %>% filter(variable == "grade") %>% pull(stat_0) %>% purrr::keep(~ !is.na(.)), + c("68.0 (34.0%)", "68.0 (34.0%)", "64.0 (32.0%)"), + ignore_attr = TRUE + ) + + expect_equal( + tbl_digits$table_body %>% filter(variable == "response") %>% pull(stat_0) %>% purrr::keep(~ !is.na(.)), + "61 193.0 31.61% 200.0 96.5000%", + ignore_attr = TRUE + ) +}) + + +test_that("tbl_summary() continuous vars with cat summary vars only", { + expect_error( + tbl1 <- trial %>% select(age) %>% tbl_summary(statistic = age ~ "{N_obs}"), + NA + ) + expect_snapshot(tbl1 %>% as.data.frame()) + expect_equal(tbl1$table_body$stat_0, c("200", "11")) + + expect_error( + tbl2 <- trial %>% select(age, trt) %>% tbl_summary(by = trt, statistic = age ~ "{N_obs}"), + NA + ) + expect_snapshot(tbl2 %>% as.data.frame()) + expect_equal(tbl2$meta_data$df_stats %>% pluck(1, "N_obs"), c(98, 102), + ignore_attr = TRUE + ) +}) + +test_that("tbl_summary() works with date and date/time", { + df_date <- + data.frame( + dates = as.Date("2021-02-20") + 1:10, + times = as.POSIXct("2021-02-20 20:31:33 EST") + 1:10, + group = 1:10 %% 2 + ) + + expect_error( + tbl1 <- df_date %>% tbl_summary(), + NA + ) + expect_snapshot(tbl1 %>% as.data.frame()) + + expect_equal( + tbl1 %>% as_tibble() %>% select(last_col()) %>% dplyr::pull(), + c("2021-02-21 to 2021-03-02", "2021-02-20 20:31:34 to 2021-02-20 20:31:43", "5 (50%)") + ) + + month_year <- function(x) format(x, "%B %Y") + expect_error( + tbl1 <- df_date %>% select(-group) %>% tbl_summary(type = everything() ~ "continuous", digits = everything() ~ month_year), + NA + ) + expect_snapshot(tbl1 %>% as.data.frame()) + + expect_equal( + tbl1 %>% as_tibble() %>% select(last_col()) %>% dplyr::pull(), + c("February 2021 to March 2021", "February 2021 to February 2021") + ) + + expect_error( + tbl1 <- df_date %>% tbl_summary(by = group, type = everything() ~ "continuous", digits = everything() ~ month_year), + NA + ) + expect_snapshot(tbl1 %>% as.data.frame()) + + expect_error( + tbl2 <- df_date %>% tbl_summary(by = group), + NA + ) + expect_snapshot(tbl2 %>% as.data.frame()) +}) + + +test_that("unobserved levels can be dichotomously summarized", { + expect_equal( + trial %>% + dplyr::transmute(trt = forcats::fct_expand(trt, "Drug C")) %>% + tbl_summary(value = trt ~ "Drug C") %>% + as_tibble(col_labels = FALSE) %>% + dplyr::pull(stat_0), + "0 (0%)" + ) +}) + +test_that("Hmisc labelled data don't error", { + skip_if_not(broom.helpers::.assert_package("Hmisc", pkg_search = "gtsummary", boolean = TRUE)) + hmisc_data <- + structure( + list( + cd4_count = c( + 30, 97, 210, NA, 358, 242, 126, + 792, 6, 145, 22, 150, 43, 23, 39, 953, 357, 427, 367, 239, 72, + 61, 61, 438, 392, 1092, 245, 326, 42, 135, 199, 158, 17, NA, + 287, 187, 252, 477, 157, NA, NA, 362, NA, 183, 885, 109, 321, + 286, 142, 797 + ), + unsuccessful = c( + 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, + 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0 + ) + ), + row.names = c(NA, 50L), + class = "data.frame" + ) + + # Add label to CD4 count, using Hmisc package + Hmisc::label(hmisc_data$cd4_count) <- "CD4 count" + + expect_equal( + hmisc_data %>% + tbl_summary(by = unsuccessful, missing = "no") %>% + as_tibble(col_labels = FALSE) %>% + dplyr::pull("stat_1"), + "210 (135, 358)" + ) +}) + +test_that("no error when by variable omitted from include", { + expect_snapshot( + trial %>% + tbl_summary(by = trt, include = age) %>% + as.data.frame() + ) +}) + +test_that("all column names are accepted", { + df <- data.frame(variable = c(rep("A", 5), rep("B", 5)), value = 1:10) + + expect_snapshot( + tbl_summary(df, by = "variable") %>% + as.data.frame() + ) + expect_snapshot(tbl_summary(df) %>% as.data.frame()) + expect_snapshot( + tbl_summary(df %>% dplyr::rename(by = variable)) %>% as.data.frame() + ) + expect_snapshot( + tbl_summary(df %>% dplyr::rename(by = variable), by = "by") %>% as.data.frame() + ) +}) + +test_that("no error with factor variable with all NA and no specifed levels", { + expect_error( + tbl <- + trial %>% + dplyr::mutate( + has_banana = factor(NA) # We don't know which patients have a banana + ) %>% + tbl_summary(by = trt, include = has_banana) %>% + as_tibble(col_labels = FALSE), + NA + ) + expect_snapshot(tbl) + expect_equal( + tbl$stat_1, + c("0 (NA%)", "98") + ) +}) + + +test_that("modify_*() family works", { + tbl0 <- + trial %>% + select(trt, age, grade) %>% + tbl_summary(by = trt) + tbl1 <- + tbl0 %>% + add_difference() %>% + add_n() %>% + add_overall() %>% + modify_spanning_header(everything() ~ "N = {N}") %>% + modify_header(all_stat_cols(FALSE) ~ "{level} N = {n}", + stat_0 = "Overall N = {N}" + ) %>% + modify_footnote(label = "N = {N}") %>% + modify_caption("N = {N}") + tbl2 <- + tbl0 %>% + add_overall() %>% + add_p() %>% + add_n() %>% + modify_spanning_header(everything() ~ "N = {N}") %>% + modify_header(all_stat_cols(FALSE) ~ "{level} N = {n}", + stat_0 = "Overall N = {N}" + ) %>% + modify_footnote(label = "N = {N}") %>% + modify_caption("N = {N}") + + expect_false( + any(is.na(tbl1$table_styling$header$modify_stat_N)) + ) + expect_false( + any(is.na(tbl2$table_styling$header$modify_stat_N)) + ) + + expect_true( + all(tbl1$table_styling$header$spanning_header == "N = 200") + ) + expect_true( + all(tbl2$table_styling$header$spanning_header == "N = 200") + ) + + expect_equal( + tbl1$table_styling$header %>% + filter(startsWith(column, "stat_")) %>% + pull(label), + c("Overall N = 200", "Drug A N = 98", "Drug B N = 102") + ) + expect_equal( + tbl2$table_styling$header %>% + filter(startsWith(column, "stat_")) %>% + pull(label), + c("Overall N = 200", "Drug A N = 98", "Drug B N = 102") + ) + + expect_equal( + tbl1$table_styling$caption, + "N = 200", + ignore_attr = TRUE + ) + expect_equal( + tbl2$table_styling$caption, + "N = 200", + ignore_attr = TRUE + ) + + expect_equal( + tbl_merge(list(tbl0, tbl0))$table_styling$header %>% + filter(startsWith(column, "stat_")) %>% + dplyr::pull(modify_stat_n), + c(98, 102, 98, 102) + ) +}) + + + + +test_that("no error when data frame contains named vector", { + df <- + structure( + list( + swallowing = structure(c(NA, 53, 100, 0, 100), + names = c("", "", "", "", "") + ), + salivation = structure(c(NA, 100, 46, 62, 100), + names = c("", "", "", "", "") + ) + ), + row.names = c(NA, -5L), class = c("tbl_df", "tbl", "data.frame") + ) + + expect_snapshot( + tbl_summary(df, type = list(everything() ~ "continuous")) %>% as.data.frame() + ) +}) diff --git a/tests/testthat/test-tbl_summary_input_checks.R b/_archive/tests/testthat/test-tbl_summary_input_checks.R similarity index 100% rename from tests/testthat/test-tbl_summary_input_checks.R rename to _archive/tests/testthat/test-tbl_summary_input_checks.R diff --git a/tests/testthat/test-tbl_survfit.R b/_archive/tests/testthat/test-tbl_survfit.R similarity index 100% rename from tests/testthat/test-tbl_survfit.R rename to _archive/tests/testthat/test-tbl_survfit.R diff --git a/tests/testthat/test-tbl_survival.R b/_archive/tests/testthat/test-tbl_survival.R similarity index 100% rename from tests/testthat/test-tbl_survival.R rename to _archive/tests/testthat/test-tbl_survival.R diff --git a/tests/testthat/test-tbl_svysummary.R b/_archive/tests/testthat/test-tbl_svysummary.R similarity index 100% rename from tests/testthat/test-tbl_svysummary.R rename to _archive/tests/testthat/test-tbl_svysummary.R diff --git a/tests/testthat/test-tbl_uvregression.R b/_archive/tests/testthat/test-tbl_uvregression.R similarity index 100% rename from tests/testthat/test-tbl_uvregression.R rename to _archive/tests/testthat/test-tbl_uvregression.R diff --git a/tests/testthat/test-vetted_models-clogit.R b/_archive/tests/testthat/test-vetted_models-clogit.R similarity index 100% rename from tests/testthat/test-vetted_models-clogit.R rename to _archive/tests/testthat/test-vetted_models-clogit.R diff --git a/tests/testthat/test-vetted_models-coxph.R b/_archive/tests/testthat/test-vetted_models-coxph.R similarity index 100% rename from tests/testthat/test-vetted_models-coxph.R rename to _archive/tests/testthat/test-vetted_models-coxph.R diff --git a/tests/testthat/test-vetted_models-geeglm.R b/_archive/tests/testthat/test-vetted_models-geeglm.R similarity index 100% rename from tests/testthat/test-vetted_models-geeglm.R rename to _archive/tests/testthat/test-vetted_models-geeglm.R diff --git a/tests/testthat/test-vetted_models-glm.R b/_archive/tests/testthat/test-vetted_models-glm.R similarity index 100% rename from tests/testthat/test-vetted_models-glm.R rename to _archive/tests/testthat/test-vetted_models-glm.R diff --git a/tests/testthat/test-vetted_models-glmer.R b/_archive/tests/testthat/test-vetted_models-glmer.R similarity index 100% rename from tests/testthat/test-vetted_models-glmer.R rename to _archive/tests/testthat/test-vetted_models-glmer.R diff --git a/tests/testthat/test-vetted_models-lm.R b/_archive/tests/testthat/test-vetted_models-lm.R similarity index 100% rename from tests/testthat/test-vetted_models-lm.R rename to _archive/tests/testthat/test-vetted_models-lm.R diff --git a/tests/testthat/test-vetted_models-lmer.R b/_archive/tests/testthat/test-vetted_models-lmer.R similarity index 100% rename from tests/testthat/test-vetted_models-lmer.R rename to _archive/tests/testthat/test-vetted_models-lmer.R diff --git a/tests/testthat/test-vetted_models-survreg.R b/_archive/tests/testthat/test-vetted_models-survreg.R similarity index 100% rename from tests/testthat/test-vetted_models-survreg.R rename to _archive/tests/testthat/test-vetted_models-survreg.R diff --git a/vignettes/.gitignore b/_archive/vignettes/.gitignore similarity index 100% rename from vignettes/.gitignore rename to _archive/vignettes/.gitignore diff --git a/vignettes/articles/shiny.Rmd b/_archive/vignettes/articles/shiny.Rmd similarity index 100% rename from vignettes/articles/shiny.Rmd rename to _archive/vignettes/articles/shiny.Rmd diff --git a/vignettes/gallery.Rmd b/_archive/vignettes/gallery.Rmd similarity index 100% rename from vignettes/gallery.Rmd rename to _archive/vignettes/gallery.Rmd diff --git a/vignettes/gtsummary_definition.Rmd b/_archive/vignettes/gtsummary_definition.Rmd similarity index 100% rename from vignettes/gtsummary_definition.Rmd rename to _archive/vignettes/gtsummary_definition.Rmd diff --git a/vignettes/img/icons8-confused-100.png b/_archive/vignettes/img/icons8-confused-100.png similarity index 100% rename from vignettes/img/icons8-confused-100.png rename to _archive/vignettes/img/icons8-confused-100.png diff --git a/vignettes/img/icons8-disappointed-100.png b/_archive/vignettes/img/icons8-disappointed-100.png similarity index 100% rename from vignettes/img/icons8-disappointed-100.png rename to _archive/vignettes/img/icons8-disappointed-100.png diff --git a/vignettes/img/icons8-neutral-100.png b/_archive/vignettes/img/icons8-neutral-100.png similarity index 100% rename from vignettes/img/icons8-neutral-100.png rename to _archive/vignettes/img/icons8-neutral-100.png diff --git a/vignettes/img/icons8-no-entry-100.png b/_archive/vignettes/img/icons8-no-entry-100.png similarity index 100% rename from vignettes/img/icons8-no-entry-100.png rename to _archive/vignettes/img/icons8-no-entry-100.png diff --git a/vignettes/img/icons8-smiling-100.png b/_archive/vignettes/img/icons8-smiling-100.png similarity index 100% rename from vignettes/img/icons8-smiling-100.png rename to _archive/vignettes/img/icons8-smiling-100.png diff --git a/vignettes/img/icons8-under-construction-100.png b/_archive/vignettes/img/icons8-under-construction-100.png similarity index 100% rename from vignettes/img/icons8-under-construction-100.png rename to _archive/vignettes/img/icons8-under-construction-100.png diff --git a/vignettes/inline_text.Rmd b/_archive/vignettes/inline_text.Rmd similarity index 100% rename from vignettes/inline_text.Rmd rename to _archive/vignettes/inline_text.Rmd diff --git a/vignettes/rmarkdown.Rmd b/_archive/vignettes/rmarkdown.Rmd similarity index 100% rename from vignettes/rmarkdown.Rmd rename to _archive/vignettes/rmarkdown.Rmd diff --git a/vignettes/tbl_regression.Rmd b/_archive/vignettes/tbl_regression.Rmd similarity index 100% rename from vignettes/tbl_regression.Rmd rename to _archive/vignettes/tbl_regression.Rmd diff --git a/vignettes/tbl_summary.Rmd b/_archive/vignettes/tbl_summary.Rmd similarity index 100% rename from vignettes/tbl_summary.Rmd rename to _archive/vignettes/tbl_summary.Rmd diff --git a/vignettes/themes.Rmd b/_archive/vignettes/themes.Rmd similarity index 100% rename from vignettes/themes.Rmd rename to _archive/vignettes/themes.Rmd diff --git a/gtsummary.Rproj b/gtsummary.Rproj index cba1b6b7a0..69fafd4b6d 100644 --- a/gtsummary.Rproj +++ b/gtsummary.Rproj @@ -14,6 +14,7 @@ LaTeX: pdfLaTeX AutoAppendNewline: Yes StripTrailingWhitespace: Yes +LineEndingConversion: Posix BuildType: Package PackageUseDevtools: Yes diff --git a/man/as_gt.Rd b/man/as_gt.Rd index d73e51c97c..06a7af7425 100644 --- a/man/as_gt.Rd +++ b/man/as_gt.Rd @@ -36,16 +36,6 @@ or \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html#advanced}{tbl_regression vignette} for detailed examples in the 'Advanced Customization' section. } -\section{Example Output}{ - - -\if{html}{Example 1} - -\if{html}{\out{ -image of rendered example table -}} -} - \examples{ # Example 1 ---------------------------------- as_gt_ex1 <- @@ -53,14 +43,6 @@ as_gt_ex1 <- tbl_summary(by = trt) \%>\% as_gt() } -\seealso{ -Other gtsummary output types: -\code{\link{as_flex_table}()}, -\code{\link{as_hux_table}()}, -\code{\link{as_kable_extra}()}, -\code{\link{as_kable}()}, -\code{\link{as_tibble.gtsummary}()} -} \author{ Daniel D. Sjoberg } diff --git a/man/bridge_tbl_summary.Rd b/man/bridge_tbl_summary.Rd new file mode 100644 index 0000000000..5f13688890 --- /dev/null +++ b/man/bridge_tbl_summary.Rd @@ -0,0 +1,98 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bridge_tbl_summary.R +\name{bridge_tbl_summary} +\alias{bridge_tbl_summary} +\alias{bridge_summary_dichotomous} +\alias{bridge_summary_categorical} +\alias{bridge_summary_continuous2} +\alias{bridge_summary_continuous} +\title{Summary Table Bridges} +\usage{ +bridge_summary_dichotomous( + x, + variables, + value, + missing, + missing_text, + missing_stat +) + +bridge_summary_categorical(x, variables, missing, missing_text, missing_stat) + +bridge_summary_continuous2(x, variables, missing, missing_text, missing_stat) + +bridge_summary_continuous(x, variables, missing, missing_text, missing_stat) +} +\arguments{ +\item{x}{gtsummary object of class \code{"tbl_summary"}} + +\item{variables}{character list of variables} + +\item{value}{named list of values to be summarized. the names are the +variable names.} + +\item{missing}{TODO:} + +\item{missing_text}{TODO:} + +\item{missing_stat}{TODO:} +} +\value{ +data frame +} +\description{ +Bridge functions for converting \code{tbl_summary()} cards to table bodies. +} +\examples{ +tbl <- + tbl_summary( + data = mtcars, + type = + list( + cyl = "categorical", + am = "dichotomous", + mpg = "continuous", + hp = "continuous2" + ), + value = list(am = 1), + statistic = + list( + c(cyl, am) ~ "{n} ({p}\%)", + mpg = "{mean} ({sd})", + hp = c("{mean}", "{median}") + ) + ) + +bridge_summary_dichotomous( + x = tbl, + variables = "am", + value = list(am = 1), + missing = "ifany", + missing_text = "Unknown", + missing_stat = "{N_miss}" +) + +bridge_summary_categorical( + x = tbl, + variables = "cyl", + missing = "ifany", + missing_text = "Unknown", + missing_stat = "{N_miss}" +) + +bridge_summary_continuous2( + x = tbl, + variables = "hp", + missing = "ifany", + missing_text = "Unknown", + missing_stat = "{N_miss}" +) + +bridge_summary_continuous( + x = tbl, + variables = "mpg", + missing = "ifany", + missing_text = "Unknown", + missing_stat = "{N_miss}" +) +} diff --git a/man/construct_gtsummary.Rd b/man/construct_gtsummary.Rd new file mode 100644 index 0000000000..902672b81e --- /dev/null +++ b/man/construct_gtsummary.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/construct_table_body.R +\name{construct_gtsummary} +\alias{construct_gtsummary} +\alias{construct_gtsummary.default} +\alias{construct_gtsummary.tbl_summary} +\title{Construct Table Body} +\usage{ +construct_gtsummary(x) + +\method{construct_gtsummary}{default}(x) + +\method{construct_gtsummary}{tbl_summary}(x) +} +\arguments{ +\item{x}{gtsummary object} +} +\value{ +gtsummary object +} +\description{ +Construct Table Body +} +\examples{ +# TODO: Add example +} diff --git a/man/gtsummary-package.Rd b/man/gtsummary-package.Rd index c4d8eeb1e0..cc0406aa3e 100644 --- a/man/gtsummary-package.Rd +++ b/man/gtsummary-package.Rd @@ -6,8 +6,6 @@ \alias{gtsummary-package} \title{gtsummary: Presentation-Ready Data Summary and Analytic Result Tables} \description{ -\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} - Creates presentation-ready tables summarizing data sets, regression models, and more. The code to create the tables is concise and highly customizable. Data frames can be summarized with any function, e.g. mean(), median(), even user-written functions. Regression models are summarized and include the reference rows for categorical variables. Common regression models, such as logistic regression and Cox proportional hazards regression, are automatically identified and the tables are pre-filled with appropriate column headers. } \seealso{ diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index f6c6ba067f..04014a40b4 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -23,7 +23,7 @@ Use these functions to hide or unhide columns in a gtsummary table. \if{html}{Example 1} \if{html}{\out{ -image of rendered example table +`r man_create_image_tag(file = "modify_column_hide_ex1.png", width = "45")` }} } @@ -42,11 +42,6 @@ modify_column_hide_ex1 <- Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: -\code{\link{modify_column_alignment}()}, -\code{\link{modify_column_indent}()}, -\code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index b3f675c2d7..6766975059 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -123,11 +123,6 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: -\code{\link{modify_column_alignment}()}, -\code{\link{modify_column_hide}()}, -\code{\link{modify_column_indent}()}, -\code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_body}()} +\code{\link{modify_column_hide}()} } \concept{Advanced modifiers} diff --git a/man/print_gtsummary.Rd b/man/print_gtsummary.Rd index 688d0217e6..90be5eab62 100644 --- a/man/print_gtsummary.Rd +++ b/man/print_gtsummary.Rd @@ -3,12 +3,9 @@ \name{print_gtsummary} \alias{print_gtsummary} \alias{print.gtsummary} -\alias{knit_print.gtsummary} \title{print and knit_print methods for gtsummary objects} \usage{ -\method{print}{gtsummary}(x, print_engine = NULL, ...) - -\method{knit_print}{gtsummary}(x, ...) +\method{print}{gtsummary}(x, print_engine = "gt", ...) } \arguments{ \item{x}{An object created using gtsummary functions} @@ -21,9 +18,6 @@ \description{ print and knit_print methods for gtsummary objects } -\seealso{ -\link{tbl_summary} \link{tbl_regression} \link{tbl_uvregression} \link{tbl_merge} \link{tbl_stack} -} \author{ Daniel D. Sjoberg } diff --git a/man/reexports.Rd b/man/reexports.Rd index 4f6c512bd3..961ee93734 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -3,10 +3,8 @@ \docType{import} \name{reexports} \alias{reexports} -\alias{as_tibble} -\alias{knit_print} \alias{\%>\%} -\alias{vars} +\alias{as_tibble} \alias{select} \alias{mutate} \alias{starts_with} @@ -19,6 +17,7 @@ \alias{everything} \alias{last_col} \alias{one_of} +\alias{vars} \title{Objects exported from other packages} \keyword{internal} \description{ @@ -26,10 +25,6 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \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]{mutate}}, \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}}} - - \item{tibble}{\code{\link[tibble]{as_tibble}}} + \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{as_tibble}}, \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]{mutate}}, \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}}} }} diff --git a/man/select_helpers.Rd b/man/select_helpers.Rd index 61c1468d65..0fd5476576 100644 --- a/man/select_helpers.Rd +++ b/man/select_helpers.Rd @@ -64,15 +64,6 @@ functions for selecting columns of data frames (and other items as well). \item \code{all_contrasts()} selects variables in regression model based on their type of contrast } } -\section{Example Output}{ - -\if{html}{Example 1} - -\if{html}{\out{ -image of rendered example table -}} -} - \examples{ select_ex1 <- trial \%>\% diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index b59e5df7db..f4bc034a2f 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tbl_summary.R \name{tbl_summary} \alias{tbl_summary} -\title{Create a table of summary statistics} +\title{Title} \usage{ tbl_summary( data, @@ -12,260 +12,64 @@ tbl_summary( digits = NULL, type = NULL, value = NULL, - missing = NULL, - missing_text = NULL, + missing = c("ifany", "no", "always"), + missing_text = "Unknown", + missing_stat = "{N_miss}", sort = NULL, - percent = NULL, - include = everything() + percent = c("column", "row", "cell"), + include = c(everything(), -by) ) } \arguments{ -\item{data}{A data frame} +\item{data}{TODO:} -\item{by}{A column name (quoted or unquoted) in \code{data}. -Summary statistics will be calculated separately for each level of the \code{by} -variable (e.g. \code{by = trt}). If \code{NULL}, summary statistics -are calculated using all observations. To stratify a table by two or more -variables, use \code{tbl_strata()}} +\item{by}{TODO:} -\item{label}{List of formulas specifying variables labels, -e.g. \code{list(age ~ "Age", stage ~ "Path T Stage")}. If a -variable's label is not specified here, the label attribute -(\code{attr(data$age, "label")}) is used. If -attribute label is \code{NULL}, the variable name will be used.} +\item{label}{TODO:} -\item{statistic}{List of formulas specifying types of summary statistics to -display for each variable. The default is -\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. -See below for details.} +\item{statistic}{TODO:} -\item{digits}{List of formulas specifying the number of decimal -places to round summary statistics. If not specified, -\code{tbl_summary} guesses an appropriate number of decimals to round statistics. -When multiple statistics are displayed for a single variable, supply a vector -rather than an integer. For example, if the -statistic being calculated is \code{"{mean} ({sd})"} and you want the mean rounded -to 1 decimal place, and the SD to 2 use \code{digits = list(age ~ c(1, 2))}. User -may also pass a styling function: \code{digits = age ~ style_sigfig}} +\item{digits}{TODO:} -\item{type}{List of formulas specifying variable types. Accepted values -are \code{c("continuous", "continuous2", "categorical", "dichotomous")}, -e.g. \code{type = list(age ~ "continuous", female ~ "dichotomous")}. -If type not specified for a variable, the function -will default to an appropriate summary type. See below for details.} +\item{type}{TODO:} -\item{value}{List of formulas specifying the value to display for dichotomous -variables. gtsummary selectors, e.g. \code{all_dichotomous()}, cannot be used -with this argument. See below for details.} +\item{value}{TODO:} -\item{missing}{Indicates whether to include counts of \code{NA} values in the table. -Allowed values are \code{"no"} (never display NA values), -\code{"ifany"} (only display if any NA values), and \code{"always"} -(includes NA count row for all variables). Default is \code{"ifany"}.} +\item{missing}{TODO:} -\item{missing_text}{String to display for count of missing observations. -Default is \code{"Unknown"}.} +\item{missing_text}{TODO:} -\item{sort}{List of formulas specifying the type of sorting to perform for -categorical data. Options are \code{frequency} where results are sorted in -descending order of frequency and \code{alphanumeric}, -e.g. \code{sort = list(everything() ~ "frequency")}} +\item{missing_stat}{TODO:} -\item{percent}{Indicates the type of percentage to return. Must be one of -\code{"column"}, \code{"row"}, or \code{"cell"}. Default is \code{"column"}.} +\item{sort}{TODO:} -\item{include}{variables to include in the summary table. Default is \code{everything()}} +\item{percent}{TODO:} + +\item{include}{TODO:} } \value{ -A \code{tbl_summary} object +a gtsummary table of class \code{"tbl_summary"} } \description{ -The \code{tbl_summary} function calculates descriptive statistics for -continuous, categorical, and dichotomous variables. Review the -\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} -for detailed examples. -} -\section{select helpers}{ - -\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#select_helpers}{Select helpers} -from the \\{tidyselect\\} package and \\{gtsummary\\} package are available to -modify default behavior for groups of variables. -For example, by default continuous variables are reported with the median -and IQR. To change all continuous variables to mean and standard deviation use -\code{statistic = list(all_continuous() ~ "{mean} ({sd})")}. - -All columns with class logical are displayed as dichotomous variables showing -the proportion of events that are \code{TRUE} on a single row. To show both rows -(i.e. a row for \code{TRUE} and a row for \code{FALSE}) use -\code{type = list(where(is.logical) ~ "categorical")}. - -The select helpers are available for use in any argument that accepts a list -of formulas (e.g. \code{statistic}, \code{type}, \code{digits}, \code{value}, \code{sort}, etc.) - -Read more on the \link{syntax} used through the package. -} - -\section{type argument}{ - -The \code{tbl_summary()} function has four summary types: -\itemize{ -\item \code{"continuous"} summaries are shown on a \emph{single row}. Most numeric -variables default to summary type continuous. -\item \code{"continuous2"} summaries are shown on \emph{2 or more rows} -\item \code{"categorical"} \emph{multi-line} summaries of nominal data. Character variables, -factor variables, and numeric variables with fewer than 10 unique levels default to -type categorical. To change a numeric variable to continuous that -defaulted to categorical, use \code{type = list(varname ~ "continuous")} -\item \code{"dichotomous"} categorical variables that are displayed on a \emph{single row}, -rather than one row per level of the variable. -Variables coded as \code{TRUE}/\code{FALSE}, \code{0}/\code{1}, or \code{yes}/\code{no} are assumed to be dichotomous, -and the \code{TRUE}, \code{1}, and \code{yes} rows are displayed. -Otherwise, the value to display must be specified in the \code{value} -argument, e.g. \code{value = list(varname ~ "level to show")} -} -} - -\section{statistic argument}{ - -The statistic argument specifies the statistics presented in the table. The -input is a list of formulas that specify the statistics to report. For example, -\code{statistic = list(age ~ "{mean} ({sd})")} would report the mean and -standard deviation for age; \code{statistic = list(all_continuous() ~ "{mean} ({sd})")} -would report the mean and standard deviation for all continuous variables. -A statistic name that appears between curly brackets -will be replaced with the numeric statistic (see \link[glue:glue]{glue::glue}). - -For categorical variables the following statistics are available to display. -\itemize{ -\item \code{{n}} frequency -\item \code{{N}} denominator, or cohort size -\item \code{{p}} formatted percentage -} -For continuous variables the following statistics are available to display. -\itemize{ -\item \code{{median}} median -\item \code{{mean}} mean -\item \code{{sd}} standard deviation -\item \code{{var}} variance -\item \code{{min}} minimum -\item \code{{max}} maximum -\item \code{{sum}} sum -\item \verb{\{p##\}} any integer percentile, where \verb{##} is an integer from 0 to 100 -\item \code{{foo}} any function of the form \code{foo(x)} is accepted where \code{x} is a numeric vector -} -When the summary type is \code{"continuous2"}, pass a vector of statistics. Each element -of the vector will result in a separate row in the summary table. - -For both categorical and continuous variables, statistics on the number of -missing and non-missing observations and their proportions are available to -display. -\itemize{ -\item \code{{N_obs}} total number of observations -\item \code{{N_miss}} number of missing observations -\item \code{{N_nonmiss}} number of non-missing observations -\item \code{{p_miss}} percentage of observations missing -\item \code{{p_nonmiss}} percentage of observations not missing +Title } - -Note that for categorical variables, \code{{N_obs}}, \code{{N_miss}} and \code{{N_nonmiss}} refer -to the total number, number missing and number non missing observations -in the denominator, not at each level of the categorical variable. -} - -\section{Example Output}{ - -\if{html}{Example 1} - -\if{html}{\out{ -image of rendered example table -}} - -\if{html}{Example 2} - -\if{html}{\out{ -image of rendered example table -}} - -\if{html}{Example 3} - -\if{html}{\out{ -image of rendered example table -}} - -\if{html}{Example 4} - -\if{html}{\out{ -image of rendered example table -}} -} - \examples{ -\donttest{ -# Example 1 ---------------------------------- -tbl_summary_ex1 <- - trial \%>\% - select(age, grade, response) \%>\% - tbl_summary() - -# Example 2 ---------------------------------- -tbl_summary_ex2 <- - trial \%>\% - select(age, grade, response, trt) \%>\% +tbl <- tbl_summary( - by = trt, - label = list(age ~ "Patient Age"), - statistic = list(all_continuous() ~ "{mean} ({sd})"), - digits = list(age ~ c(0, 1)) + data = mtcars, + type = + list( + cyl = "categorical", + am = "dichotomous", + mpg = "continuous", + hp = "continuous2" + ), + value = list(am = 1), + statistic = + list( + c(cyl, am) ~ "{n} ({p}\%)", + mpg = "{mean} ({sd})", + hp = c("{mean}", "{median}") + ) ) - -# Example 3 ---------------------------------- -# for convenience, you can also pass named lists to any arguments -# that accept formulas (e.g label, digits, etc.) -tbl_summary_ex3 <- - trial \%>\% - select(age, trt) \%>\% - tbl_summary( - by = trt, - label = list(age = "Patient Age") - ) - -# Example 4 ---------------------------------- -# multi-line summaries of continuous data with type 'continuous2' -tbl_summary_ex4 <- - trial \%>\% - select(age, marker) \%>\% - tbl_summary( - type = all_continuous() ~ "continuous2", - statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), - missing = "no" - ) -} -} -\seealso{ -See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial - -See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples - -Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary - -Other tbl_summary tools: -\code{\link{add_n.tbl_summary}()}, -\code{\link{add_overall}()}, -\code{\link{add_p.tbl_summary}()}, -\code{\link{add_q}()}, -\code{\link{add_stat_label}()}, -\code{\link{bold_italicize_labels_levels}}, -\code{\link{inline_text.tbl_summary}()}, -\code{\link{inline_text.tbl_survfit}()}, -\code{\link{modify}}, -\code{\link{separate_p_footnotes}()}, -\code{\link{tbl_custom_summary}()}, -\code{\link{tbl_merge}()}, -\code{\link{tbl_split}()}, -\code{\link{tbl_stack}()}, -\code{\link{tbl_strata}()} -} -\author{ -Daniel D. Sjoberg } -\concept{tbl_summary tools} diff --git a/tests/testthat.R b/tests/testthat.R index d362e38ec4..0f0a3330b3 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,5 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + library(testthat) library(gtsummary) test_check("gtsummary") -options(usethis.quiet = TRUE) diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index 1310653ead..8849056e25 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -1,789 +1,3 @@ -skip_on_cran() - -test_that("tbl_summary creates output without error/warning (no by var)", { - expect_error( - lst_tbl <- purrr::map(list(mtcars, iris), ~ tbl_summary(.x, sort = list(all_categorical() ~ "frequency"))), - NA - ) - expect_snapshot(purrr::map(lst_tbl, as.data.frame)) - expect_warning( - purrr::map(list(mtcars, iris), ~ tbl_summary(.x)), - NA - ) -}) - - -test_that("tbl_summary creates output without error/warning (with by var)", { - expect_snapshot( - tbl_summary(mtcars, by = am) %>% - as.data.frame() - ) - expect_warning( - tbl_summary(mtcars, by = am), - NA - ) -}) - -test_that("tbl_summary allows for named list input", { - expect_snapshot( - tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl")) %>% - as.data.frame() - ) - expect_warning( - tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl")), - NA - ) -}) - - -test_that("tbl_summary throws errors/messages with bad 'sort = ' specifications", { - expect_error( - tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))), - NULL - ) - expect_error( - tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")), - NULL - ) -}) - -test_that("tbl_summary value argument works properly", { - expect_snapshot( - tbl_summary(trial, value = "grade" ~ "III") %>% - as.data.frame() - ) -}) - -test_that("tbl_summary works in character inputs for `by=`", { - my_by_variable <- "trt" - - expect_snapshot( - tbl_summary(trial, by = all_of(my_by_variable)) %>% - as.data.frame() - ) - expect_snapshot( - tbl_summary(trial, by = "trt") %>% - as.data.frame() - ) - expect_snapshot( - purrr::map( - c("trt", "grade", "stage"), - ~ tbl_summary(trial, by = all_of(.x)) %>% as_tibble() - ) - ) -}) - - -test_that("tbl_summary returns errors with bad inputs", { - expect_error( - tbl_summary(tibble::tibble()), - NULL - ) - expect_error( - tbl_summary(tibble::tibble(t = integer())), - NULL - ) - expect_error( - tbl_summary(list(test = 5)), - NULL - ) - expect_error( - tbl_summary(trial, by = THIS_IS_NOT_A_VARIABLE), - NULL - ) - expect_message( - tbl_summary(trial, by = response), # should get message about missing data - NULL - ) - expect_error( - tbl_summary(trial, type = response), - NULL - ) - expect_error( - tbl_summary(trial, value = "0"), - NULL - ) - expect_error( - tbl_summary(trial, label = "Age"), - NULL - ) - expect_error( - tbl_summary(trial, statistic = "{mean}"), - NULL - ) - expect_error( - tbl_summary(trial, digits = 0), - NULL - ) - expect_error( - tbl_summary(trial, sort = list("grade" ~ "frequ55555ency")), - NULL - ) - expect_error( - tbl_summary(trial, by = c("trt", "grade")), - NULL - ) - - expect_error( - tbl_summary(trial, statistic = everything() ~ "{mean}"), - NULL - ) -}) - - -test_that("tbl_summary-testing tidyselect parsing", { - trial2 <- trial - trial2$`bad trt` <- trial2$trt - trial2$`bad grade` <- trial2$grade - - expect_error( - big_test <- - tbl_summary( - data = trial2, - by = `bad trt`, - type = vars(response, death) ~ "categorical", - statistic = list( - all_continuous() ~ "{min} {max}", - c("grade", "stage") ~ "{n}" - ), - label = list( - age ~ "Patient Age", vars(stage) ~ "Patient Stage", - vars(`bad grade`) ~ "Crazy Grade" - ), - digits = list(vars(age) ~ c(2, 3), marker ~ c(2, 3)), - value = list(`bad grade` = "III", "stage" = "T1"), - missing = "no" - ), - NA - ) - expect_snapshot(big_test %>% as.data.frame()) - - # checking missing - expect_equal( - big_test$table_body %>% - dplyr::filter(.data$row_type %in% c("missing")) %>% - nrow(), - 0 - ) - - # checking value - expect_equal( - big_test$meta_data %>% - dplyr::filter(.data$variable %in% c("bad grade", "stage")) %>% - dplyr::pull(.data$summary_type) %>% - unique(), - "dichotomous" - ) - - expect_equal( - big_test$meta_data %>% - dplyr::filter(.data$variable %in% c("bad grade", "stage")) %>% - dplyr::pull(.data$dichotomous_value) %>% - purrr::every(purrr::negate(is.null)), - TRUE - ) - - # checking digits - expect_equal( - big_test$table_body %>% - dplyr::filter(.data$variable %in% c("age", "marker")) %>% - dplyr::pull(.data$stat_1) %>% - stringr::word(1) %>% - stringr::word(2, sep = stringr::fixed(".")) %>% - nchar() %>% - unique(), - 2 - ) - - expect_equal( - big_test$table_body %>% - filter(.data$variable %in% c("age", "marker")) %>% - pull(.data$stat_1) %>% - word(2) %>% - word(2, sep = fixed(".")) %>% - nchar() %>% - unique(), - 3 - ) - - # checking label - expect_equal( - big_test$meta_data %>% - dplyr::filter(.data$variable %in% c("age", "stage", "bad grade")) %>% - dplyr::pull(.data$var_label), - c("Patient Age", "Patient Stage", "Crazy Grade") - ) - - # checking type - expect_equal( - big_test$meta_data %>% - dplyr::filter(.data$variable %in% c("response", "death")) %>% - dplyr::pull(.data$summary_type), - c("categorical", "categorical") - ) - - # checking statistic - expect_equal( - big_test$meta_data[c("summary_type", "stat_display")] %>% - dplyr::filter(.data$summary_type %in% c("continuous")) %>% - dplyr::distinct() %>% - dplyr::pull(.data$stat_display) %>% - unlist(), - c("{min} {max}") - ) - expect_equal( - big_test$meta_data[c("variable", "stat_display")] %>% - dplyr::filter(.data$variable %in% c("grade", "stage")) %>% - dplyr::pull(.data$stat_display) %>% - unique() %>% - unlist(), - c("{n}") - ) -}) - -test_that("tbl_summary-order of output columns", { - expect_equal( - trial %>% - dplyr::mutate( - grade = - dplyr::case_when(grade != "III" ~ grade), - grade_str = - dplyr::case_when( - is.na(grade) ~ "Missing Grade", - grade == "I" ~ "First Grade", - grade == "II" ~ "Second Grade" - ) - ) %>% - select(grade, grade_str) %>% - tbl_summary(by = grade_str) %>% - purrr::pluck("table_body") %>% - names() %>% - { - .[startsWith(., "stat_")] - }, - paste0("stat_", 1:3) - ) -}) - -test_that("tbl_summary-all_categorical() use with `type=`", { - # no variables should be dichotomous - expect_true( - !"dichotomous" %in% - (tbl_summary(trial, type = all_dichotomous() ~ "categorical") %>% - purrr::pluck("meta_data") %>% - dplyr::pull(summary_type)) - ) -}) - - -test_that("tbl_summary-difftime does not cause error", { - expect_snapshot( - df_dplyr_storms %>% - dplyr::mutate( - date = ISOdate(year, month, day), - date_diff = difftime(dplyr::lag(date, 5), date, units = "days") - ) %>% - tbl_summary() %>% - as.data.frame() - ) -}) - - -test_that("tbl_summary-all missing data does not cause error", { - df_missing <- - tibble( - my_by_var = c(1, 1, 2, 2), - fct = rep(NA, 4) %>% factor(levels = c("lion", "tiger", "bear")), - lgl = NA, - chr = NA_character_, - int = NA_integer_, - dbl = NA_real_ - ) - - expect_error( - all_missing_no_by <- tbl_summary(df_missing %>% select(-my_by_var)), - NA - ) - expect_snapshot(all_missing_no_by %>% as.data.frame()) - - expect_error( - all_missing_by <- tbl_summary(df_missing, by = my_by_var), - NA - ) - expect_snapshot(all_missing_by %>% as.data.frame()) - - # making categorical, variables that cannot be summarized as categorical - expect_snapshot( - tbl_summary(df_missing, by = my_by_var, type = vars(int, dbl) ~ "categorical") %>% - as.data.frame() - ) - - expect_equal( - all_missing_no_by$table_body %>% - filter(variable == "fct", row_type == "level") %>% - pull(stat_0), - c("0 (NA%)", "0 (NA%)", "0 (NA%)") - ) - - expect_equal( - all_missing_no_by$table_body %>% - filter(variable %in% c("lgl", "chr"), row_type == "label") %>% - pull(stat_0), - c("0 (NA%)", "0 (NA%)") - ) - - expect_equal( - all_missing_no_by$table_body %>% - filter(variable %in% c("int", "dbl"), row_type == "label") %>% - pull(stat_0), - c("NA (NA, NA)", "NA (NA, NA)") - ) - - expect_equal( - all_missing_by$table_body %>% - filter(variable == "fct", row_type == "level") %>% - select(starts_with("stat_")), - tibble(stat_1 = c("0 (NA%)", "0 (NA%)", "0 (NA%)"), stat_2 = stat_1) - ) - - expect_equal( - all_missing_by$table_body %>% - filter(variable %in% c("lgl", "chr"), row_type == "label") %>% - select(starts_with("stat_")), - tibble(stat_1 = c("0 (NA%)", "0 (NA%)"), stat_2 = stat_1) - ) - - expect_equal( - all_missing_by$table_body %>% - filter(variable %in% c("int", "dbl"), row_type == "label") %>% - select(starts_with("stat_")), - tibble(stat_1 = c("NA (NA, NA)", "NA (NA, NA)"), stat_2 = stat_1) - ) - - # unobserved factor level - expect_error( - missing_fct_by <- - trial %>% - mutate(response2 = factor(response) %>% forcats::fct_na_value_to_level(level = "(Missing)")) %>% - filter(!is.na(response)) %>% - tbl_summary(by = response2), - NA - ) - expect_snapshot(missing_fct_by %>% as.data.frame()) - - expect_equal( - missing_fct_by$table_body %>% select(starts_with("stat_")) %>% names(), - c("stat_1", "stat_2", "stat_3") - ) -}) - - -test_that("tbl_summary-no error when *data frame* with single column passed", { - expect_snapshot( - trial["trt"] %>% - as.data.frame() %>% - tbl_summary(label = trt ~ "TREATMENT GROUP") %>% - as.data.frame() - ) -}) - - -test_that("tbl_summary-no error when by variable is ordered factor", { - expect_snapshot( - trial %>% - dplyr::mutate(grade = as.ordered(grade)) %>% - tbl_summary(by = grade) %>% - as.data.frame() - ) -}) - -test_that("tbl_summary- works with grouped data (it ungroups it first)", { - expect_snapshot( - trial %>% dplyr::group_by(response) %>% - dplyr::select(response, death, trt) %>% - tbl_summary(by = trt) %>% - as.data.frame() - ) -}) - -test_that("tbl_summary-works with ordered factors", { - expect_snapshot( - trial %>% - select(response, trt) %>% - dplyr::mutate_at( - vars(response, trt), - ~ factor(., ordered = TRUE) - ) %>% - tbl_summary(by = trt) %>% - as.data.frame() - ) -}) - - -test_that("tbl_summary-complex environments check", { - no_fun <- function() { - grade_level <- "I" - trial %>% - dplyr::select(grade) %>% - tbl_summary( - label = grade ~ paste("Grade", grade_level) - ) - } - - expect_error(tbl_env <- no_fun(), NA) - expect_equal( - tbl_env$meta_data$var_label[tbl_env$meta_data$variable == "grade"], - "Grade I" - ) - - no_fun2 <- function() { - label_var <- "grade" - trial %>% - tbl_summary( - label = all_of(label_var) ~ "Grade, oof", - ) - } - expect_error(tbl_env2 <- no_fun2(), NA) - expect_equal( - tbl_env2$meta_data$var_label[tbl_env2$meta_data$variable == "grade"], - "Grade, oof" - ) -}) - - -test_that("tbl_summary creates output without error/warning for continuous2 (no by var)", { - expect_snapshot( - purrr::map( - list(mtcars, iris), - ~ tbl_summary(.x, - type = all_continuous() ~ "continuous2", - sort = list(all_categorical() ~ "frequency") - ) %>% - as_tibble() - ) - ) - expect_warning( - purrr::map(list(mtcars, iris), ~ tbl_summary(.x)), - NA - ) -}) - - -test_that("tbl_summary creates output without error/warning for continuous2 (with by var)", { - expect_snapshot( - tbl_summary(mtcars, by = am, type = all_continuous() ~ "continuous2") %>% - as.data.frame() - ) - expect_warning( - tbl_summary(mtcars, by = am, type = all_continuous() ~ "continuous2"), - NA - ) - - expect_error( - tbl_summary(mtcars, by = am, statistic = all_continuous() ~ c("{median}", "{mean}")), - "*" - ) -}) - - -test_that("tbl_summary(digits=) tests with fn inputs", { - expect_error( - tbl_digits <- - trial %>% - select(age, marker, grade, response) %>% - tbl_summary( - missing = "no", - statistic = list( - age ~ "{mean}", - marker ~ "{mean} {sd} {N_obs} {p_nonmiss}%", - response ~ "{n} {N} {p}% {N_obs} {p_nonmiss}%" - ), - digits = list( - age ~ function(x) format(x, digits = 2, scientific = TRUE), - marker ~ list(style_number, 2, 1, function(x) style_percent(x, digits = 2)), - grade ~ c(1, 1), - response ~ list(style_number, 1, 2, 1, function(x) style_percent(x, digits = 4)) - ) - ), - NA - ) - expect_snapshot(tbl_digits %>% as.data.frame()) - - # checking the display is correct - expect_equal( - tbl_digits$table_body %>% filter(variable == "age") %>% pull(stat_0), - with(trial, glue::glue("{format(mean(age, na.rm = TRUE), digits = 2, scientific = TRUE)}")) %>% as.character(), - ignore_attr = TRUE - ) - - expect_equal( - tbl_digits$table_body %>% filter(variable == "marker") %>% pull(stat_0), - with(trial, glue::glue( - "{round(mean(marker, na.rm = TRUE))} ", - "{round(sd(marker, na.rm = TRUE), 2)} ", - "{sprintf(length(marker), fmt = '%#.1f')} ", - "{sprintf(sum(!is.na(marker)) / length(marker) * 100, fmt = '%#.2f')}%" - )) %>% as.character(), - ignore_attr = TRUE - ) - - expect_equal( - tbl_digits$table_body %>% filter(variable == "grade") %>% pull(stat_0) %>% purrr::keep(~ !is.na(.)), - c("68.0 (34.0%)", "68.0 (34.0%)", "64.0 (32.0%)"), - ignore_attr = TRUE - ) - - expect_equal( - tbl_digits$table_body %>% filter(variable == "response") %>% pull(stat_0) %>% purrr::keep(~ !is.na(.)), - "61 193.0 31.61% 200.0 96.5000%", - ignore_attr = TRUE - ) -}) - - -test_that("tbl_summary() continuous vars with cat summary vars only", { - expect_error( - tbl1 <- trial %>% select(age) %>% tbl_summary(statistic = age ~ "{N_obs}"), - NA - ) - expect_snapshot(tbl1 %>% as.data.frame()) - expect_equal(tbl1$table_body$stat_0, c("200", "11")) - - expect_error( - tbl2 <- trial %>% select(age, trt) %>% tbl_summary(by = trt, statistic = age ~ "{N_obs}"), - NA - ) - expect_snapshot(tbl2 %>% as.data.frame()) - expect_equal(tbl2$meta_data$df_stats %>% pluck(1, "N_obs"), c(98, 102), - ignore_attr = TRUE - ) -}) - -test_that("tbl_summary() works with date and date/time", { - df_date <- - data.frame( - dates = as.Date("2021-02-20") + 1:10, - times = as.POSIXct("2021-02-20 20:31:33 EST") + 1:10, - group = 1:10 %% 2 - ) - - expect_error( - tbl1 <- df_date %>% tbl_summary(), - NA - ) - expect_snapshot(tbl1 %>% as.data.frame()) - - expect_equal( - tbl1 %>% as_tibble() %>% select(last_col()) %>% dplyr::pull(), - c("2021-02-21 to 2021-03-02", "2021-02-20 20:31:34 to 2021-02-20 20:31:43", "5 (50%)") - ) - - month_year <- function(x) format(x, "%B %Y") - expect_error( - tbl1 <- df_date %>% select(-group) %>% tbl_summary(type = everything() ~ "continuous", digits = everything() ~ month_year), - NA - ) - expect_snapshot(tbl1 %>% as.data.frame()) - - expect_equal( - tbl1 %>% as_tibble() %>% select(last_col()) %>% dplyr::pull(), - c("February 2021 to March 2021", "February 2021 to February 2021") - ) - - expect_error( - tbl1 <- df_date %>% tbl_summary(by = group, type = everything() ~ "continuous", digits = everything() ~ month_year), - NA - ) - expect_snapshot(tbl1 %>% as.data.frame()) - - expect_error( - tbl2 <- df_date %>% tbl_summary(by = group), - NA - ) - expect_snapshot(tbl2 %>% as.data.frame()) -}) - - -test_that("unobserved levels can be dichotomously summarized", { - expect_equal( - trial %>% - dplyr::transmute(trt = forcats::fct_expand(trt, "Drug C")) %>% - tbl_summary(value = trt ~ "Drug C") %>% - as_tibble(col_labels = FALSE) %>% - dplyr::pull(stat_0), - "0 (0%)" - ) -}) - -test_that("Hmisc labelled data don't error", { - skip_if_not(broom.helpers::.assert_package("Hmisc", pkg_search = "gtsummary", boolean = TRUE)) - hmisc_data <- - structure( - list( - cd4_count = c( - 30, 97, 210, NA, 358, 242, 126, - 792, 6, 145, 22, 150, 43, 23, 39, 953, 357, 427, 367, 239, 72, - 61, 61, 438, 392, 1092, 245, 326, 42, 135, 199, 158, 17, NA, - 287, 187, 252, 477, 157, NA, NA, 362, NA, 183, 885, 109, 321, - 286, 142, 797 - ), - unsuccessful = c( - 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, - 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, - 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0 - ) - ), - row.names = c(NA, 50L), - class = "data.frame" - ) - - # Add label to CD4 count, using Hmisc package - Hmisc::label(hmisc_data$cd4_count) <- "CD4 count" - - expect_equal( - hmisc_data %>% - tbl_summary(by = unsuccessful, missing = "no") %>% - as_tibble(col_labels = FALSE) %>% - dplyr::pull("stat_1"), - "210 (135, 358)" - ) -}) - -test_that("no error when by variable omitted from include", { - expect_snapshot( - trial %>% - tbl_summary(by = trt, include = age) %>% - as.data.frame() - ) -}) - -test_that("all column names are accepted", { - df <- data.frame(variable = c(rep("A", 5), rep("B", 5)), value = 1:10) - - expect_snapshot( - tbl_summary(df, by = "variable") %>% - as.data.frame() - ) - expect_snapshot(tbl_summary(df) %>% as.data.frame()) - expect_snapshot( - tbl_summary(df %>% dplyr::rename(by = variable)) %>% as.data.frame() - ) - expect_snapshot( - tbl_summary(df %>% dplyr::rename(by = variable), by = "by") %>% as.data.frame() - ) -}) - -test_that("no error with factor variable with all NA and no specifed levels", { - expect_error( - tbl <- - trial %>% - dplyr::mutate( - has_banana = factor(NA) # We don't know which patients have a banana - ) %>% - tbl_summary(by = trt, include = has_banana) %>% - as_tibble(col_labels = FALSE), - NA - ) - expect_snapshot(tbl) - expect_equal( - tbl$stat_1, - c("0 (NA%)", "98") - ) -}) - - -test_that("modify_*() family works", { - tbl0 <- - trial %>% - select(trt, age, grade) %>% - tbl_summary(by = trt) - tbl1 <- - tbl0 %>% - add_difference() %>% - add_n() %>% - add_overall() %>% - modify_spanning_header(everything() ~ "N = {N}") %>% - modify_header(all_stat_cols(FALSE) ~ "{level} N = {n}", - stat_0 = "Overall N = {N}" - ) %>% - modify_footnote(label = "N = {N}") %>% - modify_caption("N = {N}") - tbl2 <- - tbl0 %>% - add_overall() %>% - add_p() %>% - add_n() %>% - modify_spanning_header(everything() ~ "N = {N}") %>% - modify_header(all_stat_cols(FALSE) ~ "{level} N = {n}", - stat_0 = "Overall N = {N}" - ) %>% - modify_footnote(label = "N = {N}") %>% - modify_caption("N = {N}") - - expect_false( - any(is.na(tbl1$table_styling$header$modify_stat_N)) - ) - expect_false( - any(is.na(tbl2$table_styling$header$modify_stat_N)) - ) - - expect_true( - all(tbl1$table_styling$header$spanning_header == "N = 200") - ) - expect_true( - all(tbl2$table_styling$header$spanning_header == "N = 200") - ) - - expect_equal( - tbl1$table_styling$header %>% - filter(startsWith(column, "stat_")) %>% - pull(label), - c("Overall N = 200", "Drug A N = 98", "Drug B N = 102") - ) - expect_equal( - tbl2$table_styling$header %>% - filter(startsWith(column, "stat_")) %>% - pull(label), - c("Overall N = 200", "Drug A N = 98", "Drug B N = 102") - ) - - expect_equal( - tbl1$table_styling$caption, - "N = 200", - ignore_attr = TRUE - ) - expect_equal( - tbl2$table_styling$caption, - "N = 200", - ignore_attr = TRUE - ) - - expect_equal( - tbl_merge(list(tbl0, tbl0))$table_styling$header %>% - filter(startsWith(column, "stat_")) %>% - dplyr::pull(modify_stat_n), - c(98, 102, 98, 102) - ) -}) - - - - -test_that("no error when data frame contains named vector", { - df <- - structure( - list( - swallowing = structure(c(NA, 53, 100, 0, 100), - names = c("", "", "", "", "") - ), - salivation = structure(c(NA, 100, 46, 62, 100), - names = c("", "", "", "", "") - ) - ), - row.names = c(NA, -5L), class = c("tbl_df", "tbl", "data.frame") - ) - - expect_snapshot( - tbl_summary(df, type = list(everything() ~ "continuous")) %>% as.data.frame() - ) +test_that("multiplication works", { + expect_equal(2 * 2, 4) }) From 1cd9a39c7e4507cddfba0f3766d8dc434c09fc83 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 26 Nov 2023 16:22:09 -0800 Subject: [PATCH 02/74] Bridge updates (#1570) * progress * Update NEWS.md * Update NEWS.md --- NAMESPACE | 9 +- NEWS.md | 10 ++ R/{bridge_tbl_summary.R => bridge_summary.R} | 166 ++++++++++++++---- R/construct_table_body.R | 8 +- R/tbl_summary.R | 33 +++- ...ridge_tbl_summary.Rd => bridge_summary.Rd} | 46 ++--- man/modify_column_hide.Rd | 9 - 7 files changed, 198 insertions(+), 83 deletions(-) rename R/{bridge_tbl_summary.R => bridge_summary.R} (66%) rename man/{bridge_tbl_summary.Rd => bridge_summary.Rd} (54%) diff --git a/NAMESPACE b/NAMESPACE index 24bc3b2611..e352cf4a3e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,10 +18,6 @@ export(all_tests) export(any_of) export(as_gt) export(as_tibble) -export(bridge_summary_categorical) -export(bridge_summary_continuous) -export(bridge_summary_continuous2) -export(bridge_summary_dichotomous) export(construct_gtsummary) export(contains) export(ends_with) @@ -34,6 +30,11 @@ export(modify_table_styling) export(mutate) export(num_range) export(one_of) +export(pier_summary_categorical) +export(pier_summary_continuous) +export(pier_summary_continuous2) +export(pier_summary_dichotomous) +export(pier_summary_missing_row) export(select) export(starts_with) export(tbl_summary) diff --git a/NEWS.md b/NEWS.md index 18b742ef8b..bed47da566 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,15 @@ # gtsummary (development version) +### Overview of Changes in v2.0 + +#### User-facing Updates + +* The counts in the header of `tbl_summary(by)` tables now appear on a new line. + +#### Internal Updates + +* Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. + ### Bug Fixes * Fix in `add_difference()` for paired t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) diff --git a/R/bridge_tbl_summary.R b/R/bridge_summary.R similarity index 66% rename from R/bridge_tbl_summary.R rename to R/bridge_summary.R index c0809661c8..acb8d4cbd7 100644 --- a/R/bridge_tbl_summary.R +++ b/R/bridge_summary.R @@ -1,6 +1,11 @@ #' Summary Table Bridges #' -#' Bridge functions for converting `tbl_summary()` cards to table bodies. +#' @description +#' Bridge function for converting `tbl_summary()` (and similar) cards to table bodies. +#' All bridge functions begin with prefix `brdg_*()`. +#' +#' This file also contains helper functions for constructing the bridge, +#' referred to as the piers (supports for a bridge) and begin with `pier_*()`. #' #' @param x gtsummary object of class `"tbl_summary"` #' @param variables character list of variables @@ -9,7 +14,7 @@ #' @inheritParams tbl_summary #' #' @return data frame -#' @name bridge_tbl_summary +#' @name bridge_summary #' #' @examples #' tbl <- @@ -31,7 +36,7 @@ #' ) #' ) #' -#' bridge_summary_dichotomous( +#' pier_summary_dichotomous( #' x = tbl, #' variables = "am", #' value = list(am = 1), @@ -40,7 +45,7 @@ #' missing_stat = "{N_miss}" #' ) #' -#' bridge_summary_categorical( +#' pier_summary_categorical( #' x = tbl, #' variables = "cyl", #' missing = "ifany", @@ -48,7 +53,7 @@ #' missing_stat = "{N_miss}" #' ) #' -#' bridge_summary_continuous2( +#' pier_summary_continuous2( #' x = tbl, #' variables = "hp", #' missing = "ifany", @@ -56,7 +61,7 @@ #' missing_stat = "{N_miss}" #' ) #' -#' bridge_summary_continuous( +#' pier_summary_continuous( #' x = tbl, #' variables = "mpg", #' missing = "ifany", @@ -65,9 +70,76 @@ #' ) NULL -#' @rdname bridge_tbl_summary +brdg_summary <- function(x, calling_function = "tbl_summary") { + # add gts info to the cards table -------------------------------------------- + # add the function call column + x$cards <- + x$cards |> + dplyr::mutate( + gts_function = + ifelse( + .data$variable %in% c(x$inputs$tbl_summary$by, x$inputs$tbl_summary$include) & + .data$context %in% c("continuous", "categorical"), + .env$calling_function, + NA_character_ + ) + ) + + # adding the name of the column the stats will populate + if (is_empty(x$inputs$by)) { + x$cards$gts_column <- + ifelse(x$cards$context %in% c("continuous", "categorical"), "stat_0", NA_character_) + } + else { + x$cards <- + x$cards |> + dplyr::mutate( + .by = cards::all_ard_groups(), + gts_column = + ifelse( + .data$context %in% c("continuous", "categorical") & + !.data$variable %in% .env$x$inputs$tbl_summary$by, + paste0("stat_", dplyr::cur_group_id() - 1L), + NA_character_ + ) + ) + } + + + # build the table body pieces with bridge functions and stack them ----------- + x$table_body <- + dplyr::left_join( + dplyr::tibble(variable = x$inputs$include), + dplyr::bind_rows( + pier_summary_continuous( + x, + variables = .get_variables_by_type(x$inputs$type, type = "continuous") + ), + pier_summary_continuous2( + x, + variables = .get_variables_by_type(x$inputs$type, type = "continuous2") + ), + pier_summary_categorical( + x, + variables = .get_variables_by_type(x$inputs$type, type = "categorical") + ), + pier_summary_dichotomous( + x, + variables = .get_variables_by_type(x$inputs$type, type = "dichotomous") + ), + pier_summary_missing_row(x) + ), + by = "variable" + ) + + # construct default table_styling -------------------------------------------- + x <- construct_initial_table_styling(x) + +} + +#' @rdname bridge_summary #' @export -bridge_summary_dichotomous <- function(x, variables, value, missing, missing_text, missing_stat) { +pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { # subsetting cards object on dichotomous summaries --------------------------- x$cards <- x$cards |> @@ -82,12 +154,12 @@ bridge_summary_dichotomous <- function(x, variables, value, missing, missing_tex context = ifelse(.data$context %in% "categorical", "continuous", .data$context) ) - bridge_summary_continuous(x = x, variables = variables) + pier_summary_continuous(x = x, variables = variables) } -#' @rdname bridge_tbl_summary +#' @rdname bridge_summary #' @export -bridge_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { # subsetting cards object on categorical summaries ---------------------------- card <- x$cards |> @@ -98,7 +170,7 @@ bridge_summary_categorical <- function(x, variables, missing, missing_text, miss df_glued <- # construct stat columns with glue by grouping variables and primary summary variable card |> - dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(df_variable_stats, df_groups_and_variable) { lst_variable_stats <- @@ -110,7 +182,7 @@ bridge_summary_categorical <- function(x, variables, missing, missing_text, miss ) str_statistic_pre_glue <- - x$calls$tbl_summary$statistic[[df_groups_and_variable$variable[1]]] + x$inputs$statistic[[df_groups_and_variable$variable[1]]] dplyr::mutate( .data = df_groups_and_variable, @@ -161,7 +233,6 @@ bridge_summary_categorical <- function(x, variables, missing, missing_text, miss ) |> dplyr::mutate( .by = "variable", - statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), row_type = "level", var_label = unlist(.data$var_label), .after = 0L @@ -171,9 +242,8 @@ bridge_summary_categorical <- function(x, variables, missing, missing_text, miss tidyr::unnest(cols = "stat") |> tidyr::pivot_wider( id_cols = c("row_type", "var_label", "variable", "label"), - names_from = "statistic_id", - values_from = "stat", - names_glue = "stat_{statistic_id}" + names_from = "gts_column", + values_from = "stat" ) # add header rows to results ------------------------------------------------- @@ -198,9 +268,9 @@ bridge_summary_categorical <- function(x, variables, missing, missing_text, miss df_results } -#' @rdname bridge_tbl_summary +#' @rdname bridge_summary #' @export -bridge_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { # subsetting cards object on continuous2 summaries ---------------------------- card <- x$cards |> @@ -211,14 +281,14 @@ bridge_summary_continuous2 <- function(x, variables, missing, missing_text, miss df_glued <- # construct stat columns with glue by grouping variables and primary summary variable card |> - dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_by(across(c("gts_column" ,cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(.x, .y) { dplyr::mutate( .data = .y, stat = map( - x$calls$tbl_summary$statistic[[.y$variable[1]]], + x$inputs$statistic[[.y$variable[1]]], function(str_to_glue) { stat = glue::glue( @@ -226,13 +296,12 @@ bridge_summary_continuous2 <- function(x, variables, missing, missing_text, miss .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) ) |> as.character() - } ) |> list(), label = map( - x$calls$tbl_summary$statistic[[.y$variable[1]]], + x$inputs$statistic[[.y$variable[1]]], function(str_to_glue) { label = glue::glue( @@ -262,7 +331,6 @@ bridge_summary_continuous2 <- function(x, variables, missing, missing_text, miss ) |> dplyr::mutate( .by = "variable", - statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), row_type = "level", var_label = unlist(.data$var_label), .after = 0L @@ -272,9 +340,8 @@ bridge_summary_continuous2 <- function(x, variables, missing, missing_text, miss tidyr::unnest(cols = c("stat", "label")) |> tidyr::pivot_wider( id_cols = c("row_type", "var_label", "variable", "label"), - names_from = "statistic_id", - values_from = "stat", - names_glue = "stat_{statistic_id}" + names_from = "gts_column", + values_from = "stat" ) # add header rows to results ------------------------------------------------- @@ -299,9 +366,9 @@ bridge_summary_continuous2 <- function(x, variables, missing, missing_text, miss df_results } -#' @rdname bridge_tbl_summary +#' @rdname bridge_summary #' @export -bridge_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { # subsetting cards object on continuous summaries ---------------------------- card <- x$cards |> @@ -312,13 +379,13 @@ bridge_summary_continuous <- function(x, variables, missing, missing_text, missi df_glued <- # construct stat columns with glue by grouping variables and primary summary variable card |> - dplyr::group_by(across(c(cards::all_ard_groups(), "variable"))) |> + dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( ~dplyr::mutate( .data = .y, stat = glue::glue( - x$calls$tbl_summary$statistic[[.data$variable[1]]], + x$inputs$statistic[[.data$variable[1]]], .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) ) |> as.character() @@ -340,7 +407,6 @@ bridge_summary_continuous <- function(x, variables, missing, missing_text, missi ) |> dplyr::mutate( .by = "variable", - statistic_id = if (dplyr::n() == 1L) 0L else dplyr::row_number(), row_type = "header", var_label = unlist(.data$var_label), label = .data$var_label, @@ -348,10 +414,40 @@ bridge_summary_continuous <- function(x, variables, missing, missing_text, missi ) |> tidyr::pivot_wider( id_cols = c("row_type", "var_label", "variable", "label"), - names_from = "statistic_id", - values_from = "stat", - names_glue = "stat_{statistic_id}" + names_from = "gts_column", + values_from = "stat" ) df_results } + +#' @rdname bridge_summary +#' @export +pier_summary_missing_row <- function(x, variables = x$inputs$include) { + # keeping variables to report missing obs for (or returning empty df if none) + if (x$inputs$missing == "no") return(dplyr::tibble()) + if (x$inputs$missing == "ifany") { + variables <- + x$cards |> + dplyr::filter(.data$stat_name == "N_miss", .data$variable %in% .env$variables) |> + dplyr::filter(.data$statistic > 0L) |> + dplyr::pull("variable") |> + unique() + } + if (is_empty(variables)) return(dplyr::tibble()) + + # slightly modifying the `x` object for missing value calculations + x$inputs$statistic <- rep_named(variables, list(x$inputs$missing_stat)) + x$cards <- + x$cards |> + dplyr::mutate( + context = ifelse(.data$context %in% "categorical", "continuous", .data$context) + ) + + + pier_summary_continuous(x, variables = variables) |> + dplyr::mutate( + row_type = "missing", + label = x$inputs$missing_text + ) +} diff --git a/R/construct_table_body.R b/R/construct_table_body.R index 3c696c333f..7e4e670d9f 100644 --- a/R/construct_table_body.R +++ b/R/construct_table_body.R @@ -31,19 +31,19 @@ construct_gtsummary.tbl_summary <- function(x) { dplyr::left_join( dplyr::tibble(variable = x$calls$tbl_summary$include), dplyr::bind_rows( - bridge_summary_continuous( + pier_summary_continuous( x, variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous") ), - bridge_summary_continuous2( + pier_summary_continuous2( x, variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous2") ), - bridge_summary_categorical( + pier_summary_categorical( x, variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "categorical") ), - bridge_summary_dichotomous( + pier_summary_dichotomous( x, variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "dichotomous"), value = x$calls$tbl_summary$value diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 3cf8727f23..a0b6c76c77 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -47,7 +47,7 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, cards::process_selectors(data, by = {{by}}, include = {{include}}) include <- setdiff(include, by) # remove by variable from list vars included missing <- rlang::arg_match(arg = missing) - percent <- rlang::arg_match0(arg = percent) + percent <- rlang::arg_match(arg = percent) cards::process_formula_selectors( data = data[include], @@ -59,6 +59,7 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) + call <- match.call() # construct cards ------------------------------------------------------------ cards <- @@ -80,18 +81,34 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, ) ) - # return object - list( - cards = cards, - calls = list(tbl_summary = tbl_summary_inputs) - ) |> - structure(class = c("tbl_summary", "gtsummary")) |> - construct_gtsummary() |> + # construct initial tbl_summary object --------------------------------------- + x <- + list( + cards = cards, + inputs = tbl_summary_inputs, + call_list = list(tbl_summary = call) + ) |> + brdg_summary() |> + structure(class = c("tbl_summary", "gtsummary")) + + # adding styling ------------------------------------------------------------- + x <- modify_table_styling( + x, columns = "label", + label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), text_format = "indent" ) + + x <- + modify_header( + x, + all_stat_cols() ~ ifelse(is_empty(by), "**N = {N}**", "**{level}** \nN = {n}") + ) + + # return object + x } .get_variables_by_type <- function(x, type) { diff --git a/man/bridge_tbl_summary.Rd b/man/bridge_summary.Rd similarity index 54% rename from man/bridge_tbl_summary.Rd rename to man/bridge_summary.Rd index 5f13688890..0fe956ec79 100644 --- a/man/bridge_tbl_summary.Rd +++ b/man/bridge_summary.Rd @@ -1,27 +1,23 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bridge_tbl_summary.R -\name{bridge_tbl_summary} -\alias{bridge_tbl_summary} -\alias{bridge_summary_dichotomous} -\alias{bridge_summary_categorical} -\alias{bridge_summary_continuous2} -\alias{bridge_summary_continuous} +% Please edit documentation in R/bridge_summary.R +\name{bridge_summary} +\alias{bridge_summary} +\alias{pier_summary_dichotomous} +\alias{pier_summary_categorical} +\alias{pier_summary_continuous2} +\alias{pier_summary_continuous} +\alias{pier_summary_missing_row} \title{Summary Table Bridges} \usage{ -bridge_summary_dichotomous( - x, - variables, - value, - missing, - missing_text, - missing_stat -) +pier_summary_dichotomous(x, variables, value = x$inputs$value) + +pier_summary_categorical(x, variables, missing, missing_text, missing_stat) -bridge_summary_categorical(x, variables, missing, missing_text, missing_stat) +pier_summary_continuous2(x, variables, missing, missing_text, missing_stat) -bridge_summary_continuous2(x, variables, missing, missing_text, missing_stat) +pier_summary_continuous(x, variables, missing, missing_text, missing_stat) -bridge_summary_continuous(x, variables, missing, missing_text, missing_stat) +pier_summary_missing_row(x, variables = x$inputs$include) } \arguments{ \item{x}{gtsummary object of class \code{"tbl_summary"}} @@ -41,7 +37,11 @@ variable names.} data frame } \description{ -Bridge functions for converting \code{tbl_summary()} cards to table bodies. +Bridge function for converting \code{tbl_summary()} (and similar) cards to table bodies. +All bridge functions begin with prefix \verb{brdg_*()}. + +This file also contains helper functions for constructing the bridge, +referred to as the piers (supports for a bridge) and begin with \verb{pier_*()}. } \examples{ tbl <- @@ -63,7 +63,7 @@ tbl <- ) ) -bridge_summary_dichotomous( +pier_summary_dichotomous( x = tbl, variables = "am", value = list(am = 1), @@ -72,7 +72,7 @@ bridge_summary_dichotomous( missing_stat = "{N_miss}" ) -bridge_summary_categorical( +pier_summary_categorical( x = tbl, variables = "cyl", missing = "ifany", @@ -80,7 +80,7 @@ bridge_summary_categorical( missing_stat = "{N_miss}" ) -bridge_summary_continuous2( +pier_summary_continuous2( x = tbl, variables = "hp", missing = "ifany", @@ -88,7 +88,7 @@ bridge_summary_continuous2( missing_stat = "{N_miss}" ) -bridge_summary_continuous( +pier_summary_continuous( x = tbl, variables = "mpg", missing = "ifany", diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 04014a40b4..84cfb9ee98 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -18,15 +18,6 @@ modify_column_unhide(x, columns) \lifecycle{maturing} Use these functions to hide or unhide columns in a gtsummary table. } -\section{Example Output}{ - -\if{html}{Example 1} - -\if{html}{\out{ -`r man_create_image_tag(file = "modify_column_hide_ex1.png", width = "45")` -}} -} - \examples{ \donttest{ # Example 1 ---------------------------------- From 08491571612319d323d1081aba2f919f6dfebba9 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 27 Nov 2023 16:37:45 -0800 Subject: [PATCH 03/74] small updates --- DESCRIPTION | 4 ++ NAMESPACE | 3 - NEWS.md | 4 ++ R/as_gt.R | 28 +++----- R/construct_table_body.R | 68 ------------------ R/data.R | 18 +++++ R/modify_column_hide.R | 4 +- R/modify_header.R | 2 +- R/modify_table_styling.R | 29 ++++---- R/print.R | 36 ++++------ R/standalone-checks.R | 24 +++++++ R/syntax.R | 77 +++++++++++++++++++++ R/utils-as.R | 15 ++-- R/utils-misc.R | 137 +------------------------------------ data-raw/trial.R | 43 ++++++++++++ data/trial.rda | Bin 0 -> 2631 bytes man/as_gt.Rd | 11 +-- man/construct_gtsummary.Rd | 26 ------- man/print_gtsummary.Rd | 6 +- man/syntax.Rd | 73 ++++++++++++++++++++ man/trial.Rd | 28 ++++++++ 21 files changed, 326 insertions(+), 310 deletions(-) delete mode 100644 R/construct_table_body.R create mode 100644 R/data.R create mode 100644 R/standalone-checks.R create mode 100644 R/syntax.R create mode 100644 data-raw/trial.R create mode 100644 data/trial.rda delete mode 100644 man/construct_gtsummary.Rd create mode 100644 man/syntax.Rd create mode 100644 man/trial.Rd diff --git a/DESCRIPTION b/DESCRIPTION index cfbe36765a..4bc7dbc139 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,8 +48,10 @@ Imports: cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), + gt (>= 0.10.0), lifecycle (>= 1.0.3), rlang (>= 1.1.1), + tibble (>= 3.2.1), tidyr (>= 1.3.0) Suggests: knitr, @@ -67,3 +69,5 @@ Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 +Depends: + R (>= 2.10) diff --git a/NAMESPACE b/NAMESPACE index e352cf4a3e..fbebb15a52 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(construct_gtsummary,default) -S3method(construct_gtsummary,tbl_summary) S3method(print,gtsummary) export("%>%") export(.table_styling_expr_to_row_number) @@ -18,7 +16,6 @@ export(all_tests) export(any_of) export(as_gt) export(as_tibble) -export(construct_gtsummary) export(contains) export(ends_with) export(everything) diff --git a/NEWS.md b/NEWS.md index bed47da566..f79f47829a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -14,6 +14,10 @@ * Fix in `add_difference()` for paired t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) +### Deprecations + +* Global options have been deprecated in gtsummary since v1.3.1 (3.5 years ago). They have now been fully removed from the package. + # gtsummary 1.7.2 * Removed messaging about the former auto-removal of the `tbl_summary(group)` variable from the table: a change that occurred 3+ years ago in gtsummary v1.3.1 diff --git a/R/as_gt.R b/R/as_gt.R index ef7ff514a9..4c15b82bda 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -6,21 +6,14 @@ #' A user can use this function if they wish to add customized formatting #' available via the [gt package](https://gt.rstudio.com/index.html). #' -#' @description Review the -#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#advanced}{tbl_summary vignette} -#' or -#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html#advanced}{tbl_regression vignette} -#' for detailed examples in the 'Advanced Customization' section. -#' -#' @param x Object created by a function from the gtsummary package -#' (e.g. [tbl_summary] or [tbl_regression]) +#' @param x An object of class `"gtsummary" #' @param include Commands to include in output. Input may be a vector of #' quoted or unquoted names. tidyselect and gtsummary select helper #' functions are also accepted. #' Default is `everything()`. #' @param return_calls Logical. Default is `FALSE`. If `TRUE`, the calls are returned #' as a list of expressions. -#' @param ... Arguments passed on to [gt::gt] +#' @param ... Arguments passed on to `gt::gt(...)` #' @return A `gt_tbl` object #' @family gtsummary output types #' @author Daniel D. Sjoberg @@ -32,7 +25,7 @@ #' tbl_summary(by = trt) %>% #' as_gt() as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { - .assert_class(x, "gtsummary") + assert_class(x, "gtsummary") # running pre-conversion function, if present -------------------------------- # x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) @@ -50,7 +43,7 @@ as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { # adding user-specified calls ------------------------------------------------ insert_expr_after <- get_theme_element("as_gt-lst:addl_cmds") gt_calls <- - purrr::reduce( + reduce( .x = seq_along(insert_expr_after), .f = function(x, y) { add_expr_after( @@ -80,9 +73,7 @@ as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { } # taking each gt function call, concatenating them with %>% separating them - gt_calls[include] %>% - c(parse_expr(.get_deprecated_option("gtsummary.as_gt.addl_cmds", default = "NULL"))) %>% - .eval_list_of_exprs() + .eval_list_of_exprs(gt_calls[include]) } # creating gt calls from table_styling ----------------------------------------- @@ -225,7 +216,8 @@ table_styling_to_gt_calls <- function(x, ...) { if (nrow(x$table_styling$footnote) == 0 && nrow(x$table_styling$footnote_abbrev) == 0) { gt_calls[["tab_footnote"]] <- list() - } else { + } + else { df_footnotes <- dplyr::bind_rows( x$table_styling$footnote, @@ -234,8 +226,8 @@ table_styling_to_gt_calls <- function(x, ...) { tidyr::nest(data = c("column", "row_numbers")) %>% dplyr::rowwise() %>% dplyr::mutate( - columns = .data$data %>% pull("column") %>% unique() %>% list(), - rows = .data$data %>% pull("row_numbers") %>% unique() %>% list() + columns = .data$data %>% dplyr::pull("column") %>% unique() %>% list(), + rows = .data$data %>% dplyr::pull("row_numbers") %>% unique() %>% list() ) %>% dplyr::ungroup() df_footnotes$footnote_exp <- @@ -284,7 +276,7 @@ table_styling_to_gt_calls <- function(x, ...) { .data$interpret_spanning_header, .data$spanning_header, ~ call2(parse_expr(.x), .y) ), - cols = map(.data$cols, ~ pull(.x)) + cols = map(.data$cols, ~ dplyr::pull(.x)) ) %>% dplyr::select("spanning_header", "cols") diff --git a/R/construct_table_body.R b/R/construct_table_body.R deleted file mode 100644 index 7e4e670d9f..0000000000 --- a/R/construct_table_body.R +++ /dev/null @@ -1,68 +0,0 @@ -#' Construct Table Body -#' -#' @param x gtsummary object -#' -#' @return gtsummary object -#' @name construct_gtsummary -#' -#' @examples -#' # TODO: Add example -NULL - -#' @rdname construct_gtsummary -#' @export -construct_gtsummary <- function(x) { - if (!inherits(x, "gtsummary")) - cli::cli_abort("Object must be class {.cls gtsummary}.") - UseMethod("construct_gtsummary") -} - -#' @rdname construct_gtsummary -#' @export -construct_gtsummary.default <- function(x) { - cli::cli_abort("There is no {.fun construct_table_body} method for object of class {.cls {class(x)}}.") -} - -#' @rdname construct_gtsummary -#' @export -construct_gtsummary.tbl_summary <- function(x) { - # build the table body pieces with bridge functions and stack them ----------- - x$table_body <- - dplyr::left_join( - dplyr::tibble(variable = x$calls$tbl_summary$include), - dplyr::bind_rows( - pier_summary_continuous( - x, - variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous") - ), - pier_summary_continuous2( - x, - variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "continuous2") - ), - pier_summary_categorical( - x, - variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "categorical") - ), - pier_summary_dichotomous( - x, - variables = .get_variables_by_type(x$calls$tbl_summary$type, type = "dichotomous"), - value = x$calls$tbl_summary$value - ) - ), - by = "variable" - ) - - # construct default table_styling -------------------------------------------- - x <- construct_initial_table_styling(x) - - # update table_styling ------------------------------------------------------- - x <- x |> - modify_header( - label = "**Characteristic**", - all_stat_cols() ~ - .ifelse1(is.null(x$calls$tbl_summary$by), "**N = {N}**", "**{level}** \nN = {N}") - ) - - # return object with table_body included ------------------------------------- - x -} diff --git a/R/data.R b/R/data.R new file mode 100644 index 0000000000..e4714f8bde --- /dev/null +++ b/R/data.R @@ -0,0 +1,18 @@ +#' Results from a simulated study of two chemotherapy agents +#' +#' A dataset containing the baseline characteristics of 200 patients +#' who received Drug A or Drug B. Dataset also contains the outcome of +#' tumor response to the treatment. +#' +#' @format A data frame with 200 rows--one row per patient +#' \describe{ +#' \item{trt}{Chemotherapy Treatment} +#' \item{age}{Age} +#' \item{marker}{Marker Level (ng/mL)} +#' \item{stage}{T Stage} +#' \item{grade}{Grade} +#' \item{response}{Tumor Response} +#' \item{death}{Patient Died} +#' \item{ttdeath}{Months to Death/Censor} +#' } +"trial" diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index bdf0e282bd..535ebfb916 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -23,7 +23,7 @@ NULL #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @export modify_column_hide <- function(x, columns) { - .assert_class(x, "gtsummary") + assert_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) x <- modify_table_styling( @@ -39,7 +39,7 @@ modify_column_hide <- function(x, columns) { #' @rdname modify_column_hide #' @export modify_column_unhide <- function(x, columns) { - .assert_class(x, "gtsummary") + assert_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) x <- modify_table_styling( diff --git a/R/modify_header.R b/R/modify_header.R index 9273e227d8..5128e787aa 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -10,7 +10,7 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), if (!is.null(stat_by)) { lifecycle::deprecate_stop( "1.3.6", "gtsummary::modify_header(stat_by=)", - details = glue("Use `all_stat_cols(FALSE) ~ {stat_by}` instead.") + details = glue::glue("Use `all_stat_cols(FALSE) ~ {stat_by}` instead.") ) } if (!is.null(update)) { diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 4326e269a9..ff0da28565 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -94,7 +94,7 @@ modify_table_styling <- function(x, cols_merge_pattern = NULL) { updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) # checking inputs ------------------------------------------------------------ - .assert_class(x, "gtsummary") + assert_class(x, "gtsummary") text_interpret <- match.arg(text_interpret) %>% { @@ -207,7 +207,7 @@ modify_table_styling <- function(x, if (!is.null(fmt_fun)) { if (rlang::is_function(fmt_fun)) fmt_fun <- list(fmt_fun) x$table_styling$fmt_fun <- - bind_rows( + dplyr::bind_rows( x$table_styling$fmt_fun, dplyr::tibble( column = columns, @@ -270,26 +270,21 @@ modify_table_styling <- function(x, # function to add merging columns instructions .modify_cols_merge <- function(x, column, rows, pattern) { rows <- enquo(rows) - all_columns <- - str_extract_all(pattern, "\\{.*?\\}") %>% - map(~ stringr::str_remove_all(.x, pattern = fixed("}"))) %>% - map(~ stringr::str_remove_all(.x, pattern = fixed("{"))) %>% - unlist() + all_columns <- .extract_glue_elements(pattern) - if (!is.na(pattern) && !all(all_columns %in% x$table_styling$header$column)) { - paste( - "All columns specified in `cols_merge_pattern=`", - "must be present in `x$table_body`" - ) %>% - abort() + if (!is_empty(pattern) && !all(all_columns %in% x$table_styling$header$column)) { + cli::cli_abort(c( + "All columns specified in {.arg cols_merge_pattern} argument must be present in {.code x$table_body}", + "i" = "The following columns are not present: {.val {setdiff(all_columns, x$table_styling$header$column)}}" + )) } - if (!is.na(pattern) && !identical(column, all_columns[1])) { + if (!is_empty(pattern) && !identical(column, all_columns[1])) { paste( - "A single column must be passed when using `cols_merge_pattern=`,", + "A single column must be passed when using {.arg cols_merge_pattern},", "and that column must be the first to appear in the pattern argument." ) %>% - abort() + cli::cli_abort() } x$table_styling$cols_merge <- @@ -298,7 +293,7 @@ modify_table_styling <- function(x, dplyr::filter(!.data$column %in% .env$column) %>% # append new merge instructions dplyr::bind_rows( - tibble( + dplyr::tibble( column = column, rows = list(rows), pattern = pattern diff --git a/R/print.R b/R/print.R index 196628eda0..38b21ac268 100644 --- a/R/print.R +++ b/R/print.R @@ -11,33 +11,23 @@ NULL #' @rdname print_gtsummary #' @export -print.gtsummary <- function(x, print_engine = "gt", ...) { +print.gtsummary <- function(x, + print_engine = c("gt", "flextable", "huxtable", "kable", "kable_extra", "tibble"), + ...) { check_dots_empty(error = function(e) inform(c(e$message, e$body))) - # # select print engine - # print_engine <- - # print_engine %||% - # .get_deprecated_option("gtsummary.print_engine") %||% - # # get_theme_element("pkgwide-str:print_engine") %||% - # "gt" # default printer is gt - # - # # checking engine - # accepted_print_engines <- - # c("gt", "kable", "kable_extra", "flextable", "huxtable", "tibble") - # if (!rlang::is_string(print_engine) || !print_engine %in% accepted_print_engines) { - # stop(glue( - # "Select a valid print engine. ", - # "Please select one of {quoted_list(accepted_print_engines)}" - # )) - # } + print_engine <- + if (missing(print_engine)) get_theme_element("pkgwide-str:print_engine") %||% print_engine else print_engine + print_engine <- arg_match(print_engine) # printing results switch(print_engine, - "gt" = as_gt(x), - "kable" = as_kable(x), - "flextable" = as_flex_table(x), - "kable_extra" = as_kable_extra(x), - "huxtable" = as_hux_table(x), - "tibble" = as_tibble(x) + "gt" = as_gt(x) + # , + # "kable" = as_kable(x), + # "flextable" = as_flex_table(x), + # "kable_extra" = as_kable_extra(x), + # "huxtable" = as_hux_table(x), + # "tibble" = as_tibble(x) ) %>% print() } diff --git a/R/standalone-checks.R b/R/standalone-checks.R new file mode 100644 index 0000000000..1b77eaaa98 --- /dev/null +++ b/R/standalone-checks.R @@ -0,0 +1,24 @@ +# --- +# repo: ddsjoberg/gtsummary +# file: standalone-assertions.R +# last-updated: +# license: https://unlicense.org +# dependencies: rlang, cli +# --- +# +# This file provides a minimal shim to provide checks or assertions, +# typically of function argument inputs. +# +# ## Changelog +# +# nocov start + +assert_class <- function(x, class, arg_name = rlang::caller_arg(x), env = rlang::caller_env()) { + if (!inherits(x, class)) { + cli::cli_abort( + c("Argument {.arg {arg_name}} must be class {.cls {class}}.", + "i" = "The class of {.arg {arg_name}} is {.cls {class(x)}}."), + call = env + ) + } +} diff --git a/R/syntax.R b/R/syntax.R new file mode 100644 index 0000000000..6cc3df5042 --- /dev/null +++ b/R/syntax.R @@ -0,0 +1,77 @@ +#' Syntax and Notation +#' +#' @name syntax +#' @keywords internal +#' @description +#' +#' # Selectors +#' +#' The gtsummary package also utilizes selectors: selectors from the tidyselect +#' package and custom selectors. Review their help files for details. +#' +#' - **tidy selectors** +#' +#' `everything()`, `all_of()`, `any_of()`, `starts_with()`, `ends_with()`, +#' `contains()`, `matches()`, `num_range()`, `last_col()` +#' +#' - **gtsummary selectors** +#' +#' `all_continuous()`, `all_categorical()`, `all_dichotomous()`, +#' `all_continuous2()`, `all_tests()`, `all_stat_cols()`, +#' `all_interaction()`, `all_intercepts()`, `all_contrasts()` +#' +#' # Formula and List Selectors +#' +#' Many arguments throughout the gtsummary package accept list and +#' formula notation, e.g. `tbl_summary(statistic=)`. Below enumerates a few +#' tips and shortcuts for using the list and formulas. +#' +#' 1. **List of Formulas** +#' +#' Typical usage includes a list of formulas, where the LHS is a variable +#' name or a selector. +#' +#' ```r +#' tbl_summary(statistic = list(age ~ "{mean}", all_categorical() ~ "{n}")) +#' ``` +#' +#' 1. **Named List** +#' +#' You may also pass a named list; however, the tidyselect and gtsummary selectors +#' are not supported with this syntax. +#' +#' ```r +#' tbl_summary(statistic = list(age = "{mean}", response = "{n}")) +#' ``` +#' +#' 1. **Hybrid Named List/List of Formulas** +#' +#' Pass a combination of formulas and named elements +#' +#' ```r +#' tbl_summary(statistic = list(age = "{mean}", all_categorical() ~ "{n}")) +#' ``` +#' 1. **Shortcuts** +#' +#' You can pass a single formula, which is equivalent to passing the formula +#' in a list. +#' +#' ```r +#' tbl_summary(statistic = all_categorical() ~ "{n}") +#' ``` +#' As a shortcut to select all variables, you can omit the LHS of the formula. +#' The two calls below are equivalent. +#' +#' ```r +#' tbl_summary(statistic = ~"{n}") +#' tbl_summary(statistic = everything() ~ "{n}") +#' ``` +#' +#' 1. **Combination Selectors** +#' +#' Selectors can be combined using the `c()` function. +#' +#' ```r +#' tbl_summary(statistic = c(everything(), -grade) ~ "{n}") +#' ``` +NULL diff --git a/R/utils-as.R b/R/utils-as.R index 70017abd87..8f378107f7 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -10,7 +10,8 @@ text_interpret = "gt::md" ) %>% dplyr::select(all_of(c("column", "rows", "text_interpret", "footnote"))) - } else if (column %in% c("indent", "bold", "italic")) { + } + else if (column %in% c("indent", "bold", "italic")) { x$table_styling$text_format <- x$table_header %>% dplyr::select(all_of(c("column", .env$column))) %>% @@ -22,7 +23,8 @@ undo_text_format = FALSE ) %>% dplyr::bind_rows(x$table_styling$text_format) - } else if (column %in% "missing_emdash") { + } + else if (column %in% "missing_emdash") { x$table_styling[["fmt_missing"]] <- x$table_header %>% dplyr::select(all_of(c("column", .env$column))) %>% @@ -34,7 +36,8 @@ default = "\U2014" ) ) - } else if (column %in% "fmt_fun") { + } + else if (column %in% "fmt_fun") { x$table_styling[[column]] <- x$table_header %>% dplyr::select(all_of(c("column", .env$column))) %>% @@ -257,7 +260,7 @@ mutate(column_id = dplyr::row_number()), by = "column" ) %>% - dplyr::arrange(desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% + dplyr::arrange(dplyr::desc(.data$tab_location), .data$column_id, .data$row_numbers) %>% dplyr::group_by(.data$footnote) %>% tidyr::nest() %>% dplyr::ungroup() %>% @@ -301,7 +304,7 @@ exprs %>% # removing NULL elements unlist() %>% - purrr::compact() %>% + compact() %>% # concatenating expressions with %>% between each of them - purrr::reduce(function(x, y) rlang::inject(!!x %>% !!y, env = env)) + reduce(function(x, y) rlang::inject(!!x %>% !!y, env = env)) } diff --git a/R/utils-misc.R b/R/utils-misc.R index e45d69b4e8..a542fb2bcb 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -1,13 +1,8 @@ -# converts a character vector into a quotes list separated by a comma, eg 'a', 'b' -quoted_list <- function(x) { - paste(shQuote(x, type = "csh"), collapse = ", ") -} - # used in the as_flex_table (and friends) functions for inserting calls add_expr_after <- function(calls, add_after, expr, new_name = NULL) { # checking input if (!rlang::is_string(add_after) || !add_after %in% names(calls)) { - stop(glue("`add_after=` must be one of {quoted_list(names(calls))}")) + cli::cli_abort("Argument {.arg add_after} must be one of {.val {names(calls)}}.") } # position to insert, and name of list @@ -18,133 +13,3 @@ add_expr_after <- function(calls, add_after, expr, new_name = NULL) { # insert list append(calls, new_list, after = index) } - - -# this function is used to fill in missing values in the -# x$table_styling$header$modify_stat_* columns -.fill_table_header_modify_stats <- - function(x, modify_stats = c( - "modify_stat_N", "modify_stat_N_event", - "modify_stat_N_unweighted" - )) { - modify_stats <- - x$table_styling$header %>% - select(any_of(modify_stats) & where(.single_value)) %>% - names() - - x$table_styling$header <- - x$table_styling$header %>% - tidyr::fill(any_of(modify_stats), .direction = "downup") - - return(x) - } - -.single_value <- function(x) { - if (length(unique(stats::na.omit(x))) == 1L) { - return(TRUE) - } - FALSE -} - -#' gtsummary wrapper for purrr::as_mapper -#' -#' This wrapper only accepts a function or formula notation function, -#' and returns an informative message when incorrect inputs passed -#' -#' @param x function or anon. function using formula notation. -#' @param context string indicating function and arg, e.g. `context = "foo(arg=)"` -#' @noRd -#' @keywords internal - -gts_mapper <- function(x, context) { - # checking input, and giving informative error msg - if (!rlang::is_function(x) && !rlang::is_formula(x)) { - paste( - "Expecting a function in argument `{context}`,\n", - "e.g. `fun = function(x) style_pvalue(x, digits = 2)`, or\n", - "`fun = ~style_pvalue(., digits = 2)`" - ) %>% - stringr::str_glue() %>% - rlang::abort() - } - - purrr::as_mapper(x) -} - -# All documentation of the global options was removed in v1.3.1. -# This messaging was added in v1.6.0 -.get_deprecated_option <- function(x, default = NULL) { - if (!is.null(getOption(x, default = NULL))) { - paste( - "Global option {.val {x}} is soft deprecated and will", - "{.emph soon} be removed from {.pkg gtsummary}.\nThe functionality", - "has been migrated to a function argument or a gtsummary theme.", - "\n{.url https://www.danieldsjoberg.com/gtsummary/articles/themes.html}" - ) %>% - cli::cli_alert_danger() - } - getOption(x, default = default) -} - -.assert_class <- function(x, class, arg_name = "x") { - if (!inherits(x, class)) { - cls_clps <- - glue::glue_collapse(shQuote(class, type = "csh"), sep = ", ", last = ", or ") - glue("Error in argument '{arg_name}='. Expecting object of class {cls_clps}") %>% - stop(call. = FALSE) - } -} - -vec_paste0 <- function(..., collapse = NULL) { - args <- vctrs::vec_recycle_common(...) - rlang::inject(paste0(!!!args, collapse = collapse)) -} - -type_check <- - list( - is_string = - list( - msg = "Expecting a string as the passed value.", - fn = function(x) is_string(x) - ), - is_string_summary_type = - list( - msg = "Expecting one of `c('categorical', 'dichotomous', 'continuous', 'continuous2')` as the passed value.", - fn = function(x) is_string(x) && x %in% c("categorical", "dichotomous", "continuous", "continuous2") - ), - is_string_summary_sort = - list( - msg = "Expecting one of `c('frequency', 'alphanumeric')` as the passed value.", - fn = function(x) is_string(x) && x %in% c("frequency", "alphanumeric") - ), - is_character = - list( - msg = "Expecting a character as the passed value.", - fn = function(x) is.character(x) - ), - is_function = - list( - msg = "Expecting a function as the passed value.", - fn = function(x) is.function(x) - ), - is_function_or_string = - list( - msg = "Expecting a function or a string of a function name.", - fn = function(x) is_string(x) || is.function(x) - ), - is_string_or_na = - list( - msg = "Expecting a string or NA as the passed value.", - fn = function(x) is_string(x) || is.na(x) - ), - is_named = - list( - msg = "Expecting a named vector or list as the passed value.", - fn = function(x) is_named(x) - ), - digits = - list( - msg = "Expecting an integer, function, or a vector/list of intergers/functions as the passed value.", - fn = function(x) rlang::is_integerish(x) || is.function(x) || purrr::every(x, ~ rlang::is_integerish(.x) || is.function(.x)) - ) - ) diff --git a/data-raw/trial.R b/data-raw/trial.R new file mode 100644 index 0000000000..0618860961 --- /dev/null +++ b/data-raw/trial.R @@ -0,0 +1,43 @@ +# Results from a cohort study of Drug A vs B + +set.seed(8976) +n <- 200 +trial <- + tibble::tibble( + trt = sample(c("Drug A", "Drug B"), n, replace = TRUE), + age = rnorm(n, mean = 50, sd = 15) %>% as.integer(), + marker = rgamma(n, 1, 1) %>% round(digits = 3), + stage = sample(c("T1", "T2", "T3", "T4"), size = n, replace = TRUE) %>% factor(), + grade = sample(c("I", "II", "III"), size = n, replace = TRUE) %>% factor(), + response_prob = + ((trt == "Drug") - 0.2 * as.numeric(stage) - 0.1 * as.numeric(grade) + 0.1 * marker) %>% + { + 1 / (1 + exp(-.)) + }, + response = runif(n) < response_prob, + ttdeath_true = + exp(1 + 0.2 * response + + -0.1 * as.numeric(stage) + + -0.1 * as.numeric(grade) + + rnorm(n, sd = 0.5)) * 12, + death = ifelse(ttdeath_true <= 24, 1L, 0L), + ttdeath = pmin(ttdeath_true, 24) %>% round(digits = 2) + ) %>% + dplyr::mutate( + age = ifelse(runif(n) < 0.95, age, NA_real_), + marker = ifelse(runif(n) < 0.95, marker, NA_real_), + response = ifelse(runif(n) < 0.95, response, NA_integer_) + ) %>% + dplyr::select(-dplyr::one_of("response_prob", "ttdeath_true")) +summary(trial) + +attr(trial$trt, "label") <- "Chemotherapy Treatment" +attr(trial$age, "label") <- "Age" +attr(trial$marker, "label") <- "Marker Level (ng/mL)" +attr(trial$stage, "label") <- "T Stage" +attr(trial$grade, "label") <- "Grade" +attr(trial$response, "label") <- "Tumor Response" +attr(trial$death, "label") <- "Patient Died" +attr(trial$ttdeath, "label") <- "Months to Death/Censor" + +usethis::use_data(trial, overwrite = TRUE) diff --git a/data/trial.rda b/data/trial.rda new file mode 100644 index 0000000000000000000000000000000000000000..4e60bdcf9e64c0a66079e060831cc47934fdca58 GIT binary patch literal 2631 zcmV-N3b^$`T4*^jL0KkKSt-=rjQ|jq|NsC0|NsC0|NsC0{q_I<|NrW{tH1yK-T(jp z|Nr~{|Nr0#pEBi91JfWq3+LKCcsOvRWdZP%Nd#&GOhZOM4Gld&&Pg5lQO(&?y>87J6siCHg=@TYu zY^RCpnq+B&149}{LkQ8M1OrA*JtIMgVGMz$LnfF_qG_f>BLu`UWH8k6Q56`508AzT z0GLb@A%Fk?044wcm`oEPfS3RP0000+5r6;zFaU!_j3R!jl+ZE;6GKKpqXHUYWYEL| zOn}o95HcAt7=uiVjDQA%OiYYMnhh`}fHW~OGBm`(00w{n7=zRXLm+4XXahh102%?N zfB*mh00000000004FCWD0000000c=QB_2|KOp&SLjW(z1o})8UQJRgY)AcmedYLrI zrqt7EJx8c$&}hl(JsO^;sp>XUL)6nl)b$6X0g%u=CV=%c00Te(G&E>!BTXCCJSo6L zqkrpGM_UG@AQCB2s1S%183IP2mi!#YH8pdUoeTiypk~1}(Gj;pteV_>O?Q*L*xE*~ zRh^0wiv?Cl>`uwWSxBV9$$2c2iZLOvuvLQVsVv}r($ZX*^Pg=@7X&*?C5|C&IEk}t znDebR^V1=g>ujhYu`onbXVid@K+_^s348>x0TWM{O62IYs+O@WDljA@5lpaI2$36! z#0n&ogJl9iWRj8vB%qWD1QbbvK(^EgEhZg6FbFb4z#^KM-d`btj107eRi&kiRvU`A zsR{tVsFNg^G!Q`&0VzQwOK31bK-E=3NmVLQEmo-{wOF(~P60(Qq+M0mB!o~YBt()B zVH6W>f)XTwW zz>-Lij0qzGLJ%P|lBAJ@goK1479=DgB!poj2oZ#lkrW^RfPe}?5KsyQ0w5qF2p|Cn zNXs|(>dLio(KEp0#1IUT5nzeRKx8KMln38xl;(_5xwuNEMy0Jz!kR52BDj!<*3y8G z5`i$WMH`bClFl%P6PS%e-aJ`3Fy5FzxSASSBga5NhT$`9J|Gs8!% zx$YBT-)7h}OfNb;UaG)gSe+0MH&b>7zns+Vbj9d&*h&Hq#tsB1KJ%!FQW|-^os2ub z>=hl29u^6-BjGdQ|Dst7O=McpjX-q07j2!Z-r)lhDeqluS{JlfDxB^$AB;$Dx(vH; z13E1jF+D`Hwz#T1V+02PK#nTRg;X(q$iKVn=hmTSJXjvg{MRM&IqcU(5y$|5BuB3W z0As|b3|tWCqR?b?89O6JSdE2ZZ-{y&j)6Zu1ri|Ja%frsB{iUH5n2Wo^5@^7$K8fW zqS1#4FMb^4&@ni2QlK=p+~KkmP85M7so|HV10GNi+J}nT+SE^{tFFt;rqM`=5tv#>}Q(lJXcp3FC&GMINSnV$oyn7~eORUZ23p+J;jD(4_Jw#XHqiXBJg2pva zxa4oWHqo&3hN+4U*21)H4Eve`cTJ{~lr`4Ao6QIleT@|%!x4<2HS?&t`r|AddaTn# zeS!(rJeJ@=E}j&}Hw=_;gJHmJ838Uz12I!CZ5+4XlBtFvIOfA7HijIdBpM(z6QV>^ z%P|XR5HX1gGE>ZXp)AD15QB(ah0^vgmz%}%;J94H_7%m|tDvC-5JUh$1OY%GAeYe= z0DuSrECFBup%73C06`)^Br2s9Ajn9@FpQ~0BqStZQizhMs6>G)Fb%+f?Lyz}H!2$`f4l|bTEEh#b#XuoRmF)g+QauLXi9~;U z1z2$0(SeBC^=;C*X%b9_i8DXg27)0`?fWbtWHDsQs`X>xo1z8~cq${gcf>+oS*_Ww z8xXT?ZAGthUZ1!rAiXH`3snfUuy27bT4n)KZaH(#VGoIPt21Ry_3?Zo8yk7PJ#hKuMy?5q?2?( z!*6kGG%Ac18K{xWPF|X|_uh@_g^~I{4v7yQ>~%deLhdG{Nbtt@_&|gh0G}uU{gt(C zdHzHWkF6aD0DvmeTx-%3IO_=_Eab4$wTnV~$|zQWXHp!AM)9T;E~p}m03ZrwwKS#< zM_0-~C{4dGRG9Ap2MjOb0%ZreA2}^jHf;zTivx>7 zR}sZP(sUAm?{gcuzou}=yYl=Dxx_hh-9K+rnQ=RfV5p#kwB+=wL;Mm3dP2t<2e}F# z+q$hc!ht<@VC_IZh+OIEEgNHK9Y#P*!UJgJ?nSf4AbWO3o+3uCPZU_B44PALU50~C z)|^52EoV83CLIJY0)DrUa~xWr;9`hS6c3#GjhnrmtAj(>bs?ku|CYhVbD`UiF^+v+ z*O1-*>s)qm69LoBvpdIW7Q0uE(@qtV<588apt0Sj``L1vF81*p2S}anHMyW{nQ{-r z#7R%b@cpnHmz;4RsyxTBznGL%U^@d5Yxj+SE=+mTW!W=z6?@?Nl&;T~1F}NL)ky*! zfWiZ`efP5Ro+09#FEB~Z=4ALQ&a_Dg`orQur^`+G12}h_-5T3b2o2C8^P3Wm8gTMx zZP@86x5irBsRKD*o@RQT4*vA-i>jcwQ-lNz6Rc!2JD%(L+?VgN={W$>@hB|mGr_Tq zoYc_ye=}o)4|fH@0Gufq7#o%D5hh0?a2tcia#R*$0Ln-@RW|0rzpPT=?`>}a)4g>V1> literal 0 HcmV?d00001 diff --git a/man/as_gt.Rd b/man/as_gt.Rd index 06a7af7425..5ea2f41981 100644 --- a/man/as_gt.Rd +++ b/man/as_gt.Rd @@ -7,8 +7,7 @@ as_gt(x, include = everything(), return_calls = FALSE, ...) } \arguments{ -\item{x}{Object created by a function from the gtsummary package -(e.g. \link{tbl_summary} or \link{tbl_regression})} +\item{x}{An object of class `"gtsummary"} \item{include}{Commands to include in output. Input may be a vector of quoted or unquoted names. tidyselect and gtsummary select helper @@ -18,7 +17,7 @@ Default is \code{everything()}.} \item{return_calls}{Logical. Default is \code{FALSE}. If \code{TRUE}, the calls are returned as a list of expressions.} -\item{...}{Arguments passed on to \link[gt:gt]{gt::gt}} +\item{...}{Arguments passed on to \code{gt::gt(...)}} } \value{ A \code{gt_tbl} object @@ -29,12 +28,6 @@ that is, a table created with \code{gt::gt()}. Function is used in the background when the results are printed or knit. A user can use this function if they wish to add customized formatting available via the \href{https://gt.rstudio.com/index.html}{gt package}. - -Review the -\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html#advanced}{tbl_summary vignette} -or -\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html#advanced}{tbl_regression vignette} -for detailed examples in the 'Advanced Customization' section. } \examples{ # Example 1 ---------------------------------- diff --git a/man/construct_gtsummary.Rd b/man/construct_gtsummary.Rd deleted file mode 100644 index 902672b81e..0000000000 --- a/man/construct_gtsummary.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/construct_table_body.R -\name{construct_gtsummary} -\alias{construct_gtsummary} -\alias{construct_gtsummary.default} -\alias{construct_gtsummary.tbl_summary} -\title{Construct Table Body} -\usage{ -construct_gtsummary(x) - -\method{construct_gtsummary}{default}(x) - -\method{construct_gtsummary}{tbl_summary}(x) -} -\arguments{ -\item{x}{gtsummary object} -} -\value{ -gtsummary object -} -\description{ -Construct Table Body -} -\examples{ -# TODO: Add example -} diff --git a/man/print_gtsummary.Rd b/man/print_gtsummary.Rd index 90be5eab62..a49d1b1fde 100644 --- a/man/print_gtsummary.Rd +++ b/man/print_gtsummary.Rd @@ -5,7 +5,11 @@ \alias{print.gtsummary} \title{print and knit_print methods for gtsummary objects} \usage{ -\method{print}{gtsummary}(x, print_engine = "gt", ...) +\method{print}{gtsummary}( + x, + print_engine = c("gt", "flextable", "huxtable", "kable", "kable_extra", "tibble"), + ... +) } \arguments{ \item{x}{An object created using gtsummary functions} diff --git a/man/syntax.Rd b/man/syntax.Rd new file mode 100644 index 0000000000..ba855f0762 --- /dev/null +++ b/man/syntax.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/syntax.R +\name{syntax} +\alias{syntax} +\title{Syntax and Notation} +\description{ +Syntax and Notation +} +\section{Selectors}{ +The gtsummary package also utilizes selectors: selectors from the tidyselect +package and custom selectors. Review their help files for details. +\itemize{ +\item \strong{tidy selectors} + +\code{everything()}, \code{all_of()}, \code{any_of()}, \code{starts_with()}, \code{ends_with()}, +\code{contains()}, \code{matches()}, \code{num_range()}, \code{last_col()} +\item \strong{gtsummary selectors} + +\code{all_continuous()}, \code{all_categorical()}, \code{all_dichotomous()}, +\code{all_continuous2()}, \code{all_tests()}, \code{all_stat_cols()}, +\code{all_interaction()}, \code{all_intercepts()}, \code{all_contrasts()} +} +} + +\section{Formula and List Selectors}{ +Many arguments throughout the gtsummary package accept list and +formula notation, e.g. \code{tbl_summary(statistic=)}. Below enumerates a few +tips and shortcuts for using the list and formulas. +\enumerate{ +\item \strong{List of Formulas} + +Typical usage includes a list of formulas, where the LHS is a variable +name or a selector. + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = list(age ~ "\{mean\}", all_categorical() ~ "\{n\}")) +}\if{html}{\out{
}} +\item \strong{Named List} + +You may also pass a named list; however, the tidyselect and gtsummary selectors +are not supported with this syntax. + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = list(age = "\{mean\}", response = "\{n\}")) +}\if{html}{\out{
}} +\item \strong{Hybrid Named List/List of Formulas} + +Pass a combination of formulas and named elements + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = list(age = "\{mean\}", all_categorical() ~ "\{n\}")) +}\if{html}{\out{
}} +\item \strong{Shortcuts} + +You can pass a single formula, which is equivalent to passing the formula +in a list. + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = all_categorical() ~ "\{n\}") +}\if{html}{\out{
}} + +As a shortcut to select all variables, you can omit the LHS of the formula. +The two calls below are equivalent. + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = ~"\{n\}") +tbl_summary(statistic = everything() ~ "\{n\}") +}\if{html}{\out{
}} +\item \strong{Combination Selectors} + +Selectors can be combined using the \code{c()} function. + +\if{html}{\out{
}}\preformatted{tbl_summary(statistic = c(everything(), -grade) ~ "\{n\}") +}\if{html}{\out{
}} +} +} + +\keyword{internal} diff --git a/man/trial.Rd b/man/trial.Rd new file mode 100644 index 0000000000..5e6fd70a06 --- /dev/null +++ b/man/trial.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{trial} +\alias{trial} +\title{Results from a simulated study of two chemotherapy agents} +\format{ +A data frame with 200 rows--one row per patient +\describe{ +\item{trt}{Chemotherapy Treatment} +\item{age}{Age} +\item{marker}{Marker Level (ng/mL)} +\item{stage}{T Stage} +\item{grade}{Grade} +\item{response}{Tumor Response} +\item{death}{Patient Died} +\item{ttdeath}{Months to Death/Censor} +} +} +\usage{ +trial +} +\description{ +A dataset containing the baseline characteristics of 200 patients +who received Drug A or Drug B. Dataset also contains the outcome of +tumor response to the treatment. +} +\keyword{datasets} From 320a437ad2baa52f5b8dd0dde0951e5630f7b961 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 1 Dec 2023 08:54:55 -0800 Subject: [PATCH 04/74] Selecting updates (#1573) * in progress * progress --- DESCRIPTION | 2 +- NAMESPACE | 9 +- NEWS.md | 14 ++- R/as_gt.R | 10 +- R/assign_summary_digits.R | 20 ++++ R/assign_summary_type.R | 95 +++++++++++++++++++ R/bridge_summary.R | 26 ++--- R/modify_column_hide.R | 18 ++-- R/modify_fmt_fun.R | 59 ++++++++++++ R/reexport.R | 4 + R/select_helpers.R | 100 ++++++++++---------- R/tbl_summary.R | 64 +++++++++++-- R/utils-as.R | 8 +- R/utils-gtsummary.R | 32 ------- R/utils-gtsummary_core.R | 2 +- R/utils-misc.R | 15 +++ man/as_gt.Rd | 10 +- man/assign_summary_type.Rd | 32 +++++++ man/bridge_summary.Rd | 28 +++--- man/dot-table_styling_expr_to_row_number.Rd | 6 -- man/modify_column_hide.Rd | 12 +-- man/modify_fmt_fun.Rd | 51 ++++++++++ man/modify_table_styling.Rd | 3 +- man/reexports.Rd | 3 +- man/select_helpers.Rd | 28 ------ man/tbl_summary.Rd | 9 +- 26 files changed, 451 insertions(+), 209 deletions(-) create mode 100644 R/assign_summary_digits.R create mode 100644 R/assign_summary_type.R create mode 100644 R/modify_fmt_fun.R delete mode 100644 R/utils-gtsummary.R create mode 100644 man/assign_summary_type.Rd create mode 100644 man/modify_fmt_fun.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4bc7dbc139..59407419c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -44,7 +44,7 @@ URL: https://github.com/ddsjoberg/gtsummary, BugReports: https://github.com/ddsjoberg/gtsummary/issues Imports: broom.helpers, - cards (>= 0.0.0.9001), + cards (>= 0.0.0.9002), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/NAMESPACE b/NAMESPACE index fbebb15a52..9f27f52559 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,16 +6,14 @@ export(.table_styling_expr_to_row_number) export(all_categorical) export(all_continuous) export(all_continuous2) -export(all_contrasts) export(all_dichotomous) -export(all_interaction) -export(all_intercepts) export(all_of) export(all_stat_cols) -export(all_tests) export(any_of) export(as_gt) export(as_tibble) +export(assign_summary_type) +export(brdg_summary) export(contains) export(ends_with) export(everything) @@ -23,6 +21,7 @@ export(last_col) export(matches) export(modify_column_hide) export(modify_column_unhide) +export(modify_fmt_fun) export(modify_table_styling) export(mutate) export(num_range) @@ -36,6 +35,7 @@ export(select) export(starts_with) export(tbl_summary) export(vars) +export(where) import(rlang) importFrom(broom.helpers,.select_to_varnames) importFrom(dplyr,"%>%") @@ -54,3 +54,4 @@ importFrom(dplyr,one_of) importFrom(dplyr,select) importFrom(dplyr,starts_with) importFrom(dplyr,vars) +importFrom(dplyr,where) diff --git a/NEWS.md b/NEWS.md index f79f47829a..e92bcf0a3e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,20 +1,24 @@ # gtsummary (development version) -### Overview of Changes in v2.0 +## Overview of Changes in v2.0 -#### User-facing Updates +### User-facing Updates * The counts in the header of `tbl_summary(by)` tables now appear on a new line. -#### Internal Updates +* If a column is all `NA` it is now removed from the summary table created with `tbl_summary()`. + +* Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be explicitly defined in a factor. + +### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. -### Bug Fixes +## Bug Fixes * Fix in `add_difference()` for paired t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) -### Deprecations +## Deprecations * Global options have been deprecated in gtsummary since v1.3.1 (3.5 years ago). They have now been fully removed from the package. diff --git a/R/as_gt.R b/R/as_gt.R index 4c15b82bda..fcef710018 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -19,11 +19,11 @@ #' @author Daniel D. Sjoberg #' @export #' @examples -#' # Example 1 ---------------------------------- -#' as_gt_ex1 <- -#' trial[c("trt", "age", "response", "grade")] %>% -#' tbl_summary(by = trt) %>% -#' as_gt() +#' # # Example 1 ---------------------------------- +#' # as_gt_ex1 <- +#' # trial[c("trt", "age", "response", "grade")] %>% +#' # tbl_summary(by = trt) %>% +#' # as_gt() as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { assert_class(x, "gtsummary") diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R new file mode 100644 index 0000000000..57d77736df --- /dev/null +++ b/R/assign_summary_digits.R @@ -0,0 +1,20 @@ + + +# assign_summary_digits <- function(data, statistic, type, digits = NULL) { +# # extract the statistics +# statistic <- lapply(statistic, function(x) .extract_glue_elements(x) |> unlist()) +# +# lapply( +# names(statistic), +# function(variable) { +# if (!is.null(digits[[variable]])){ +# return(rep_named(statistic[[variable]], digits[[variable]])) +# } +# +# if (type[[variable]] %in% c("cateogrical", "dichotomous")) { +# +# } +# } +# ) +# +# } diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R new file mode 100644 index 0000000000..654d1c99fc --- /dev/null +++ b/R/assign_summary_type.R @@ -0,0 +1,95 @@ +#' Assign Default Summary Type +#' +#' Function inspects data and assigns a summary type when not specified +#' in the `type` argument. +#' +#' @param data a data frame +#' @param variables character vector of column names in `data` +#' @param value named list of values to show for dichotomous variables, where +#' the names are the variables +#' @param type named list of summary types, where names are the variables +#' +#' @return named list +#' @export +#' +#' @examples +#' assign_summary_type( +#' data = trial, +#' variables = c("age", "grade", "response"), +#' value = NULL +#' ) +assign_summary_type <- function(data, variables, value, type = NULL) { + # base classes that can be summarized as continuous + base_numeric_classes <- c("numeric", "integer", "difftime", "Date", "POSIXt", "double") + + # assign a type + type <- + map( + variables, + function(variable) { + # return specified type if passed by user + if (!is.null(type[[variable]])) { + return(type[[variable]]) + } + + # logical variables are dichotomous + if (inherits(data[[variable]], "logical")) { + return("dichotomous") + } + + # numeric variables that are 0 and 1 only, will be dichotomous + if (inherits(data[[variable]], c("integer", "numeric")) && + length(setdiff(stats::na.omit(data[[variable]]), c(0, 1))) == 0) { + return("dichotomous") + } + + # factor variables that are "No" and "Yes" only, will be dichotomous + if (inherits(data[[variable]], "factor") && + length(levels(data[[variable]])) == 2L && + setequal(toupper(levels(data[[variable]])), c("NO", "YES"))) { + return("dichotomous") + } + + # character variables that are "No" and "Yes" only, will be dichotomous + if (inherits(data[[variable]], "character") && + setequal(toupper(stats::na.omit(data[[variable]])), c("NO", "YES")) && + length(stats::na.omit(data[[variable]])) == 2L) { + return("dichotomous") + } + + # factors and characters are categorical + if (inherits(data[[variable]], c("factor", "character"))) { + return("categorical") + } + + # numeric variables with fewer than 10 levels will be categorical + if (inherits(data[[variable]], base_numeric_classes) && + length(unique(stats::na.omit(data[[variable]]))) < 10) { + return("categorical") + } + + # all other numeric classes are continuous + if (inherits(data[[variable]], base_numeric_classes)) { + return(get_theme_element("tbl_summary-str:default_con_type", default = "continuous")) + } + + # finally, summarize as categorical if none of the above criteria were met + return("categorical") + } + ) |> + stats::setNames(variables) + + # return type + type +} + +.add_summary_type_as_attr <- function(data, type) { + type <- type[names(type) %in% names(data)] + type_names <- names(type) + + for (i in seq_along(type)) { + attr(data[[type_names[i]]], "gtsummary.type") <- type[[i]] + } + + data +} diff --git a/R/bridge_summary.R b/R/bridge_summary.R index acb8d4cbd7..871d4e3999 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -11,6 +11,9 @@ #' @param variables character list of variables #' @param value named list of values to be summarized. the names are the #' variable names. +#' @param calling_function string indicating the name of the function that is +#' calling thie bridge function, e.g. `call_function = "tbl_summary"`. This is used +#' internally to organize results. #' @inheritParams tbl_summary #' #' @return data frame @@ -20,6 +23,7 @@ #' tbl <- #' tbl_summary( #' data = mtcars, +#' include = c("cyl", "am", "mpg", "hp"), #' type = #' list( #' cyl = "categorical", @@ -39,37 +43,27 @@ #' pier_summary_dichotomous( #' x = tbl, #' variables = "am", -#' value = list(am = 1), -#' missing = "ifany", -#' missing_text = "Unknown", -#' missing_stat = "{N_miss}" +#' value = list(am = 1) #' ) #' #' pier_summary_categorical( #' x = tbl, -#' variables = "cyl", -#' missing = "ifany", -#' missing_text = "Unknown", -#' missing_stat = "{N_miss}" +#' variables = "cyl" #' ) #' #' pier_summary_continuous2( #' x = tbl, -#' variables = "hp", -#' missing = "ifany", -#' missing_text = "Unknown", -#' missing_stat = "{N_miss}" +#' variables = "hp" #' ) #' #' pier_summary_continuous( #' x = tbl, -#' variables = "mpg", -#' missing = "ifany", -#' missing_text = "Unknown", -#' missing_stat = "{N_miss}" +#' variables = "mpg" #' ) NULL +#' @rdname bridge_summary +#' @export brdg_summary <- function(x, calling_function = "tbl_summary") { # add gts info to the cards table -------------------------------------------- # add the function call column diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index 535ebfb916..cfb0b3c170 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -8,15 +8,15 @@ #' @name modify_column_hide #' @family Advanced modifiers #' @examples -#' \donttest{ -#' # Example 1 ---------------------------------- -#' # hide 95% CI, and replace with standard error -#' modify_column_hide_ex1 <- -#' lm(age ~ marker + grade, trial) %>% -#' tbl_regression() %>% -#' modify_column_hide(columns = ci) %>% -#' modify_column_unhide(columns = std.error) -#' } +# #' \donttest{ +# #' # Example 1 ---------------------------------- +# #' # hide 95% CI, and replace with standard error +# #' modify_column_hide_ex1 <- +# #' lm(age ~ marker + grade, trial) %>% +# #' tbl_regression() %>% +# #' modify_column_hide(columns = ci) %>% +# #' modify_column_unhide(columns = std.error) +# #' } NULL #' @rdname modify_column_hide diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R new file mode 100644 index 0000000000..41569197fe --- /dev/null +++ b/R/modify_fmt_fun.R @@ -0,0 +1,59 @@ +#' Modify Formatting Functions +#' +#' \lifecycle{maturing} +#' Use this function to update the way numeric columns and rows of `.$table_body` +#' are formatted +#' +#' @param update list of formulas or a single formula specifying the updated +#' formatting function. +#' The LHS specifies the column(s) to be updated, +#' and the RHS is the updated formatting function. +#' @param rows predicate expression to select rows in `x$table_body`. +#' Default is `NULL`. See details below. +#' @inheritParams modify_table_styling +#' +#' @inheritSection modify_table_styling rows argument +#' @family Advanced modifiers +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @export +# #' @examples +# #' \donttest{ +# #' # Example 1 ---------------------------------- +# #' # show 'grade' p-values to 3 decimal places +# #' modify_fmt_fun_ex1 <- +# #' lm(age ~ marker + grade, trial) %>% +# #' tbl_regression() %>% +# #' modify_fmt_fun( +# #' update = p.value ~ function(x) style_pvalue(x, digits = 3), +# #' rows = variable == "grade" +# #' ) +# #' } +modify_fmt_fun <- function(x, update, rows = NULL) { + updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) + assert_class(x, "gtsummary") + + # converting update arg to a tidyselect list --------------------------------- + cards::process_formula_selectors( + data = x$table_body, + udpate = update + ) + cards::check_list_elements( + check = function(x) is_function(x), + error_msg = list( + check = "The value passed in {.arg {arg_name}} for variable {.val {variable}} must be a function." + ) + ) + + + # updating formatting functions ---------------------------------------------- + x <- + modify_table_styling( + x = x, + columns = names(update), + rows = {{ rows }}, + fmt_fun = update + ) + + x$call_list <- updated_call_list + x +} diff --git a/R/reexport.R b/R/reexport.R index b32db33c67..d0b9e13c77 100644 --- a/R/reexport.R +++ b/R/reexport.R @@ -51,6 +51,10 @@ dplyr::everything #' @export dplyr::last_col +#' @importFrom dplyr where +#' @export +dplyr::where + #' @importFrom dplyr one_of #' @export dplyr::one_of diff --git a/R/select_helpers.R b/R/select_helpers.R index d13c78258b..6fca53ffdc 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -11,77 +11,73 @@ #' - `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 -#' @param tests string indicating the test type of the variables to select, e.g. -#' select all variables being compared with `"t.test"` +# #' @param tests string indicating the test type of the variables to select, e.g. +# #' select all variables being compared with `"t.test"` #' @param stat_0 When `FALSE`, will not select the `"stat_0"` column. Default is `TRUE` #' @param continuous2 Logical indicating whether to include continuous2 variables. Default is `TRUE` #' @param dichotomous Logical indicating whether to include dichotomous variables. #' Default is `TRUE` -#' @param contrasts_type type of contrast to select. When `NULL`, all variables with a -#' contrast will be selected. Default is `NULL`. Select among contrast types -#' `c("treatment", "sum", "poly", "helmert", "other")` +# #' @param contrasts_type type of contrast to select. When `NULL`, all variables with a +# #' contrast will be selected. Default is `NULL`. Select among contrast types +# #' `c("treatment", "sum", "poly", "helmert", "other")` #' @name select_helpers #' @return A character vector of column names selected #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @examples -#' select_ex1 <- -#' trial %>% -#' select(age, response, grade) %>% -#' tbl_summary( -#' statistic = all_continuous() ~ "{mean} ({sd})", -#' type = all_dichotomous() ~ "categorical" -#' ) +# #' select_ex1 <- +# #' trial %>% +# #' select(age, response, grade) %>% +# #' tbl_summary( +# #' statistic = all_continuous() ~ "{mean} ({sd})", +# #' type = all_dichotomous() ~ "categorical" +# #' ) NULL #' @rdname select_helpers #' @export all_continuous <- function(continuous2 = TRUE) { - if (continuous2 == TRUE) { - return(broom.helpers::all_continuous()) - } else { - return( - .generic_selector("variable", "var_type", - .data$var_type %in% "continuous", - fun_name = "all_continuous" - ) - ) - } + types <- if (continuous2) c("continuous", "continuous2") else "continuous" + + where(function(x) attr(x, "gtsummary.type") %in% types) } #' @rdname select_helpers #' @export all_continuous2 <- function() { - .generic_selector("variable", "var_type", - .data$var_type %in% "continuous2", - fun_name = "all_continuous" - ) + where(function(x) attr(x, "gtsummary.type") %in% "continuous2") } #' @rdname select_helpers #' @export -all_categorical <- broom.helpers::all_categorical +all_categorical <- function(dichotomous = TRUE) { + types <- if (dichotomous) c("categorical", "dichotomous") else "categorical" -#' @rdname select_helpers -#' @export -all_dichotomous <- broom.helpers::all_dichotomous + where(function(x) attr(x, "gtsummary.type") %in% types) +} #' @rdname select_helpers #' @export -all_tests <- function(tests = NULL) { - if (is.null(tests) || !is.character(tests) || any(!tests %in% df_add_p_tests$test_name)) { - paste( - "The `tests=` argument must be one or more of the following:", - paste(shQuote(df_add_p_tests$test_name), collapse = ", ") - ) %>% - stop(call. = FALSE) - } - - .generic_selector("variable", "test_name", - .data$test_name %in% .env$tests, - fun_name = "all_tests" - ) +all_dichotomous <- function() { + where(function(x) attr(x, "gtsummary.type") %in% "dichotomous") } +# #' @rdname select_helpers +# #' @export +# all_tests <- function(tests = NULL) { +# if (is.null(tests) || !is.character(tests) || any(!tests %in% df_add_p_tests$test_name)) { +# paste( +# "The `tests=` argument must be one or more of the following:", +# paste(shQuote(df_add_p_tests$test_name), collapse = ", ") +# ) %>% +# stop(call. = FALSE) +# } +# +# .generic_selector("variable", "test_name", +# .data$test_name %in% .env$tests, +# fun_name = "all_tests" +# ) +# } + #' @rdname select_helpers #' @export all_stat_cols <- function(stat_0 = TRUE) { @@ -105,14 +101,14 @@ all_stat_cols <- function(stat_0 = TRUE) { } } -#' @rdname select_helpers -#' @export -all_interaction <- broom.helpers::all_interaction +# #' @rdname select_helpers +# #' @export +# all_interaction <- broom.helpers::all_interaction -#' @rdname select_helpers -#' @export -all_intercepts <- broom.helpers::all_intercepts +# #' @rdname select_helpers +# #' @export +# all_intercepts <- broom.helpers::all_intercepts -#' @rdname select_helpers -#' @export -all_contrasts <- broom.helpers::all_contrasts +# #' @rdname select_helpers +# #' @export +# all_contrasts <- broom.helpers::all_contrasts diff --git a/R/tbl_summary.R b/R/tbl_summary.R index a0b6c76c77..fe3769e084 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -21,6 +21,7 @@ #' tbl <- #' tbl_summary( #' data = mtcars, +#' include = c("cyl", "am", "mpg", "hp"), #' type = #' list( #' cyl = "categorical", @@ -36,25 +37,61 @@ #' hp = c("{mean}", "{median}") #' ) #' ) -tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, - digits = NULL, type = NULL, value = NULL, +tbl_summary <- function(data, + by = NULL, + label = NULL, + statistic = list(all_continuous() ~ "{mean} ({sd})", + all_categorical() ~ "{n} ({p}%)"), + digits = NULL, + type = assign_summary_type(data, include, value), + value = NULL, missing = c("ifany", "no", "always"), - missing_text = "Unknown", missing_stat = "{N_miss}", - sort = NULL, percent = c("column", "row", "cell"), - include = c(everything(), -by)) { + missing_text = "Unknown", + missing_stat = "{N_miss}", + sort = all_categorical() ~ "alphanumeric", + percent = c("column", "row", "cell"), + include = everything()) { # process arguments ---------------------------------------------------------- data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{by}}, include = {{include}}) include <- setdiff(include, by) # remove by variable from list vars included + include <- .remove_na_columns(data, include) missing <- rlang::arg_match(arg = missing) percent <- rlang::arg_match(arg = percent) + cards::process_formula_selectors(data = data[include], value = value) + # assign summary type -------------------------------------------------------- + if (!missing(type)) { + # first set default types, so selectors like `all_continuous()` can be used + # to recast the summary type, e.g. make all continuous type "continuous2" + default_types <- formals(gtsummary::tbl_summary)[["type"]] |> eval() + data <- .add_summary_type_as_attr(data, default_types) + # process the user-passed type argument + cards::process_formula_selectors(data = data[include], type = type) + # fill in any types not specified by user + type <- utils::modifyList(default_types, type) + } + + # evaluate the remaining list-formula arguments ------------------------------ + # processed arguments are saved into this env cards::process_formula_selectors( - data = data[include], + data = .add_summary_type_as_attr(data[include], type), label = label, - statistic = statistic, + statistic = + .ifelse1( + missing(statistic), + get_theme_element("TODO:fill-this-in", default = statistic), + statistic + ) , digits = digits, - type = type + sort = sort + ) + + # fill in unspecified variables + cards::fill_formula_selectors( + data[include], + statistic = + get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])) ) # save processed function inputs --------------------------------------------- @@ -114,3 +151,14 @@ tbl_summary <- function(data, by = NULL, label = NULL, statistic = NULL, .get_variables_by_type <- function(x, type) { names(x)[unlist(x) %in% type] } + +.remove_na_columns <- function(data, include) { + is_all_na <- map_lgl(include, function(x) all(is.na(x))) + if (any(is_all_na)) { + paste("Columns {.val {include[is_all_na]}} are all {.cls NA}", + "and have been removed from the summary table.") |> + cli::cli_inform() + } + + include[!is_all_na] +} diff --git a/R/utils-as.R b/R/utils-as.R index 8f378107f7..9773511c2e 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -84,10 +84,10 @@ #' @export #' #' @examples -#' tbl <- -#' trial %>% -#' tbl_summary(include = c(age, grade)) %>% -#' .table_styling_expr_to_row_number() +# #' tbl <- +# #' trial %>% +# #' tbl_summary(include = c(age, grade)) %>% +# #' .table_styling_expr_to_row_number() .table_styling_expr_to_row_number <- function(x) { # text_format ---------------------------------------------------------------- x$table_styling$text_format <- diff --git a/R/utils-gtsummary.R b/R/utils-gtsummary.R deleted file mode 100644 index 2db5069cd2..0000000000 --- a/R/utils-gtsummary.R +++ /dev/null @@ -1,32 +0,0 @@ - -.extract_glue_elements <- function(x) { - regmatches(x, gregexpr("\\{([^\\}]*)\\}", x)) |> - unlist() %>% - {substr(., 2, nchar(.) - 1)} -} - -.ifelse1 <- function(test, yes, no) { - if (test) { - return(yes) - } - no -} - -.get_selecting_data_frame <- function(x) { - # if a tbl_summary-like table, grab data frame from inputs - if (tryCatch(x$calls[[1]]$data |> is.data.frame(), error = function(x) FALSE)) { - return(x$calls[[1]]$dataa) - } - - # TODO: add tbl_regression results often return the type of variable input, we could use that to construct a df with the approriate class? - - # if none of the above apply, return a data frame based on the variables listed - if ("variable" %in% names(x$table_body)) { - return( - dplyr::tibble(!!!rlang::rep_named(unique(x$table_body$variable), character())) - ) - } - - # lastly, we can get a variable list from the card data frame - dplyr::tibble(!!!rlang::rep_named(unique(x$cards$variable), character())) -} diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 539fce9dd2..848f5e660d 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -1,4 +1,4 @@ -get_theme_element <- function(...) NULL +get_theme_element <- function(..., default = NULL) default construct_initial_table_styling <- function(x) { # table_styling -------------------------------------------------------------- diff --git a/R/utils-misc.R b/R/utils-misc.R index a542fb2bcb..7bef019eb5 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -1,3 +1,18 @@ + +.extract_glue_elements <- function(x) { + regmatches(x, gregexpr("\\{([^\\}]*)\\}", x)) |> + unlist() %>% + {substr(., 2, nchar(.) - 1)} +} + +.ifelse1 <- function(test, yes, no) { + if (test) { + return(yes) + } + no +} + + # used in the as_flex_table (and friends) functions for inserting calls add_expr_after <- function(calls, add_after, expr, new_name = NULL) { # checking input diff --git a/man/as_gt.Rd b/man/as_gt.Rd index 5ea2f41981..d0146bcdd1 100644 --- a/man/as_gt.Rd +++ b/man/as_gt.Rd @@ -30,11 +30,11 @@ A user can use this function if they wish to add customized formatting available via the \href{https://gt.rstudio.com/index.html}{gt package}. } \examples{ -# Example 1 ---------------------------------- -as_gt_ex1 <- - trial[c("trt", "age", "response", "grade")] \%>\% - tbl_summary(by = trt) \%>\% - as_gt() +# # Example 1 ---------------------------------- +# as_gt_ex1 <- +# trial[c("trt", "age", "response", "grade")] \%>\% +# tbl_summary(by = trt) \%>\% +# as_gt() } \author{ Daniel D. Sjoberg diff --git a/man/assign_summary_type.Rd b/man/assign_summary_type.Rd new file mode 100644 index 0000000000..173e231e1e --- /dev/null +++ b/man/assign_summary_type.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/assign_summary_type.R +\name{assign_summary_type} +\alias{assign_summary_type} +\title{Assign Default Summary Type} +\usage{ +assign_summary_type(data, variables, value, type = NULL) +} +\arguments{ +\item{data}{a data frame} + +\item{variables}{character vector of column names in \code{data}} + +\item{value}{named list of values to show for dichotomous variables, where +the names are the variables} + +\item{type}{named list of summary types, where names are the variables} +} +\value{ +named list +} +\description{ +Function inspects data and assigns a summary type when not specified +in the \code{type} argument. +} +\examples{ +assign_summary_type( + data = trial, + variables = c("age", "grade", "response"), + value = NULL +) +} diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 0fe956ec79..314078c183 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/bridge_summary.R \name{bridge_summary} \alias{bridge_summary} +\alias{brdg_summary} \alias{pier_summary_dichotomous} \alias{pier_summary_categorical} \alias{pier_summary_continuous2} @@ -9,6 +10,8 @@ \alias{pier_summary_missing_row} \title{Summary Table Bridges} \usage{ +brdg_summary(x, calling_function = "tbl_summary") + pier_summary_dichotomous(x, variables, value = x$inputs$value) pier_summary_categorical(x, variables, missing, missing_text, missing_stat) @@ -22,6 +25,10 @@ pier_summary_missing_row(x, variables = x$inputs$include) \arguments{ \item{x}{gtsummary object of class \code{"tbl_summary"}} +\item{calling_function}{string indicating the name of the function that is +calling thie bridge function, e.g. \code{call_function = "tbl_summary"}. This is used +internally to organize results.} + \item{variables}{character list of variables} \item{value}{named list of values to be summarized. the names are the @@ -47,6 +54,7 @@ referred to as the piers (supports for a bridge) and begin with \verb{pier_*()}. tbl <- tbl_summary( data = mtcars, + include = c("cyl", "am", "mpg", "hp"), type = list( cyl = "categorical", @@ -66,33 +74,21 @@ tbl <- pier_summary_dichotomous( x = tbl, variables = "am", - value = list(am = 1), - missing = "ifany", - missing_text = "Unknown", - missing_stat = "{N_miss}" + value = list(am = 1) ) pier_summary_categorical( x = tbl, - variables = "cyl", - missing = "ifany", - missing_text = "Unknown", - missing_stat = "{N_miss}" + variables = "cyl" ) pier_summary_continuous2( x = tbl, - variables = "hp", - missing = "ifany", - missing_text = "Unknown", - missing_stat = "{N_miss}" + variables = "hp" ) pier_summary_continuous( x = tbl, - variables = "mpg", - missing = "ifany", - missing_text = "Unknown", - missing_stat = "{N_miss}" + variables = "mpg" ) } diff --git a/man/dot-table_styling_expr_to_row_number.Rd b/man/dot-table_styling_expr_to_row_number.Rd index 426fc79c5e..c5a25fd87a 100644 --- a/man/dot-table_styling_expr_to_row_number.Rd +++ b/man/dot-table_styling_expr_to_row_number.Rd @@ -17,10 +17,4 @@ Ahead of a gtsummary object being converted to an output type, each logical expression saved in \code{x$table_styling} is converted to a list of row numbers. } -\examples{ -tbl <- - trial \%>\% - tbl_summary(include = c(age, grade)) \%>\% - .table_styling_expr_to_row_number() -} \keyword{internal} diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 84cfb9ee98..43a24893c5 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -18,21 +18,11 @@ modify_column_unhide(x, columns) \lifecycle{maturing} Use these functions to hide or unhide columns in a gtsummary table. } -\examples{ -\donttest{ -# Example 1 ---------------------------------- -# hide 95\% CI, and replace with standard error -modify_column_hide_ex1 <- - lm(age ~ marker + grade, trial) \%>\% - tbl_regression() \%>\% - modify_column_hide(columns = ci) \%>\% - modify_column_unhide(columns = std.error) -} -} \seealso{ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: +\code{\link{modify_fmt_fun}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd new file mode 100644 index 0000000000..80c0b89205 --- /dev/null +++ b/man/modify_fmt_fun.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_fmt_fun.R +\name{modify_fmt_fun} +\alias{modify_fmt_fun} +\title{Modify Formatting Functions} +\usage{ +modify_fmt_fun(x, update, rows = NULL) +} +\arguments{ +\item{x}{gtsummary object} + +\item{update}{list of formulas or a single formula specifying the updated +formatting function. +The LHS specifies the column(s) to be updated, +and the RHS is the updated formatting function.} + +\item{rows}{predicate expression to select rows in \code{x$table_body}. +Default is \code{NULL}. See details below.} +} +\description{ +\lifecycle{maturing} +Use this function to update the way numeric columns and rows of \code{.$table_body} +are formatted +} +\section{rows argument}{ + +The rows argument accepts a predicate expression that is used to specify +rows to apply formatting. The expression must evaluate to a logical when +evaluated in \code{x$table_body}. For example, to apply formatting to the age rows +pass \code{rows = variable == "age"}. A vector of row numbers is NOT acceptable. + +A couple of things to note when using the \verb{rows=} argument. +\enumerate{ +\item You can use saved objects to create the predicate argument, e.g. +\code{rows = variable == letters[1]}. +\item The saved object cannot share a name with a column in \code{x$table_body}. +The reason for this is that in \code{tbl_merge()} the columns are renamed, +and the renaming process cannot disambiguate the \code{variable} column from +an external object named \code{variable} in the following expression +\code{rows = .data$variable = .env$variable}. +} +} + +\seealso{ +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary + +Other Advanced modifiers: +\code{\link{modify_column_hide}()}, +\code{\link{modify_table_styling}()} +} +\concept{Advanced modifiers} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 6766975059..8b364720c0 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -123,6 +123,7 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: -\code{\link{modify_column_hide}()} +\code{\link{modify_column_hide}()}, +\code{\link{modify_fmt_fun}()} } \concept{Advanced modifiers} diff --git a/man/reexports.Rd b/man/reexports.Rd index 961ee93734..2b26cf0dfe 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -16,6 +16,7 @@ \alias{any_of} \alias{everything} \alias{last_col} +\alias{where} \alias{one_of} \alias{vars} \title{Objects exported from other packages} @@ -25,6 +26,6 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{as_tibble}}, \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]{mutate}}, \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{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{as_tibble}}, \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]{mutate}}, \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}}, \code{\link[dplyr:reexports]{where}}} }} diff --git a/man/select_helpers.Rd b/man/select_helpers.Rd index 0fd5476576..5e79e3f0b6 100644 --- a/man/select_helpers.Rd +++ b/man/select_helpers.Rd @@ -6,11 +6,7 @@ \alias{all_continuous2} \alias{all_categorical} \alias{all_dichotomous} -\alias{all_tests} \alias{all_stat_cols} -\alias{all_interaction} -\alias{all_intercepts} -\alias{all_contrasts} \title{Select helper functions} \usage{ all_continuous(continuous2 = TRUE) @@ -21,15 +17,7 @@ all_categorical(dichotomous = TRUE) all_dichotomous() -all_tests(tests = NULL) - all_stat_cols(stat_0 = TRUE) - -all_interaction() - -all_intercepts() - -all_contrasts(contrasts_type = NULL) } \arguments{ \item{continuous2}{Logical indicating whether to include continuous2 variables. Default is \code{TRUE}} @@ -37,14 +25,7 @@ all_contrasts(contrasts_type = NULL) \item{dichotomous}{Logical indicating whether to include dichotomous variables. Default is \code{TRUE}} -\item{tests}{string indicating the test type of the variables to select, e.g. -select all variables being compared with \code{"t.test"}} - \item{stat_0}{When \code{FALSE}, will not select the \code{"stat_0"} column. Default is \code{TRUE}} - -\item{contrasts_type}{type of contrast to select. When \code{NULL}, all variables with a -contrast will be selected. Default is \code{NULL}. Select among contrast types -\code{c("treatment", "sum", "poly", "helmert", "other")}} } \value{ A character vector of column names selected @@ -64,15 +45,6 @@ functions for selecting columns of data frames (and other items as well). \item \code{all_contrasts()} selects variables in regression model based on their type of contrast } } -\examples{ -select_ex1 <- - trial \%>\% - select(age, response, grade) \%>\% - tbl_summary( - statistic = all_continuous() ~ "{mean} ({sd})", - type = all_dichotomous() ~ "categorical" - ) -} \seealso{ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index f4bc034a2f..efadc0fac0 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -8,16 +8,16 @@ tbl_summary( data, by = NULL, label = NULL, - statistic = NULL, + statistic = list(all_continuous() ~ "{mean} ({sd})", all_categorical() ~ "{n} ({p}\%)"), digits = NULL, - type = NULL, + type = assign_summary_type(data, include, value), value = NULL, missing = c("ifany", "no", "always"), missing_text = "Unknown", missing_stat = "{N_miss}", - sort = NULL, + sort = all_categorical() ~ "alphanumeric", percent = c("column", "row", "cell"), - include = c(everything(), -by) + include = everything() ) } \arguments{ @@ -57,6 +57,7 @@ Title tbl <- tbl_summary( data = mtcars, + include = c("cyl", "am", "mpg", "hp"), type = list( cyl = "categorical", From 2ce0d5008d0338abdadf827e1bdf9f1553fbe0e0 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 1 Dec 2023 09:57:24 -0800 Subject: [PATCH 05/74] GH Action workflow updates (#1574) * updates * more updates * Update test-coverage.yaml * Update pull_request_template.md * updates * updates --- ...t_template.md => PULL_REQUEST_TEMPLATE.md} | 12 +-- .../R-CMD-check-historic-R-versions.yaml | 94 ------------------- .github/workflows/R-CMD-check.yaml | 36 +++---- .github/workflows/close.yaml | 20 ---- .github/workflows/continuous-benchmarks.txt | 52 ---------- .github/workflows/pkgdown.yaml | 8 +- .github/workflows/pr-commands.yaml | 22 +++-- .github/workflows/test-coverage.yaml | 80 ++++++++++------ _archive/README.Rmd | 3 +- codecov.yml | 14 +++ 10 files changed, 98 insertions(+), 243 deletions(-) rename .github/{pull_request_template.md => PULL_REQUEST_TEMPLATE.md} (58%) delete mode 100644 .github/workflows/R-CMD-check-historic-R-versions.yaml delete mode 100644 .github/workflows/close.yaml delete mode 100644 .github/workflows/continuous-benchmarks.txt create mode 100644 codecov.yml diff --git a/.github/pull_request_template.md b/.github/PULL_REQUEST_TEMPLATE.md similarity index 58% rename from .github/pull_request_template.md rename to .github/PULL_REQUEST_TEMPLATE.md index 3688a6414e..2fa240b1e5 100644 --- a/.github/pull_request_template.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -8,20 +8,16 @@ Reviewer Checklist (if item does not apply, mark is as complete) -- [ ] Ensure all package dependencies are installed by running `renv::install()` -- [ ] PR branch has pulled the most recent updates from master branch. Ensure the pull request branch and your local version match and both have the latest updates from the master branch. -- [ ] If an update was made to `tbl_summary()`, was the same change implemented for `tbl_svysummary()`? -- [ ] 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 +- [ ] Ensure all package dependencies are installed: `renv::install()` +- [ ] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()` +- [ ] If a bug was fixed, a unit test was added. - [ ] 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 `withr::with_envvar(new = c("NOT_CRAN" = "true"), covr::report())`. Begin in a fresh R session without any packages loaded. -- [ ] R CMD Check runs without errors, warnings, and notes +- [ ] Code coverage is suitable for any new functions/features: `devtools::test_coverage()` - [ ] `usethis::use_spell_check()` runs with no spelling errors in documentation When the branch is ready to be merged into master: - [ ] Update `NEWS.md` 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 parentheses at the end update (see `NEWS.md` for examples). - [ ] Increment the version number using `usethis::use_version(which = "dev")` -- [ ] Run `codemetar::write_codemeta()` - [ ] Run `usethis::use_spell_check()` again - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge". diff --git a/.github/workflows/R-CMD-check-historic-R-versions.yaml b/.github/workflows/R-CMD-check-historic-R-versions.yaml deleted file mode 100644 index 71922c60b3..0000000000 --- a/.github/workflows/R-CMD-check-historic-R-versions.yaml +++ /dev/null @@ -1,94 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions -on: - push: - branches: - - main - - master - pull_request: - branches: - - main - - master - -name: R-CMD-historic-R-check - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: ubuntu-latest, r: 'oldrel-2'} - - {os: ubuntu-latest, r: 'oldrel-3'} - # - {os: ubuntu-latest, r: 'oldrel-4'} - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v2 - - # installing nlopt for R versions less than 3.6 - # this is for the installation of nloptr package required for lme4 - - name: Install nlopt on Linux - if: runner.os == 'Linux' - run: sudo apt-get install pkg-config libnlopt-dev - - - name: Query dependencies - run: | - install.packages('remotes', repos = 'http://cran.rstudio.com') - saveRDS(remotes::dev_package_deps(dependencies = TRUE, repos = 'http://cran.rstudio.com'), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - if: runner.os != 'Windows' - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-2-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-2- - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - sudo apt-get update -y - sudo apt-get install -y texlive-fonts-extra - sudo apt-get install -y libcurl4-openssl-dev - - - name: Install dependencies - run: | - remotes::install_cran("curl", repos = 'https://packagemanager.posit.co/cran/latest') # added this because curl install was failing from CRAN, hopeing this uses the binaries available from RSPM - remotes::install_deps(dependencies = TRUE, repos = 'http://cran.rstudio.com') - remotes::install_cran("rcmdcheck", repos = 'http://cran.rstudio.com') - shell: Rscript {0} - - - name: Check - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - _R_CHECK_FORCE_SUGGESTS_: false - run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 5c626acd2f..1fe123e906 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -1,4 +1,4 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help # # NOTE: This workflow is overkill for most R packages and @@ -8,7 +8,7 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] + # branches: [main, master] name: R-CMD-check @@ -22,15 +22,16 @@ jobs: fail-fast: false matrix: config: - - {os: macOS-latest, r: 'release'} + - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} + # use 4.1 to check with rtools40's older compiler + - {os: windows-latest, r: '4.1'} - # Use older ubuntu to maximise backward compatibility - # - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'oldrel-1'} - # - {os: ubuntu-latest, r: 'oldrel-2'} + - {os: ubuntu-latest, r: 'oldrel-2'} # - {os: ubuntu-latest, r: 'oldrel-3'} # - {os: ubuntu-latest, r: 'oldrel-4'} @@ -39,7 +40,7 @@ jobs: R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-pandoc@v2 @@ -51,24 +52,9 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: rcmdcheck - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - sudo apt-get update -y - sudo apt-get install -y texlive-fonts-extra + extra-packages: any::rcmdcheck + needs: check - uses: r-lib/actions/check-r-package@v2 - - - name: Show testthat output - if: always() - run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true - shell: bash - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check + upload-snapshots: true diff --git a/.github/workflows/close.yaml b/.github/workflows/close.yaml deleted file mode 100644 index 0ab93f0d91..0000000000 --- a/.github/workflows/close.yaml +++ /dev/null @@ -1,20 +0,0 @@ -name: 'Close stale issues and PRs' -on: - schedule: - - cron: '0 0 * * *' - -jobs: - stale: - runs-on: ubuntu-latest - steps: - - uses: actions/stale@v3 - with: - days-before-stale: 365 - stale-issue-label: 'stale issue' - stale-pr-label: 'stale pull request' - stale-issue-message: 'This issue has been automatically closed due to inactivity.' - stale-pr-message: 'This pull request has been automatically closed due to inactivity.' - days-before-close: 14 - exempt-assignees: 'ddsjoberg,larmarange,emilyvertosick,jalavery,karissawhiting,larmarange,michaelcurry1123,shannonpileggi,zabore' - exempt-issue-labels: 'waiting,hackathon,help wanted' - exempt-all-milestones: true diff --git a/.github/workflows/continuous-benchmarks.txt b/.github/workflows/continuous-benchmarks.txt deleted file mode 100644 index 7aa1919797..0000000000 --- a/.github/workflows/continuous-benchmarks.txt +++ /dev/null @@ -1,52 +0,0 @@ -# on: -# push: -# pull_request: -# -# name: Benchmark -# -# jobs: -# build: -# runs-on: macOS-latest -# steps: -# - name: Checkout repo -# uses: actions/checkout@master -# -# - name: Setup R -# uses: r-lib/actions/setup-r@master -# -# - name: Query dependencies -# run: | -# install.packages('remotes') -# saveRDS(remotes::dev_package_deps(dependencies = c("Depends", "Imports")), ".github/bench_depends.Rds", version = 2) -# writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") -# shell: Rscript {0} -# -# - name: Cache R packages -# uses: actions/cache@v1 -# with: -# path: ${{ env.R_LIBS_USER }} -# key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/bench_depends.Rds') }} -# restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- -# -# - name: Install dependencies -# run: | -# install.packages(c('devtools', 'microbenchmark', 'here', 'gert', 'usethis', 'lubridate', 'readr', 'ggplot2', 'rmarkdown', 'knitr')) -# remotes::install_deps(dependencies = c("Depends", "Imports")) # don't need suggests to run most fns -# shell: Rscript {0} -# -# - name: Install Pandoc -# uses: r-lib/actions/setup-pandoc@9598b8eeb6d88de7d76d580d84443542bbfdffce -# with: -# pandoc-version: 2.11.1.1 -# -# - name: Build RMD REPORT -# run: | -# Rscript -e 'rmarkdown::render(input = here::here("benchmark/README.Rmd"), output_file = here::here("benchmark/README.md"), clean = TRUE, output_format = "md_document")' -# -# - name: Commit files -# run: | -# git config --global user.email "ghau@example.com" -# git config --global user.name "GitHub Actions User" -# git add --all -# git commit -am "continous benchmark autocommit" -# git push diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 0b2602168b..d629ecbda7 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -4,7 +4,7 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] + # branches: [main, master] release: types: [published] workflow_dispatch: @@ -19,8 +19,10 @@ jobs: group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-pandoc@v2 @@ -39,7 +41,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@4.1.4 + uses: JamesIves/github-pages-deploy-action@v4.4.1 with: clean: false branch: gh-pages diff --git a/.github/workflows/pr-commands.yaml b/.github/workflows/pr-commands.yaml index 98ca228bce..71f335b3ea 100644 --- a/.github/workflows/pr-commands.yaml +++ b/.github/workflows/pr-commands.yaml @@ -1,4 +1,4 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: issue_comment: @@ -8,13 +8,13 @@ name: Commands jobs: document: - if: startsWith(github.event.comment.body, '/document') + if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} name: document runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/pr-fetch@v2 with: @@ -26,10 +26,12 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: roxygen2 + extra-packages: any::roxygen2 + needs: pr-document - name: Document - run: Rscript -e 'roxygen2::roxygenise()' + run: roxygen2::roxygenise() + shell: Rscript {0} - name: commit run: | @@ -43,13 +45,13 @@ jobs: repo-token: ${{ secrets.GITHUB_TOKEN }} style: - if: startsWith(github.event.comment.body, '/style') + if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} name: style runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/pr-fetch@v2 with: @@ -58,10 +60,12 @@ jobs: - uses: r-lib/actions/setup-r@v2 - name: Install dependencies - run: Rscript -e 'install.packages("styler")' + run: install.packages("styler") + shell: Rscript {0} - name: Style - run: Rscript -e 'styler::style_pkg()' + run: styler::style_pkg() + shell: Rscript {0} - name: commit run: | diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 4b01af7586..6a1bcbbeee 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,30 +1,50 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/master/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - -name: test-coverage - -jobs: - test-coverage: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: covr - - - name: Test coverage - run: covr::codecov() - shell: Rscript {0} +# # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +# on: +# push: +# branches: [main, master] +# pull_request: +# branches: [main, master] +# +# name: test-coverage +# +# jobs: +# test-coverage: +# runs-on: ubuntu-latest +# env: +# GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} +# +# steps: +# - uses: actions/checkout@v3 +# +# - uses: r-lib/actions/setup-r@v2 +# with: +# use-public-rspm: true +# +# - uses: r-lib/actions/setup-r-dependencies@v2 +# with: +# extra-packages: any::covr +# needs: coverage +# +# - name: Test coverage +# run: | +# covr::codecov( +# quiet = FALSE, +# clean = FALSE, +# install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") +# ) +# shell: Rscript {0} +# +# - name: Show testthat output +# if: always() +# run: | +# ## -------------------------------------------------------------------- +# find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true +# shell: bash +# +# - name: Upload test results +# if: failure() +# uses: actions/upload-artifact@v3 +# with: +# name: coverage-test-failures +# path: ${{ runner.temp }}/package diff --git a/_archive/README.Rmd b/_archive/README.Rmd index d9e8896bd8..253450b350 100644 --- a/_archive/README.Rmd +++ b/_archive/README.Rmd @@ -15,8 +15,7 @@ knitr::opts_chunk$set( ``` -[![R-CMD-check](https://github.com/ddsjoberg/gtsummary/workflows/R-CMD-check/badge.svg)](https://github.com/ddsjoberg/gtsummary/actions) -[![CRAN status](https://www.r-pkg.org/badges/version/gtsummary)](https://cran.r-project.org/package=gtsummary) +[![R-CMD-check](https://github.com/ddsjoberg/gtsummary/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/ddsjoberg/gtsummary/actions/workflows/R-CMD-check.yaml)[![CRAN status](https://www.r-pkg.org/badges/version/gtsummary)](https://cran.r-project.org/package=gtsummary) [![Codecov test coverage](https://codecov.io/gh/ddsjoberg/gtsummary/branch/main/graph/badge.svg)](https://app.codecov.io/gh/ddsjoberg/gtsummary?branch=main) [![](https://cranlogs.r-pkg.org/badges/gtsummary)](https://cran.r-project.org/package=gtsummary) [![DOI:10.32614/RJ-2021-053](https://zenodo.org/badge/DOI/10.32614/RJ-2021-053.svg)](https://doi.org/10.32614/RJ-2021-053) diff --git a/codecov.yml b/codecov.yml new file mode 100644 index 0000000000..04c5585990 --- /dev/null +++ b/codecov.yml @@ -0,0 +1,14 @@ +comment: false + +coverage: + status: + project: + default: + target: auto + threshold: 1% + informational: true + patch: + default: + target: auto + threshold: 1% + informational: true From 7ae09aea93367c4f846f34117702f99929a4884a Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 1 Dec 2023 10:11:45 -0800 Subject: [PATCH 06/74] Update NEWS.md --- NEWS.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index e92bcf0a3e..26ad87aa37 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,8 @@ # gtsummary (development version) -## Overview of Changes in v2.0 +### Overview of Changes -### User-facing Updates +#### User-facing Updates * The counts in the header of `tbl_summary(by)` tables now appear on a new line. @@ -10,15 +10,15 @@ * Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be explicitly defined in a factor. -### Internal Updates +#### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. -## Bug Fixes +### Bug Fixes * Fix in `add_difference()` for paired t-tests. Previously, the sign of the reported difference depended on which group appeared first in the source data. Function has been updated to consistently report the difference as the first group mean minus the second group mean. (#1557) -## Deprecations +### Deprecations * Global options have been deprecated in gtsummary since v1.3.1 (3.5 years ago). They have now been fully removed from the package. From dea17ad3c9cfb82f0fab6e6c58d0abdbc36aa575 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 3 Dec 2023 09:33:25 -0800 Subject: [PATCH 07/74] Assign digits (#1575) * in progress * progress --- DESCRIPTION | 2 +- NAMESPACE | 10 +++ NEWS.md | 2 + R/assign_summary_digits.R | 132 ++++++++++++++++++++++++++++++++------ R/modify_column_hide.R | 2 +- R/select_helpers.R | 2 +- R/styfn.R | 47 ++++++++++++++ R/style_number.R | 59 +++++++++++++++++ R/style_percent.R | 34 ++++++++++ R/style_pvalue.R | 112 ++++++++++++++++++++++++++++++++ R/style_ratio.R | 38 +++++++++++ R/style_sigfig.R | 51 +++++++++++++++ R/tbl_summary.R | 17 +++-- R/utils-as.R | 2 +- man/styfn.Rd | 57 ++++++++++++++++ man/style_number.Rd | 52 +++++++++++++++ man/style_percent.Rd | 59 +++++++++++++++++ man/style_pvalue.Rd | 61 ++++++++++++++++++ man/style_ratio.Rd | 54 ++++++++++++++++ man/style_sigfig.Rd | 73 +++++++++++++++++++++ man/tbl_summary.Rd | 2 +- 21 files changed, 839 insertions(+), 29 deletions(-) create mode 100644 R/styfn.R create mode 100644 R/style_number.R create mode 100644 R/style_percent.R create mode 100644 R/style_pvalue.R create mode 100644 R/style_ratio.R create mode 100644 R/style_sigfig.R create mode 100644 man/styfn.Rd create mode 100644 man/style_number.Rd create mode 100644 man/style_percent.Rd create mode 100644 man/style_pvalue.Rd create mode 100644 man/style_ratio.Rd create mode 100644 man/style_sigfig.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 59407419c5..2a42a98a9c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -44,7 +44,7 @@ URL: https://github.com/ddsjoberg/gtsummary, BugReports: https://github.com/ddsjoberg/gtsummary/issues Imports: broom.helpers, - cards (>= 0.0.0.9002), + cards (>= 0.0.0.9003), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/NAMESPACE b/NAMESPACE index 9f27f52559..6a8cfdeab0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,16 @@ export(pier_summary_dichotomous) export(pier_summary_missing_row) export(select) export(starts_with) +export(styfn_number) +export(styfn_percent) +export(styfn_pvalue) +export(styfn_ratio) +export(styfn_sigfig) +export(style_number) +export(style_percent) +export(style_pvalue) +export(style_ratio) +export(style_sigfig) export(tbl_summary) export(vars) export(where) diff --git a/NEWS.md b/NEWS.md index 26ad87aa37..6fecdcc0ad 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,8 @@ * If a column is all `NA` it is now removed from the summary table created with `tbl_summary()`. +* Added a family of function `styfn_*()` that are similar to the `style_*()` except they return a styling _function_, rather than a styled value. + * Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be explicitly defined in a factor. #### Internal Updates diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index 57d77736df..cbebcb11a8 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -1,20 +1,116 @@ -# assign_summary_digits <- function(data, statistic, type, digits = NULL) { -# # extract the statistics -# statistic <- lapply(statistic, function(x) .extract_glue_elements(x) |> unlist()) -# -# lapply( -# names(statistic), -# function(variable) { -# if (!is.null(digits[[variable]])){ -# return(rep_named(statistic[[variable]], digits[[variable]])) -# } -# -# if (type[[variable]] %in% c("cateogrical", "dichotomous")) { -# -# } -# } -# ) -# -# } +assign_summary_digits <- function(data, statistic, type, digits = NULL) { + # stats returned for all variables + lst_cat_summary_fns <- .categorical_summary_functions(c("n", "p")) + lst_all_fmt_fns <- .categorical_summary_functions() + + # extract the statistics + statistic <- lapply(statistic, function(x) .extract_glue_elements(x) |> unlist()) + + lapply( + names(statistic), + function(variable) { + # if user passed digits AND they've specified every statistic, use the passed value + # otherwise, we need to calculate the defaults, and later we can update with the pieces the user passed + if (!is.null(digits[[variable]])) { + # if a scalar or vector passed, convert it to a list + if (!is.list(digits[[variable]]) && is_vector(digits[[variable]])) { + digits[[variable]] <- as.list(digits[[variable]]) + } + + # if user-passed value is not named, repeat the passed value to the length of 'statistic' + if (!is_named(digits[[variable]])) { + digits[[variable]] <- rep_named(statistic[[variable]], digits[[variable]]) + } + + # convert integers to a proper function + digits[[variable]] <- .convert_integer_to_fmt_fn(digits[[variable]]) + + # if the passed value fully specifies the formatting for each 'statistic', + # then return it. Otherwise, the remaining stat will be filled below + if (setequal(statistic[[variable]], names(digits[[variable]]))) { + return(digits[[variable]]) + } + } + + if (type[[variable]] %in% c("categorical", "dichotomous")) { + return( + c(lst_cat_summary_fns, lst_all_fmt_fns) |> + utils::modifyList(digits[[variable]] %||% list()) + ) + } + + if (type[[variable]] %in% c("continuous", "continuous2")) { + return( + rep_named( + statistic[[variable]], + list(.guess_continuous_summary_digits(data[[variable]])) + ) |> + utils::modifyList(lst_all_fmt_fns) |> + utils::modifyList(digits[[variable]] %||% list()) + ) + } + } + ) |> + stats::setNames(names(statistic)) +} + +.convert_integer_to_fmt_fn <- function(x) { + imap( + x, + function(value, stat_name) { + # if not an integer, simply return the value + if (!is_integerish(value)) return(value) + # if an integer is passed for a percentage, process stat with style_percent() + if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) + return(styfn_percent(digits = value)) + # otherwise, use style_numer() to style number + return(styfn_number(digits = value)) + } + ) +} + +.guess_continuous_summary_digits <- function(x) { + # if all missing, return 0 + if (all(is.na(x))) return(styfn_number(digits = 0L)) + + # if class is integer, then round everything to nearest integer + if (inherits(x, "integer")) { + return(styfn_number(digits = 0L)) + } + + # otherwise guess the number of dignits to use based on the spread + # calculate the spread of the variable + var_spread <- + stats::quantile(x, probs = c(0.95), na.rm = TRUE) - + stats::quantile(x, probs = c(0.05), na.rm = TRUE) + + styfn_number( + digits = + dplyr::case_when( + var_spread < 0.01 ~ 4L, + var_spread >= 0.01 & var_spread < 0.1 ~ 3L, + var_spread >= 0.1 & var_spread < 10 ~ 2L, + var_spread >= 10 & var_spread < 20 ~ 1L, + var_spread >= 20 ~ 0L + ) + ) +} + +.categorical_summary_functions <- + function(statistics = c(" + N", "N_obs", "N_miss", "N_nonmiss", "n_unweighted", "N_unweighted", + "p_miss", "p_nonmiss", "p_unweighted")) { + lst_defaults <- + c( + c("n", "N", "N_obs", "N_miss", "N_nonmiss", "n_unweighted", "N_unweighted") |> + intersect(statistics) |> + rep_named(list(styfn_number())), + c("p", "p_miss", "p_nonmiss", "p_unweighted") |> + intersect(statistics) |> + rep_named(list(styfn_percent())) + ) + + lst_defaults + } diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index cfb0b3c170..ab81975dff 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -7,7 +7,7 @@ #' #' @name modify_column_hide #' @family Advanced modifiers -#' @examples +# #' @examples # #' \donttest{ # #' # Example 1 ---------------------------------- # #' # hide 95% CI, and replace with standard error diff --git a/R/select_helpers.R b/R/select_helpers.R index 6fca53ffdc..279428bc5c 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -23,7 +23,7 @@ #' @name select_helpers #' @return A character vector of column names selected #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary -#' @examples +# #' @examples # #' select_ex1 <- # #' trial %>% # #' select(age, response, grade) %>% diff --git a/R/styfn.R b/R/styfn.R new file mode 100644 index 0000000000..e49d7aab54 --- /dev/null +++ b/R/styfn.R @@ -0,0 +1,47 @@ +#' Style Functions +#' +#' Similar to the `style_*()` family of functions, but these functions return +#' a `style_*()` **function** rather than performing the styling. +#' +#' @param digits,big.mark,decimal.mark,scale,prepend_p,symbol,... arguments +#' passed to the `style_*()` functions +#' +#' @return a function +#' @name styfn +#' @family style tools +#' +#' @examples +#' my_style <- styfn_number(digits = 1) +#' my_style(3.14) +NULL + +#' @rdname styfn +#' @export +styfn_number <- function(digits = 0, big.mark = NULL, decimal.mark = NULL, scale = 1, ...) { + function(x) style_number(x, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, scale = scale, ...) +} + +#' @rdname styfn +#' @export +styfn_sigfig <- function(digits = 2, scale = 1, big.mark = NULL, decimal.mark = NULL, ...) { + function(x) style_sigfig(x, digits = digits, scale = scale, big.mark = big.mark, decimal.mark = decimal.mark, ...) +} + +#' @rdname styfn +#' @export +styfn_pvalue <- function(digits = 1, prepend_p = FALSE, big.mark = NULL, decimal.mark = NULL, ...) { + function(x) styfn_pvalue(x, digits = digits, prepend_p = prepend_p, big.mark = big.mark, decimal.mark = decimal.mark, ...) +} + +#' @rdname styfn +#' @export +styfn_ratio <- function(digits = 2, big.mark = NULL, decimal.mark = NULL, ...) { + function(x) style_ratio(x, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...) +} + +#' @rdname styfn +#' @export +styfn_percent <- function(symbol = FALSE, digits = 0, big.mark = NULL, decimal.mark = NULL, ...) { + function(x) style_percent(x, symbol = symbol, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...) +} + diff --git a/R/style_number.R b/R/style_number.R new file mode 100644 index 0000000000..6181076943 --- /dev/null +++ b/R/style_number.R @@ -0,0 +1,59 @@ +#' Style numbers +#' +#' @param x Numeric vector +#' @param digits Integer or vector of integers specifying the number of decimals +#' to round `x=`. When vector is passed, each integer is mapped 1:1 to the +#' numeric values in `x` +#' @param big.mark Character used between every 3 digits to separate +#' hundreds/thousands/millions/etc. +#' Default is `","`, except when `decimal.mark = ","` when the default is a space. +#' @param decimal.mark The character to be used to indicate the numeric decimal point. +#' Default is `"."` or `getOption("OutDec")` +#' @param scale A scaling factor: x will be multiplied by scale before formatting. +#' @param ... Other arguments passed on to `base::format()` +#' +#' @return formatted character vector +#' @export +#' @family style tools +#' @examples +#' c(0.111, 12.3) %>% style_number(digits = 1) +#' c(0.111, 12.3) %>% style_number(digits = c(1, 0)) +style_number <- function(x, digits = 0, big.mark = NULL, decimal.mark = NULL, + scale = 1, ...) { + # setting defaults ----------------------------------------------------------- + decimal.mark <- + decimal.mark %||% + get_theme_element("style_number-arg:decimal.mark", + default = getOption("OutDec", default = ".") + ) + big.mark <- + big.mark %||% + get_theme_element("style_number-arg:big.mark", + # if decimal is a comma, then making big.mark a thin space, otherwise a comma + default = ifelse(identical(decimal.mark, ","), "\U2009", ",") + ) + + digits <- rep(digits, length.out = length(x)) + + ret <- + map2_chr( + x, digits, + function(.x, .y) { + round2(.x * scale, digits = .y) %>% + format( + big.mark = big.mark, decimal.mark = decimal.mark, nsmall = .y, + scientific = FALSE, trim = TRUE, ... + ) + } + ) + ret[is.na(x)] <- NA_character_ + attributes(ret) <- attributes(unclass(x)) + + ret +} + +# this function assures that 5s are rounded up (and not to even, the default in `round()`) +# code taken from https://github.com/sfirke/janitor/blob/main/R/round_half_up.R +round2 <- function(x, digits = 0) { + trunc(abs(x) * 10 ^ digits + 0.5 + sqrt(.Machine$double.eps)) / 10 ^ digits * sign(as.numeric(x)) +} diff --git a/R/style_percent.R b/R/style_percent.R new file mode 100644 index 0000000000..b0c1cb075d --- /dev/null +++ b/R/style_percent.R @@ -0,0 +1,34 @@ +#' Style percentages +#' +#' @param x numeric vector of percentages +#' @param digits number of digits to round large percentages (i.e. greater than 10%). +#' Smaller percentages are rounded to `digits + 1` places. +#' Default is `0` +#' @param symbol Logical indicator to include percent symbol in output. +#' Default is `FALSE`. +#' @inheritParams style_number +#' @export +#' @return A character vector of styled percentages +#' @family style tools +#' @seealso See Table Gallery \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{vignette} for example +#' @author Daniel D. Sjoberg +#' @examples +#' percent_vals <- c(-1, 0, 0.0001, 0.005, 0.01, 0.10, 0.45356, 0.99, 1.45) +#' style_percent(percent_vals) +#' style_percent(percent_vals, symbol = TRUE, digits = 1) +style_percent <- function(x, symbol = FALSE, digits = 0, big.mark = NULL, decimal.mark = NULL, ...) { + y <- dplyr::case_when( + x * 100 >= 10 ~ style_number(x * 100, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...), + x * 100 >= 10^(-(digits + 1)) ~ style_number(x * 100, digits = digits + 1, big.mark = big.mark, decimal.mark = decimal.mark, ...), + x > 0 ~ paste0("<", style_number( + x = 10^(-(digits + 1)), digits = digits + 1, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )), + x == 0 ~ "0" + ) + + # adding percent symbol if requested + if (symbol == TRUE) y <- ifelse(!is.na(y), paste0(y, "%"), y) + attributes(y) <- attributes(unclass(x)) + return(y) +} diff --git a/R/style_pvalue.R b/R/style_pvalue.R new file mode 100644 index 0000000000..1a634737d8 --- /dev/null +++ b/R/style_pvalue.R @@ -0,0 +1,112 @@ +#' Style p-values +#' +#' @param x Numeric vector of p-values. +#' @param digits Number of digits large p-values are rounded. Must be 1, 2, or 3. +#' Default is 1. +#' @param prepend_p Logical. Should 'p=' be prepended to formatted p-value. +#' Default is `FALSE` +#' @inheritParams style_number +#' @export +#' @return A character vector of styled p-values +#' @family style tools +#' @seealso See tbl_summary \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{vignette} for examples +#' @author Daniel D. Sjoberg +#' @examples +#' pvals <- c( +#' 1.5, 1, 0.999, 0.5, 0.25, 0.2, 0.197, 0.12, 0.10, 0.0999, 0.06, +#' 0.03, 0.002, 0.001, 0.00099, 0.0002, 0.00002, -1 +#' ) +#' style_pvalue(pvals) +#' style_pvalue(pvals, digits = 2, prepend_p = TRUE) +style_pvalue <- function(x, digits = 1, prepend_p = FALSE, + big.mark = NULL, decimal.mark = NULL, ...) { + # rounding large p-values to 1 digits + if (digits == 1) { + p_fmt <- + dplyr::case_when( + # allowing some leeway for numeric storage errors + x > 1 + 1e-15 ~ NA_character_, + x < 0 - 1e-15 ~ NA_character_, + x > 0.9 ~ paste0(">", style_number( + x = 0.9, digits = 1, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )), + round2(x, 1) >= 0.2 ~ style_number(x, + digits = 1, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + round2(x, 2) >= 0.1 ~ style_number(x, + digits = 2, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + x >= 0.001 ~ style_number(x, + digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + x < 0.001 ~ paste0("<", style_number( + x = 0.001, digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )) + ) + } + # rounding large p-values to 2 digits + else if (digits == 2) { + p_fmt <- + dplyr::case_when( + x > 1 + 1e-15 ~ NA_character_, + x < 0 - 1e-15 ~ NA_character_, + x > 0.99 ~ paste0(">", style_number( + x = 0.99, digits = 2, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )), + round2(x, 2) >= 0.1 ~ style_number(x, + digits = 2, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + x >= 0.001 ~ style_number(x, + digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + x < 0.001 ~ paste0("<", style_number( + x = 0.001, digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )) + ) + } + + # rounding large pvalues to 3 digit + else if (digits == 3) { + p_fmt <- + dplyr::case_when( + x > 1 + 1e-15 ~ NA_character_, + x < 0 - 1e-15 ~ NA_character_, + x > 0.999 ~ paste0(">", style_number( + x = 0.999, digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )), + x >= 0.001 ~ style_number(x, + digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + ), + x < 0.001 ~ paste0("<", style_number( + x = 0.001, digits = 3, big.mark = big.mark, + decimal.mark = decimal.mark, ... + )) + ) + } else { + stop("The `digits=` argument must be 1, 2, or 3.") + } + + # prepending a p = in front of value + if (prepend_p == TRUE) { + p_fmt <- dplyr::case_when( + is.na(p_fmt) ~ NA_character_, + grepl(pattern = "<|>", x = p_fmt) ~ paste0("p", p_fmt), + # stringr::str_sub(p_fmt, end = 1L) %in% c("<", ">") ~ paste0("p", p_fmt), + TRUE ~ paste0("p=", p_fmt) + ) + } + + attributes(p_fmt) <- attributes(unclass(x)) + return(p_fmt) +} diff --git a/R/style_ratio.R b/R/style_ratio.R new file mode 100644 index 0000000000..7d472b8464 --- /dev/null +++ b/R/style_ratio.R @@ -0,0 +1,38 @@ +#' Style significant figure-like rounding for ratios +#' +#' When reporting ratios, such as relative risk or an odds ratio, we'll often +#' want the rounding to be similar on each side of the number 1. For example, +#' if we report an odds ratio of 0.95 with a confidence interval of 0.70 to 1.24, +#' we would want to round to two decimal places for all values. In other words, +#' 2 significant figures for numbers less than 1 and 3 significant figures 1 and +#' larger. `style_ratio()` performs significant figure-like rounding in this manner. +#' +#' @param x Numeric vector +#' @param digits Integer specifying the number of significant +#' digits to display for numbers below 1. Numbers larger than 1 will be be `digits + 1`. +#' Default is `digits = 2`. +#' @inheritParams style_number +#' @export +#' @return A character vector of styled ratios +#' @family style tools +#' @author Daniel D. Sjoberg +#' @examples +#' c( +#' 0.123, 0.9, 1.1234, 12.345, 101.234, -0.123, +#' -0.9, -1.1234, -12.345, -101.234 +#' ) %>% +#' style_ratio() +style_ratio <- function(x, digits = 2, big.mark = NULL, decimal.mark = NULL, ...) { + x_fmt <- + dplyr::case_when( + round2(abs(x), digits = digits) < 1 ~ + style_sigfig(x, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...), + x > 0 ~ + style_sigfig(pmax(1, x), digits = digits + 1, big.mark = big.mark, decimal.mark = decimal.mark, ...), + x < 0 ~ + style_sigfig(pmin(-1, x), digits = digits + 1, big.mark = big.mark, decimal.mark = decimal.mark, ...), + ) + + attributes(x_fmt) <- attributes(unclass(x)) + x_fmt +} diff --git a/R/style_sigfig.R b/R/style_sigfig.R new file mode 100644 index 0000000000..3d7a4808d5 --- /dev/null +++ b/R/style_sigfig.R @@ -0,0 +1,51 @@ +#' Style significant figure-like rounding +#' +#' Converts a numeric argument into a string that has been rounded to a +#' significant figure-like number. Scientific notation output +#' is avoided, however, and additional significant figures may be displayed for +#' large numbers. For example, if the number of significant digits +#' requested is 2, 123 will be displayed (rather than 120 or 1.2x10^2). +#' +#' @section Details: +#' +#' - Scientific notation output is avoided. +#' +#' - If 2 significant figures are requested, the number is rounded to no more than 2 decimal places. +#' For example, a number will be rounded to 2 decimals places when `abs(x) < 1`, +#' 1 decimal place when `abs(x) >= 1 & abs(x) < 10`, +#' and to the nearest integer when `abs(x) >= 10`. +#' +#' - Additional significant figures +#' may be displayed for large numbers. For example, if the number of +#' significant digits requested is 2, +#' 123 will be displayed (rather than 120 or 1.2x10^2). +#' +#' @param x Numeric vector +#' @param digits Integer specifying the minimum number of significant +#' digits to display +#' @inheritParams style_number +#' @export +#' @return A character vector of styled numbers +#' @family style tools +#' @author Daniel D. Sjoberg +#' @examples +#' c(0.123, 0.9, 1.1234, 12.345, -0.123, -0.9, -1.1234, -132.345, NA, -0.001) %>% +#' style_sigfig() +style_sigfig <- function(x, digits = 2, scale = 1, big.mark = NULL, decimal.mark = NULL, ...) { + # calculating the number of digits to round number + d <- + paste0( + "round2(abs(x * scale), digits = ", digits:1 + 1L, ") ", + "< 10^(", 1:digits - 1, ") - 0.5 * 10^(", -(digits:1), ") ~ ", digits:1, + collapse = ", " + ) %>% + { + paste0("dplyr::case_when(", ., ", TRUE ~ 0)") + } %>% + # converting strings into expressions to run + parse(text = .) %>% + eval() + + # formatting number + style_number(x, digits = d, scale = scale, big.mark = big.mark, decimal.mark = decimal.mark, ...) +} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index fe3769e084..8752f13da8 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -42,7 +42,7 @@ tbl_summary <- function(data, label = NULL, statistic = list(all_continuous() ~ "{mean} ({sd})", all_categorical() ~ "{n} ({p}%)"), - digits = NULL, + digits = assign_summary_digits(data, statistic, type), type = assign_summary_type(data, include, value), value = NULL, missing = c("ifany", "no", "always"), @@ -82,11 +82,9 @@ tbl_summary <- function(data, missing(statistic), get_theme_element("TODO:fill-this-in", default = statistic), statistic - ) , - digits = digits, + ), sort = sort ) - # fill in unspecified variables cards::fill_formula_selectors( data[include], @@ -94,6 +92,11 @@ tbl_summary <- function(data, get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])) ) + cards::process_formula_selectors( + data = .add_summary_type_as_attr(data[include], type), + digits = digits + ) + # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) call <- match.call() @@ -108,13 +111,15 @@ tbl_summary <- function(data, cards::ard_categorical( data, by = by, - variables = .get_variables_by_type(type, c("categorical", "dichotomous")) + variables = .get_variables_by_type(type, c("categorical", "dichotomous")), + fmt_fn = digits ), # calculate categorical summaries cards::ard_continuous( data, by = by, - variables = .get_variables_by_type(type, c("continuous", "continuous2")) + variables = .get_variables_by_type(type, c("continuous", "continuous2")), + fmt_fn = digits ) ) diff --git a/R/utils-as.R b/R/utils-as.R index 9773511c2e..dc557875fe 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -83,7 +83,7 @@ #' @keywords internal #' @export #' -#' @examples +# #' @examples # #' tbl <- # #' trial %>% # #' tbl_summary(include = c(age, grade)) %>% diff --git a/man/styfn.Rd b/man/styfn.Rd new file mode 100644 index 0000000000..4bd5e8a4d1 --- /dev/null +++ b/man/styfn.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/styfn.R +\name{styfn} +\alias{styfn} +\alias{styfn_number} +\alias{styfn_sigfig} +\alias{styfn_pvalue} +\alias{styfn_ratio} +\alias{styfn_percent} +\title{Style Functions} +\usage{ +styfn_number(digits = 0, big.mark = NULL, decimal.mark = NULL, scale = 1, ...) + +styfn_sigfig(digits = 2, scale = 1, big.mark = NULL, decimal.mark = NULL, ...) + +styfn_pvalue( + digits = 1, + prepend_p = FALSE, + big.mark = NULL, + decimal.mark = NULL, + ... +) + +styfn_ratio(digits = 2, big.mark = NULL, decimal.mark = NULL, ...) + +styfn_percent( + symbol = FALSE, + digits = 0, + big.mark = NULL, + decimal.mark = NULL, + ... +) +} +\arguments{ +\item{digits, big.mark, decimal.mark, scale, prepend_p, symbol, ...}{arguments +passed to the \verb{style_*()} functions} +} +\value{ +a function +} +\description{ +Similar to the \verb{style_*()} family of functions, but these functions return +a \verb{style_*()} \strong{function} rather than performing the styling. +} +\examples{ +my_style <- styfn_number(digits = 1) +my_style(3.14) +} +\seealso{ +Other style tools: +\code{\link{style_number}()}, +\code{\link{style_percent}()}, +\code{\link{style_pvalue}()}, +\code{\link{style_ratio}()}, +\code{\link{style_sigfig}()} +} +\concept{style tools} diff --git a/man/style_number.Rd b/man/style_number.Rd new file mode 100644 index 0000000000..e8001ed93f --- /dev/null +++ b/man/style_number.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/style_number.R +\name{style_number} +\alias{style_number} +\title{Style numbers} +\usage{ +style_number( + x, + digits = 0, + big.mark = NULL, + decimal.mark = NULL, + scale = 1, + ... +) +} +\arguments{ +\item{x}{Numeric vector} + +\item{digits}{Integer or vector of integers specifying the number of decimals +to round \verb{x=}. When vector is passed, each integer is mapped 1:1 to the +numeric values in \code{x}} + +\item{big.mark}{Character used between every 3 digits to separate +hundreds/thousands/millions/etc. +Default is \code{","}, except when \code{decimal.mark = ","} when the default is a space.} + +\item{decimal.mark}{The character to be used to indicate the numeric decimal point. +Default is \code{"."} or \code{getOption("OutDec")}} + +\item{scale}{A scaling factor: x will be multiplied by scale before formatting.} + +\item{...}{Other arguments passed on to \code{base::format()}} +} +\value{ +formatted character vector +} +\description{ +Style numbers +} +\examples{ +c(0.111, 12.3) \%>\% style_number(digits = 1) +c(0.111, 12.3) \%>\% style_number(digits = c(1, 0)) +} +\seealso{ +Other style tools: +\code{\link{styfn}}, +\code{\link{style_percent}()}, +\code{\link{style_pvalue}()}, +\code{\link{style_ratio}()}, +\code{\link{style_sigfig}()} +} +\concept{style tools} diff --git a/man/style_percent.Rd b/man/style_percent.Rd new file mode 100644 index 0000000000..437b01d0c7 --- /dev/null +++ b/man/style_percent.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/style_percent.R +\name{style_percent} +\alias{style_percent} +\title{Style percentages} +\usage{ +style_percent( + x, + symbol = FALSE, + digits = 0, + big.mark = NULL, + decimal.mark = NULL, + ... +) +} +\arguments{ +\item{x}{numeric vector of percentages} + +\item{symbol}{Logical indicator to include percent symbol in output. +Default is \code{FALSE}.} + +\item{digits}{number of digits to round large percentages (i.e. greater than 10\%). +Smaller percentages are rounded to \code{digits + 1} places. +Default is \code{0}} + +\item{big.mark}{Character used between every 3 digits to separate +hundreds/thousands/millions/etc. +Default is \code{","}, except when \code{decimal.mark = ","} when the default is a space.} + +\item{decimal.mark}{The character to be used to indicate the numeric decimal point. +Default is \code{"."} or \code{getOption("OutDec")}} + +\item{...}{Other arguments passed on to \code{base::format()}} +} +\value{ +A character vector of styled percentages +} +\description{ +Style percentages +} +\examples{ +percent_vals <- c(-1, 0, 0.0001, 0.005, 0.01, 0.10, 0.45356, 0.99, 1.45) +style_percent(percent_vals) +style_percent(percent_vals, symbol = TRUE, digits = 1) +} +\seealso{ +See Table Gallery \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{vignette} for example + +Other style tools: +\code{\link{styfn}}, +\code{\link{style_number}()}, +\code{\link{style_pvalue}()}, +\code{\link{style_ratio}()}, +\code{\link{style_sigfig}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{style tools} diff --git a/man/style_pvalue.Rd b/man/style_pvalue.Rd new file mode 100644 index 0000000000..b22006d9f5 --- /dev/null +++ b/man/style_pvalue.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/style_pvalue.R +\name{style_pvalue} +\alias{style_pvalue} +\title{Style p-values} +\usage{ +style_pvalue( + x, + digits = 1, + prepend_p = FALSE, + big.mark = NULL, + decimal.mark = NULL, + ... +) +} +\arguments{ +\item{x}{Numeric vector of p-values.} + +\item{digits}{Number of digits large p-values are rounded. Must be 1, 2, or 3. +Default is 1.} + +\item{prepend_p}{Logical. Should 'p=' be prepended to formatted p-value. +Default is \code{FALSE}} + +\item{big.mark}{Character used between every 3 digits to separate +hundreds/thousands/millions/etc. +Default is \code{","}, except when \code{decimal.mark = ","} when the default is a space.} + +\item{decimal.mark}{The character to be used to indicate the numeric decimal point. +Default is \code{"."} or \code{getOption("OutDec")}} + +\item{...}{Other arguments passed on to \code{base::format()}} +} +\value{ +A character vector of styled p-values +} +\description{ +Style p-values +} +\examples{ +pvals <- c( + 1.5, 1, 0.999, 0.5, 0.25, 0.2, 0.197, 0.12, 0.10, 0.0999, 0.06, + 0.03, 0.002, 0.001, 0.00099, 0.0002, 0.00002, -1 +) +style_pvalue(pvals) +style_pvalue(pvals, digits = 2, prepend_p = TRUE) +} +\seealso{ +See tbl_summary \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{vignette} for examples + +Other style tools: +\code{\link{styfn}}, +\code{\link{style_number}()}, +\code{\link{style_percent}()}, +\code{\link{style_ratio}()}, +\code{\link{style_sigfig}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{style tools} diff --git a/man/style_ratio.Rd b/man/style_ratio.Rd new file mode 100644 index 0000000000..89b601809a --- /dev/null +++ b/man/style_ratio.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/style_ratio.R +\name{style_ratio} +\alias{style_ratio} +\title{Style significant figure-like rounding for ratios} +\usage{ +style_ratio(x, digits = 2, big.mark = NULL, decimal.mark = NULL, ...) +} +\arguments{ +\item{x}{Numeric vector} + +\item{digits}{Integer specifying the number of significant +digits to display for numbers below 1. Numbers larger than 1 will be be \code{digits + 1}. +Default is \code{digits = 2}.} + +\item{big.mark}{Character used between every 3 digits to separate +hundreds/thousands/millions/etc. +Default is \code{","}, except when \code{decimal.mark = ","} when the default is a space.} + +\item{decimal.mark}{The character to be used to indicate the numeric decimal point. +Default is \code{"."} or \code{getOption("OutDec")}} + +\item{...}{Other arguments passed on to \code{base::format()}} +} +\value{ +A character vector of styled ratios +} +\description{ +When reporting ratios, such as relative risk or an odds ratio, we'll often +want the rounding to be similar on each side of the number 1. For example, +if we report an odds ratio of 0.95 with a confidence interval of 0.70 to 1.24, +we would want to round to two decimal places for all values. In other words, +2 significant figures for numbers less than 1 and 3 significant figures 1 and +larger. \code{style_ratio()} performs significant figure-like rounding in this manner. +} +\examples{ +c( + 0.123, 0.9, 1.1234, 12.345, 101.234, -0.123, + -0.9, -1.1234, -12.345, -101.234 +) \%>\% + style_ratio() +} +\seealso{ +Other style tools: +\code{\link{styfn}}, +\code{\link{style_number}()}, +\code{\link{style_percent}()}, +\code{\link{style_pvalue}()}, +\code{\link{style_sigfig}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{style tools} diff --git a/man/style_sigfig.Rd b/man/style_sigfig.Rd new file mode 100644 index 0000000000..4b5fa691c4 --- /dev/null +++ b/man/style_sigfig.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/style_sigfig.R +\name{style_sigfig} +\alias{style_sigfig} +\title{Style significant figure-like rounding} +\usage{ +style_sigfig( + x, + digits = 2, + scale = 1, + big.mark = NULL, + decimal.mark = NULL, + ... +) +} +\arguments{ +\item{x}{Numeric vector} + +\item{digits}{Integer specifying the minimum number of significant +digits to display} + +\item{scale}{A scaling factor: x will be multiplied by scale before formatting.} + +\item{big.mark}{Character used between every 3 digits to separate +hundreds/thousands/millions/etc. +Default is \code{","}, except when \code{decimal.mark = ","} when the default is a space.} + +\item{decimal.mark}{The character to be used to indicate the numeric decimal point. +Default is \code{"."} or \code{getOption("OutDec")}} + +\item{...}{Other arguments passed on to \code{base::format()}} +} +\value{ +A character vector of styled numbers +} +\description{ +Converts a numeric argument into a string that has been rounded to a +significant figure-like number. Scientific notation output +is avoided, however, and additional significant figures may be displayed for +large numbers. For example, if the number of significant digits +requested is 2, 123 will be displayed (rather than 120 or 1.2x10^2). +} +\section{Details}{ + +\itemize{ +\item Scientific notation output is avoided. +\item If 2 significant figures are requested, the number is rounded to no more than 2 decimal places. +For example, a number will be rounded to 2 decimals places when \code{abs(x) < 1}, +1 decimal place when \code{abs(x) >= 1 & abs(x) < 10}, +and to the nearest integer when \code{abs(x) >= 10}. +\item Additional significant figures +may be displayed for large numbers. For example, if the number of +significant digits requested is 2, +123 will be displayed (rather than 120 or 1.2x10^2). +} +} + +\examples{ +c(0.123, 0.9, 1.1234, 12.345, -0.123, -0.9, -1.1234, -132.345, NA, -0.001) \%>\% + style_sigfig() +} +\seealso{ +Other style tools: +\code{\link{styfn}}, +\code{\link{style_number}()}, +\code{\link{style_percent}()}, +\code{\link{style_pvalue}()}, +\code{\link{style_ratio}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{style tools} diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index efadc0fac0..f34b6b63dd 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -9,7 +9,7 @@ tbl_summary( by = NULL, label = NULL, statistic = list(all_continuous() ~ "{mean} ({sd})", all_categorical() ~ "{n} ({p}\%)"), - digits = NULL, + digits = assign_summary_digits(data, statistic, type), type = assign_summary_type(data, include, value), value = NULL, missing = c("ifany", "no", "always"), From ae39b22f9b3ad6d6b42ec49ae89efe744ccac59c Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 4 Dec 2023 13:34:56 -0800 Subject: [PATCH 08/74] Dynamic column headers (#1576) * in progress * progress * progress --- NAMESPACE | 2 + R/as_tibble.R | 219 +++++++++++++++++++++++++++++++++++++ R/assign_summary_type.R | 53 +++++---- R/bridge_summary.R | 77 ++++++++++++- R/modify_header.R | 42 +++++++ R/tbl_summary.R | 23 ++++ man/as_gt.Rd | 4 + man/as_tibble.gtsummary.Rd | 63 +++++++++++ 8 files changed, 460 insertions(+), 23 deletions(-) create mode 100644 R/as_tibble.R create mode 100644 man/as_tibble.gtsummary.Rd diff --git a/NAMESPACE b/NAMESPACE index 6a8cfdeab0..2f037b3f32 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +S3method(as.data.frame,gtsummary) +S3method(as_tibble,gtsummary) S3method(print,gtsummary) export("%>%") export(.table_styling_expr_to_row_number) diff --git a/R/as_tibble.R b/R/as_tibble.R new file mode 100644 index 0000000000..539878cf9d --- /dev/null +++ b/R/as_tibble.R @@ -0,0 +1,219 @@ +#' Convert gtsummary object to a tibble +#' +#' Function converts a gtsummary object to a tibble. +#' +#' @inheritParams as_gt +#' @param col_labels Logical argument adding column labels to output tibble. +#' Default is `TRUE`. +#' @param fmt_missing Logical argument adding the missing value formats. +#' @param ... Not used +#' @return a [tibble][tibble::tibble-package] +#' @family gtsummary output types +#' @author Daniel D. Sjoberg +#' @name as_tibble.gtsummary +#' @examples +#' \donttest{ +#' tbl <- +#' trial %>% +#' select(trt, age, grade, response) %>% +#' tbl_summary(by = trt) +#' +#' as_tibble(tbl) +#' +#' # without column labels +#' as_tibble(tbl, col_labels = FALSE) +#' } +NULL + +#' @export +#' @rdname as_tibble.gtsummary +as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, + return_calls = FALSE, fmt_missing = FALSE, ...) { + # running pre-conversion function, if present -------------------------------- + x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) + + # converting row specifications to row numbers, and removing old cmds -------- + x <- .table_styling_expr_to_row_number(x) + + # creating list of calls to get formatted tibble ----------------------------- + tibble_calls <- + table_styling_to_tibble_calls( + x = x, + col_labels = col_labels, + fmt_missing = fmt_missing + ) + + # converting to character vector --------------------------------------------- + include <- + .select_to_varnames( + select = {{ include }}, + var_info = names(tibble_calls), + arg_name = "include" + ) + + # making list of commands to include ----------------------------------------- + # this ensures list is in the same order as names(x$kable_calls) + include <- names(tibble_calls) %>% intersect(include) + # user cannot exclude the first 'tibble' command + include <- "tibble" %>% union(include) + + # return calls, if requested ------------------------------------------------- + if (return_calls == TRUE) { + return(tibble_calls[include]) + } + + # taking each gt function call, concatenating them with %>% separating them + .eval_list_of_exprs(tibble_calls[include]) +} + +#' @export +#' @rdname as_tibble.gtsummary +as.data.frame.gtsummary <- function(...) { + res <- as_tibble(...) + + if (inherits(res, "data.frame")) + return(as.data.frame(res)) + + res +} + + +table_styling_to_tibble_calls <- function(x, col_labels = TRUE, fmt_missing = FALSE) { + tibble_calls <- list() + + # tibble --------------------------------------------------------------------- + tibble_calls[["tibble"]] <- expr(x$table_body) + + # ungroup -------------------------------------------------------------------- + if ("groupname_col" %in% x$table_styling$header$column) { + tibble_calls[["ungroup"]] <- + list( + expr(dplyr::group_by(.data$groupname_col)), + expr(dplyr::mutate(groupname_col = ifelse(dplyr::row_number() == 1, + as.character(.data$groupname_col), + NA_character_ + ))), + expr(dplyr::ungroup()) + ) + } + + # fmt (part 1) --------------------------------------------------------------- + # this needs to be called in as_tibble() before the bolding and italic function, + # but the bolding and italic code needs to executed on pre-formatted data + # (e.g. `bold_p()`) this holds its place for when it is finally run + tibble_calls[["fmt"]] <- list() + + # cols_merge ----------------------------------------------------------------- + tibble_calls[["cols_merge"]] <- + map( + seq_len(nrow(x$table_styling$cols_merge)), + ~ expr( + dplyr::mutate( + !!x$table_styling$cols_merge$column[.x] := + ifelse( + dplyr::row_number() %in% !!x$table_styling$cols_merge$rows[[.x]], + glue::glue(!!x$table_styling$cols_merge$pattern[.x]) %>% as.character(), + !!rlang::sym(x$table_styling$cols_merge$column[.x]) + ) + ) + ) + ) + + # tab_style_bold ------------------------------------------------------------- + df_bold <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "bold") + + tibble_calls[["tab_style_bold"]] <- + map( + seq_len(nrow(df_bold)), + ~ expr(dplyr::mutate_at( + gt::vars(!!!syms(df_bold$column[[.x]])), + ~ ifelse(row_number() %in% !!df_bold$row_numbers[[.x]], + paste0("__", ., "__"), . + ) + )) + ) + + # tab_style_italic ------------------------------------------------------------- + df_italic <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "italic") + + tibble_calls[["tab_style_italic"]] <- + map( + seq_len(nrow(df_italic)), + ~ expr(dplyr::mutate_at( + gt::vars(!!!syms(df_italic$column[[.x]])), + ~ ifelse(dplyr::row_number() %in% !!df_italic$row_numbers[[.x]], + paste0("_", ., "_"), . + ) + )) + ) + + # fmt (part 2) --------------------------------------------------------------- + tibble_calls[["fmt"]] <- + map( + seq_len(nrow(x$table_styling$fmt_fun)), + ~ expr((!!expr(!!eval(parse_expr("gtsummary:::.apply_fmt_fun"))))( + columns = !!x$table_styling$fmt_fun$column[[.x]], + row_numbers = !!x$table_styling$fmt_fun$row_numbers[[.x]], + fmt_fun = !!x$table_styling$fmt_fun$fmt_fun[[.x]], + update_from = !!x$table_body + )) + ) + + # fmt_missing ---------------------------------------------------------------- + if (isTRUE(fmt_missing)) { + tibble_calls[["fmt_missing"]] <- + map( + seq_len(nrow(x$table_styling$fmt_missing)), + ~ expr( + ifelse( + dplyr::row_number() %in% !!x$table_styling$fmt_missing$row_numbers[[.x]] & is.na(!!sym(x$table_styling$fmt_missing$column[.x])), + !!x$table_styling$fmt_missing$symbol[.x], + !!sym(x$table_styling$fmt_missing$column[.x]) + ) + ) + ) %>% + rlang::set_names(x$table_styling$fmt_missing$column) %>% + { + expr(dplyr::mutate(!!!.)) + } %>% + list() + } else { + tibble_calls[["fmt_missing"]] <- list() + } + + # cols_hide ------------------------------------------------------------------ + # cols_to_keep object created above in fmt section + tibble_calls[["cols_hide"]] <- + expr(dplyr::select(any_of("groupname_col"), !!!syms(.cols_to_show(x)))) + + # cols_label ----------------------------------------------------------------- + if (col_labels) { + df_col_labels <- + dplyr::filter(x$table_styling$header, .data$hide == FALSE) + + tibble_calls[["cols_label"]] <- + expr(rlang::set_names(!!df_col_labels$label)) + } + + tibble_calls +} + +.apply_fmt_fun <- function(data, columns, row_numbers, fmt_fun, update_from) { + # apply formatting functions + df_updated <- + update_from[row_numbers, columns, drop = FALSE] %>% + map(~ fmt_fun(.x)) |> + dplyr::bind_cols() + + # convert underlying column to character if updated col is character + for (v in columns) { + if (is.character(df_updated[[v]]) && !is.character(data[[v]])) { + data[[v]] <- as.character(data[[v]]) + } + } + + # update data and return + data[row_numbers, columns, drop = FALSE] <- df_updated + + data +} diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index 654d1c99fc..f09466332b 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -32,28 +32,7 @@ assign_summary_type <- function(data, variables, value, type = NULL) { return(type[[variable]]) } - # logical variables are dichotomous - if (inherits(data[[variable]], "logical")) { - return("dichotomous") - } - - # numeric variables that are 0 and 1 only, will be dichotomous - if (inherits(data[[variable]], c("integer", "numeric")) && - length(setdiff(stats::na.omit(data[[variable]]), c(0, 1))) == 0) { - return("dichotomous") - } - - # factor variables that are "No" and "Yes" only, will be dichotomous - if (inherits(data[[variable]], "factor") && - length(levels(data[[variable]])) == 2L && - setequal(toupper(levels(data[[variable]])), c("NO", "YES"))) { - return("dichotomous") - } - - # character variables that are "No" and "Yes" only, will be dichotomous - if (inherits(data[[variable]], "character") && - setequal(toupper(stats::na.omit(data[[variable]])), c("NO", "YES")) && - length(stats::na.omit(data[[variable]])) == 2L) { + if (!is.null(.get_default_dichotomous_value(data[[variable]]))) { return("dichotomous") } @@ -83,6 +62,36 @@ assign_summary_type <- function(data, variables, value, type = NULL) { type } +.get_default_dichotomous_value <- function(x) { + # logical variables are dichotomous + if (inherits(x, "logical")) { + return(TRUE) + } + + # numeric variables that are 0 and 1 only, will be dichotomous + if (inherits(x, c("integer", "numeric")) && + length(setdiff(stats::na.omit(x), c(0, 1))) == 0) { + return(stats::na.omit(x) |> unique() |> sort() |> dplyr::last()) + } + + # factor variables that are "No" and "Yes" only, will be dichotomous + if (inherits(x, "factor") && + length(levels(x)) == 2L && + setequal(toupper(levels(x)), c("NO", "YES"))) { + return(levels(x)[toupper(levels(x)) %in% "YES"]) + } + + # character variables that are "No" and "Yes" only, will be dichotomous + if (inherits(x, "character") && + setequal(toupper(stats::na.omit(x)), c("NO", "YES")) && + length(stats::na.omit(x)) == 2L) { + return(unique(x)[toupper(unique(x)) %in% "YES"]) + } + + # otherwise, return NULL + NULL +} + .add_summary_type_as_attr <- function(data, type) { type <- type[names(type) %in% names(data)] type_names <- names(type) diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 871d4e3999..e3e038673c 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -129,11 +129,16 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { # construct default table_styling -------------------------------------------- x <- construct_initial_table_styling(x) + # add info to x$table_styling$header for dynamic headers --------------------- + x <- .add_table_styling_stats(x) + + x } #' @rdname bridge_summary #' @export pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { + if (is_empty(variables)) return(dplyr::tibble()) # subsetting cards object on dichotomous summaries --------------------------- x$cards <- x$cards |> @@ -154,6 +159,7 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { #' @rdname bridge_summary #' @export pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { + if (is_empty(variables)) return(dplyr::tibble()) # subsetting cards object on categorical summaries ---------------------------- card <- x$cards |> @@ -265,6 +271,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { + if (is_empty(variables)) return(dplyr::tibble()) # subsetting cards object on continuous2 summaries ---------------------------- card <- x$cards |> @@ -275,7 +282,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin df_glued <- # construct stat columns with glue by grouping variables and primary summary variable card |> - dplyr::group_by(across(c("gts_column" ,cards::all_ard_groups(), "variable"))) |> + dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(.x, .y) { dplyr::mutate( @@ -418,6 +425,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing #' @rdname bridge_summary #' @export pier_summary_missing_row <- function(x, variables = x$inputs$include) { + if (is_empty(variables)) return(dplyr::tibble()) # keeping variables to report missing obs for (or returning empty df if none) if (x$inputs$missing == "no") return(dplyr::tibble()) if (x$inputs$missing == "ifany") { @@ -445,3 +453,70 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { label = x$inputs$missing_text ) } + +.add_table_styling_stats <- function(x) { + if (is_empty(x$inputs$by)) { + x$table_styling$header <- + x$table_styling$header |> + dplyr::mutate( + modify_stat_N = + x$cards |> + dplyr::filter(.data$stat_name %in% "N_obs") |> + dplyr::pull("statistic") |> + unlist() |> + getElement(1), + modify_stat_n = .data$modify_stat_N, + modify_stat_p = 1, + modify_stat_level = "Overall" + ) + } + else { + df_by_stats <- x$cards |> + dplyr::filter(.data$variable %in% .env$x$inputs$by & .data$stat_name %in% c("N", "n", "p")) + + # get a data frame with the by variable stats + df_by_stats_wide <- + df_by_stats |> + dplyr::filter(.data$stat_name %in% c("n", "p")) |> + dplyr::mutate( + .by = .data$variable_level, + column = paste0("stat_", dplyr::cur_group_id()) + ) %>% + {dplyr::bind_rows( + ., + dplyr::select(., "variable_level", "column", statistic = "variable_level") |> + dplyr::mutate(stat_name = "level") |> + dplyr::distinct() + )} |> + tidyr::pivot_wider( + id_cols = "column", + names_from = "stat_name", + values_from = "statistic" + ) |> + dplyr::mutate( + dplyr::across(-"column", unlist), + dplyr::across("level", as.character) + ) |> + dplyr::rename_with( + function(x) paste0("modify_stat_", x), + .cols = -"column" + ) + + # add the stats here to the header data frame + x$table_styling$header <- + x$table_styling$header |> + dplyr::mutate( + modify_stat_N = + df_by_stats |> + dplyr::filter(.data$stat_name %in% "N") |> + dplyr::pull("statistic") |> + unlist() + ) |> + dplyr::left_join( + df_by_stats_wide, + by = "column" + ) + } + + x +} diff --git a/R/modify_header.R b/R/modify_header.R index 5128e787aa..f0a91daf7c 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -23,6 +23,14 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), } cards::process_formula_selectors(data = x$table_body, dots = dots) + cards::check_list_elements( + dots = function(x) is_string(x), + error_msg = list(dots = c("All values passed in {.arg ...} must be strings.", + "i" = "For example, {.code label = '**Variable**'}")) + ) + + # evaluate the strings with glue + dots <- .evaluate_string_with_glue(x, dots) # updated header meta data x$table_styling$header <- @@ -38,3 +46,37 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), # return object x } + +.evaluate_string_with_glue <- function(x, dots) { + # only keep values that are in the table_body + dots <- dots[intersect(names(dots), x$table_styling$header$column)] + + df_header_subset <- + x$table_styling$header |> + dplyr::select("column", starts_with("modify_stat_")) |> + dplyr::rename_with( + .fn = function(x) gsub("^modify_stat_", "", x), + .cols = starts_with("modify_stat_") + ) + + imap( + dots, + function(value, variable) { + df_header_subset <- + df_header_subset |> + dplyr::filter(.data$column %in% .env$variable) |> + dplyr::select(-"column") + + glued_value <- + cards::eval_capture_conditions( + expr(glue::glue(value)), + data = df_header_subset + ) + + if (!is.null(glued_value$result)) + return(glued_value$result) + + cli::cli_abort("There was an error the {.field glue} evaluation of {.val {value}}.") + } + ) +} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 8752f13da8..6122719e95 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -72,6 +72,8 @@ tbl_summary <- function(data, type <- utils::modifyList(default_types, type) } + value <- .assign_default_values(data[include], value, type) + # evaluate the remaining list-formula arguments ------------------------------ # processed arguments are saved into this env cards::process_formula_selectors( @@ -167,3 +169,24 @@ tbl_summary <- function(data, include[!is_all_na] } + +.assign_default_values <- function(data, value, type) { + lapply( + names(data), + function(variable) { + # if user passed value, then use it + if (!is.null(value[[variable]])) return(value[[variable]]) + # if not a dichotomous summary type, then return NULL + if (!type[[variable]] %in% "dichotomous") return(NULL) + + # otherwise, return default value + default_value <- .get_default_dichotomous_value(data[[variable]]) + if (!is.null(default_value)) return(default_value) + cli::cli_abort(c( + "Error in argument {.arg value} for variable {.val {variable}}.", + "i" = "Summary type is {.val dichotomous} but no summary value has been assigned." + )) + } + ) |> + stats::setNames(names(data)) +} diff --git a/man/as_gt.Rd b/man/as_gt.Rd index d0146bcdd1..349ee2a314 100644 --- a/man/as_gt.Rd +++ b/man/as_gt.Rd @@ -36,6 +36,10 @@ available via the \href{https://gt.rstudio.com/index.html}{gt package}. # tbl_summary(by = trt) \%>\% # as_gt() } +\seealso{ +Other gtsummary output types: +\code{\link{as_tibble.gtsummary}()} +} \author{ Daniel D. Sjoberg } diff --git a/man/as_tibble.gtsummary.Rd b/man/as_tibble.gtsummary.Rd new file mode 100644 index 0000000000..8939339e44 --- /dev/null +++ b/man/as_tibble.gtsummary.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/as_tibble.R +\name{as_tibble.gtsummary} +\alias{as_tibble.gtsummary} +\alias{as.data.frame.gtsummary} +\title{Convert gtsummary object to a tibble} +\usage{ +\method{as_tibble}{gtsummary}( + x, + include = everything(), + col_labels = TRUE, + return_calls = FALSE, + fmt_missing = FALSE, + ... +) + +\method{as.data.frame}{gtsummary}(...) +} +\arguments{ +\item{x}{An object of class `"gtsummary"} + +\item{include}{Commands to include in output. Input may be a vector of +quoted or unquoted names. tidyselect and gtsummary select helper +functions are also accepted. +Default is \code{everything()}.} + +\item{col_labels}{Logical argument adding column labels to output tibble. +Default is \code{TRUE}.} + +\item{return_calls}{Logical. Default is \code{FALSE}. If \code{TRUE}, the calls are returned +as a list of expressions.} + +\item{fmt_missing}{Logical argument adding the missing value formats.} + +\item{...}{Not used} +} +\value{ +a \link[tibble:tibble-package]{tibble} +} +\description{ +Function converts a gtsummary object to a tibble. +} +\examples{ +\donttest{ +tbl <- + trial \%>\% + select(trt, age, grade, response) \%>\% + tbl_summary(by = trt) + +as_tibble(tbl) + +# without column labels +as_tibble(tbl, col_labels = FALSE) +} +} +\seealso{ +Other gtsummary output types: +\code{\link{as_gt}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{gtsummary output types} From e78282592ad08196fcbc0603697bfae813dfad6d Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 6 Dec 2023 20:29:52 -0800 Subject: [PATCH 09/74] Update DESCRIPTION --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2a42a98a9c..66f639c4b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,6 +42,8 @@ License: MIT + file LICENSE URL: https://github.com/ddsjoberg/gtsummary, https://www.danieldsjoberg.com/gtsummary/ BugReports: https://github.com/ddsjoberg/gtsummary/issues +Depends: + R (>= 4.1) Imports: broom.helpers, cards (>= 0.0.0.9003), @@ -69,5 +71,3 @@ Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 -Depends: - R (>= 2.10) From 2e4c79c4df985742a2e260cdfea4ddc8118edd53 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 7 Dec 2023 18:29:05 -0800 Subject: [PATCH 10/74] progress --- DESCRIPTION | 2 +- NEWS.md | 4 +++- R/bridge_summary.R | 20 ++++++-------------- R/modify_header.R | 10 ++-------- R/tbl_summary.R | 1 + 5 files changed, 13 insertions(+), 24 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 66f639c4b8..f95a237d67 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9003), + cards (>= 0.0.0.9004), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/NEWS.md b/NEWS.md index 6fecdcc0ad..498e3d98f7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,7 +22,9 @@ ### Deprecations -* Global options have been deprecated in gtsummary since v1.3.1 (3.5 years ago). They have now been fully removed from the package. +* Global options have been deprecated in gtsummary since v1.3.1 (2020-06-02). They have now been fully removed from the package. + +* The `modify_header(stat_by)` argument was deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the packaage. # gtsummary 1.7.2 diff --git a/R/bridge_summary.R b/R/bridge_summary.R index e3e038673c..43102fa3ab 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -69,20 +69,12 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { # add the function call column x$cards <- x$cards |> - dplyr::mutate( - gts_function = - ifelse( - .data$variable %in% c(x$inputs$tbl_summary$by, x$inputs$tbl_summary$include) & - .data$context %in% c("continuous", "categorical"), - .env$calling_function, - NA_character_ - ) - ) + dplyr::mutate(gts_function = .env$calling_function) # adding the name of the column the stats will populate if (is_empty(x$inputs$by)) { x$cards$gts_column <- - ifelse(x$cards$context %in% c("continuous", "categorical"), "stat_0", NA_character_) + ifelse(x$cards$context %in% c("continuous", "categorical", "missing"), "stat_0", NA_character_) } else { x$cards <- @@ -91,7 +83,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { .by = cards::all_ard_groups(), gts_column = ifelse( - .data$context %in% c("continuous", "categorical") & + .data$context %in% c("continuous", "categorical", "missing") & !.data$variable %in% .env$x$inputs$tbl_summary$by, paste0("stat_", dplyr::cur_group_id() - 1L), NA_character_ @@ -163,7 +155,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin # subsetting cards object on categorical summaries ---------------------------- card <- x$cards |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "categorical") |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("categorical", "missing")) |> cards::apply_statistic_fmt_fn() # construct formatted statistics --------------------------------------------- @@ -275,7 +267,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin # subsetting cards object on continuous2 summaries ---------------------------- card <- x$cards |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "continuous") |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> cards::apply_statistic_fmt_fn() # construct formatted statistics --------------------------------------------- @@ -373,7 +365,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing # subsetting cards object on continuous summaries ---------------------------- card <- x$cards |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% "continuous") |> + dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> cards::apply_statistic_fmt_fn() # construct formatted statistics --------------------------------------------- diff --git a/R/modify_header.R b/R/modify_header.R index f0a91daf7c..1848f2b616 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -1,18 +1,12 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), - quiet = NULL, update = NULL, stat_by = NULL) { + quiet = NULL, update = NULL) { # process inputs ------------------------------------------------------------- dots <- rlang::dots_list(...) text_interpret <- rlang::arg_match(text_interpret) # deprecated arguments - if (!is.null(stat_by)) { - lifecycle::deprecate_stop( - "1.3.6", "gtsummary::modify_header(stat_by=)", - details = glue::glue("Use `all_stat_cols(FALSE) ~ {stat_by}` instead.") - ) - } if (!is.null(update)) { lifecycle::deprecate_warn( "2.0.0", "gtsummary::modify_header(update=)", @@ -76,7 +70,7 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), if (!is.null(glued_value$result)) return(glued_value$result) - cli::cli_abort("There was an error the {.field glue} evaluation of {.val {value}}.") + cli::cli_abort("There was an error the {.fun glue::glue} evaluation of {.val {value}}.") } ) } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 6122719e95..1fbb369dc3 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -107,6 +107,7 @@ tbl_summary <- function(data, cards <- cards::bind_ard( cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), + cards::ard_missing(data, variables = all_of(include), by = all_of(by)), # tabulate by variable for header stats if (!rlang::is_empty(by)) cards::ard_categorical(data, variables = all_of(by)), # tabulate categorical summaries From 853fad3a08288ed71de630159f5d7c489e8ad396 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 8 Dec 2023 14:30:45 -0800 Subject: [PATCH 11/74] Update tbl_summary.R --- R/tbl_summary.R | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 1fbb369dc3..631b867ec7 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -144,6 +144,12 @@ tbl_summary <- function(data, label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), text_format = "indent" + ) |> + modify_table_styling( + columns = all_stat_cols(), + footnote = + .construct_summary_footnote(x$cards, x$inputs$include, x$inputs$statistic) |> + unlist() |> unique() |> paste(collapse = ", ") ) x <- @@ -156,6 +162,25 @@ tbl_summary <- function(data, x } + +.construct_summary_footnote <- function(card, include, statistic) { + include |> + lapply( + function(variable) { + card |> + dplyr::filter(.data$variable %in% .env$variable) |> + dplyr::select("stat_name", "stat_label") |> + dplyr::distinct() %>% + {as.list(.$stat_label) |> stats::setNames(.$stat_name)}|> + glue::glue_data(statistic[[variable]]) %>% + {gsub(pattern = "(%%)+", replacement = "%", x = .)} + } + ) |> + stats::setNames(include) +} + + + .get_variables_by_type <- function(x, type) { names(x)[unlist(x) %in% type] } From 8de782a027084cfe55d8d56b806d8d8118476f87 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 29 Dec 2023 20:26:18 -0800 Subject: [PATCH 12/74] Updating with the `tbl_summary(sort)` argument (#1583) * in progress * Update tbl_summary.R --- R/standalone-forcats.R | 35 +++++++++++++++++++++++++++++++++++ R/tbl_summary.R | 37 +++++++++++++++++++++++++++++++------ man/tbl_summary.Rd | 2 +- 3 files changed, 67 insertions(+), 7 deletions(-) create mode 100644 R/standalone-forcats.R diff --git a/R/standalone-forcats.R b/R/standalone-forcats.R new file mode 100644 index 0000000000..e6e5039b2c --- /dev/null +++ b/R/standalone-forcats.R @@ -0,0 +1,35 @@ +# --- +# file: standalone-forcats.R +# last-updated: 2023-12-29 +# license: https://unlicense.org +# imports: +# --- +# +# This file provides a minimal shim to provide a forcats-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# 2023-12-29 +# First functions added +# +# nocov start + +fct_infreq <- function(f, ordered = NA) { + # reorder by frequency + factor( + f, + levels = table(f) |> sort(decreasing = TRUE) |> names(), + ordered = ifelse(is.na(ordered), is.ordered(f), ordered) + ) +} + +fct_inorder <- function(f, ordered = NA) { + factor( + f, + levels = stats::na.omit(unique(f)) |> union(levels(f)), + ordered = ifelse(is.na(ordered), is.ordered(f), ordered) + ) +} + +# nocov end diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 631b867ec7..2da9c03d48 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -48,7 +48,7 @@ tbl_summary <- function(data, missing = c("ifany", "no", "always"), missing_text = "Unknown", missing_stat = "{N_miss}", - sort = all_categorical() ~ "alphanumeric", + sort = all_categorical(FALSE) ~ "alphanumeric", percent = c("column", "row", "cell"), include = everything()) { # process arguments ---------------------------------------------------------- @@ -85,7 +85,12 @@ tbl_summary <- function(data, get_theme_element("TODO:fill-this-in", default = statistic), statistic ), - sort = sort + sort = + .ifelse1( + missing(sort), + get_theme_element("TODO:fill-this-in", default = sort), + sort + ) ) # fill in unspecified variables cards::fill_formula_selectors( @@ -99,6 +104,10 @@ tbl_summary <- function(data, digits = digits ) + # sort requested columns by frequency + data <- .sort_data_infreq(data, sort) + + # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) call <- match.call() @@ -148,8 +157,7 @@ tbl_summary <- function(data, modify_table_styling( columns = all_stat_cols(), footnote = - .construct_summary_footnote(x$cards, x$inputs$include, x$inputs$statistic) |> - unlist() |> unique() |> paste(collapse = ", ") + .construct_summary_footnote(x$cards, x$inputs$include, x$inputs$statistic, x$inputs$type) ) x <- @@ -162,11 +170,24 @@ tbl_summary <- function(data, x } +.sort_data_infreq <- function(data, sort) { + # if no frequency sorts requested, just return data frame + if (every(sort, function(x) x %in% "alphanumeric")) return(data) + + for (i in seq_along(sort[intersect(names(sort), names(data))])) { + if (sort[[i]] %in% "frequency") { + data[[names(sort)[i]]] <- fct_infreq(data[[names(sort)[i]]]) + } + } + + data +} -.construct_summary_footnote <- function(card, include, statistic) { +.construct_summary_footnote <- function(card, include, statistic, type) { include |> lapply( function(variable) { + if (type[[variable]] %in% "continuous2") return(NULL) card |> dplyr::filter(.data$variable %in% .env$variable) |> dplyr::select("stat_name", "stat_label") |> @@ -176,7 +197,11 @@ tbl_summary <- function(data, {gsub(pattern = "(%%)+", replacement = "%", x = .)} } ) |> - stats::setNames(include) + stats::setNames(include) |> + compact() |> + unlist() |> + unique() |> + paste(collapse = ", ") } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index f34b6b63dd..4fc6721e67 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -15,7 +15,7 @@ tbl_summary( missing = c("ifany", "no", "always"), missing_text = "Unknown", missing_stat = "{N_miss}", - sort = all_categorical() ~ "alphanumeric", + sort = all_categorical(FALSE) ~ "alphanumeric", percent = c("column", "row", "cell"), include = everything() ) From f523d1916c9e086f98e44ddeadd571631e6cbc41 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 30 Dec 2023 14:26:35 -0800 Subject: [PATCH 13/74] moving indentation to its own table styling enttry (#1584) * moving indentation to its own table styling enttry * Update NEWS.md --- NEWS.md | 4 + R/as_gt.R | 7 +- R/modify_table_styling.R | 118 +++++++++++++++----- R/tbl_summary.R | 2 +- R/utils-as.R | 93 ++++++--------- R/utils-gtsummary_core.R | 9 +- man/dot-table_styling_expr_to_row_number.Rd | 6 + man/modify_table_styling.Rd | 11 +- 8 files changed, 154 insertions(+), 96 deletions(-) diff --git a/NEWS.md b/NEWS.md index 498e3d98f7..6bcca00f64 100644 --- a/NEWS.md +++ b/NEWS.md @@ -12,6 +12,10 @@ * Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be explicitly defined in a factor. +* Previously, indentation was handled with `modify_table_styling(text_format = c("indent", "indent2"))`, which would indent a cell 4 and 8 spaces, respectively. Handling of indentation has been migrated to `modify_table_styling(indentation = integer())`, and by default, the label column is indented to zero spaces. This makes it easier to indent a group of rows. + +* The inputs for `modify_table_styling(undo_text_format)` has been updated to mirror its counterpart `modify_table_styling(text_format)` and no longer accepts `TRUE` or `FALSE`. + #### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. diff --git a/R/as_gt.R b/R/as_gt.R index fcef710018..0870de2d6d 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -134,14 +134,13 @@ table_styling_to_gt_calls <- function(x, ...) { ) # indent --------------------------------------------------------------------- - df_indent <- x$table_styling$text_format %>% dplyr::filter(.data$format_type == "indent") gt_calls[["indent"]] <- map( - seq_len(nrow(df_indent)), + seq_len(nrow(x$table_styling$indentation)), ~ expr(gt::text_transform( locations = gt::cells_body( - columns = !!df_indent$column[[.x]], - rows = !!df_indent$row_numbers[[.x]] + columns = !!x$table_styling$indentation$column[[.x]], + rows = !!x$table_styling$indentation$row_numbers[[.x]] ), fn = function(x) paste0("\U00A0\U00A0\U00A0\U00A0", x) )) diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index ff0da28565..f9d453311f 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -17,9 +17,9 @@ #' @param hide logical indicating whether to hide column from output #' @param align string indicating alignment of column, must be one of #' `c("left", "right", "center")` -#' @param text_format string indicated which type of text formatting to apply to the rows and columns. -#' Must be one of `c("bold", "italic", "indent", "indent2")`. Do not assign -#' both `"indent"` and `"indent2"` to the same cell. +#' @param text_format,undo_text_format +#' string indicated which type of text formatting to apply/remove to the rows and columns. +#' Must be one of `c("bold", "italic")`. #' @param text_interpret string, must be one of `"md"` or `"html"` #' @param fmt_fun function that formats the statistics in the #' columns/rows in `columns=` and `rows=` @@ -28,13 +28,12 @@ #' @param footnote string with text for footnote #' @param spanning_header string with text for spanning header #' @param missing_symbol string indicating how missing values are formatted. -#' @param undo_text_format rarely used. Logical that undoes the indent, bold, -#' and italic styling when `TRUE` #' @param cols_merge_pattern \lifecycle{experimental} glue-syntax string #' indicating how to merge #' columns in `x$table_body`. For example, to construct a confidence interval #' use `"{conf.low}, {conf.high}"`. The first column listed in the pattern #' string must match the single column name passed in `columns=`. +#' @param indentation an integer indicating how many space to indent text #' #' @seealso `modify_table_body()` #' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} @@ -75,8 +74,6 @@ #' version of the quosure is the same as the quosure (i.e. no evaluated #' objects), there should be no issues. Regardless, this argument is used #' internally with care, and it is _not_ recommended for users. - - modify_table_styling <- function(x, columns, rows = NULL, @@ -89,30 +86,78 @@ modify_table_styling <- function(x, missing_symbol = NULL, fmt_fun = NULL, text_format = NULL, - undo_text_format = FALSE, + undo_text_format = NULL, + indentation = NULL, text_interpret = c("md", "html"), cols_merge_pattern = NULL) { updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) # checking inputs ------------------------------------------------------------ assert_class(x, "gtsummary") - text_interpret <- match.arg(text_interpret) %>% - { - paste0("gt::", .) + # deprecation ---------------------------------------------------------------- + if (isTRUE(undo_text_format)) { + # set new values for the user + if (any(c("indent", "indent2") %in% text_format)) { + indentation <- 0L } - if (!is.null(text_format)) { - text_format <- match.arg(text_format, - choices = c("bold", "italic", "indent", "indent2"), - several.ok = TRUE + undo_text_format <- text_format |> setdiff(c("indent", "indent2")) + text_format <- NULL + + updated_call <- + match.call() |> + as.list() |> + utils::modifyList( + list(text_format = NULL, undo_text_format = undo_text_format, indentation = indentation) + ) |> + compact() + if (nchar(expr_deparse(updated_call[["x"]])) > 30L) updated_call[["x"]] <- expr(.) + updated_call <- as.call(updated_call) |> expr_deparse(width = Inf) + + lifecycle::deprecate_warn( + when = "2.0.0", + what = "gtsummary::modify_table_styling(undo_text_format = 'must be one of \"bold\" or \"italic\"')", + details = glue::glue("Update function call to `{updated_call}`.") + ) + } + if (any(c("indent", "indent2") %in% text_format)) { + lst_new_args <- + list( + indentation = ifelse("indent" %in% text_format, 4L, 8L), + text_format = + text_format |> + setdiff(c("indent", "indent2")) %>% + {.ifelse1(is_empty(.), NULL, .)} #nolint + ) + env_bind(.env = current_env(), !!!lst_new_args) + + updated_call <- + match.call() |> + as.list() |> + utils::modifyList(lst_new_args) |> + compact() + if (nchar(expr_deparse(updated_call[["x"]])) > 30) updated_call[["x"]] <- expr(.) + updated_call <- as.call(updated_call) |> expr_deparse(width = Inf) + + lifecycle::deprecate_warn( + when = "2.0.0", + what = "gtsummary::modify_table_styling(text_format = 'must be one of \"bold\" or \"italic\"')", + details = glue::glue("Update function call to `{updated_call}`.") ) } + + text_interpret <- paste0("gt::", arg_match(text_interpret)) + + if (!is.null(text_format)) { + text_format <- arg_match(text_format, values = c("bold", "italic"), multiple = TRUE) + } + if (!is.null(undo_text_format)) { + undo_text_format <- arg_match(undo_text_format, values = c("bold", "italic"), multiple = TRUE) + } rows <- enquo(rows) rows_eval_error <- tryCatch( eval_tidy(rows, data = x$table_body) %>% - { - !is.null(.) && !is.logical(.) - }, + {!is.null(.) && !is.logical(.)}, #nolint error = function(e) TRUE ) if (rows_eval_error) { @@ -224,14 +269,37 @@ modify_table_styling <- function(x, column = columns, rows = list(rows), format_type = text_format, - undo_text_format = undo_text_format + undo_text_format = FALSE ) %>% - { - tidyr::expand_grid(!!!.) - } %>% - { - dplyr::bind_rows(x$table_styling$text_format, .) - } + {tidyr::expand_grid(!!!.)} %>% # nolint + {dplyr::bind_rows(x$table_styling$text_format, .)} # nolint + } + if (!is.null(undo_text_format)) { + x$table_styling$text_format <- + list( + column = columns, + rows = list(rows), + format_type = undo_text_format, + undo_text_format = TRUE + ) %>% + {tidyr::expand_grid(!!!.)} %>% # nolint + {dplyr::bind_rows(x$table_styling$text_format, .)} # nolint + } + + # indentation ---------------------------------------------------------------- + if (!is.null(indentation)) { + if (!rlang::is_scalar_integerish(indentation)) { + cli::cli_abort("The {.arg indentation} argument must be a scalar integer.") + } + x$table_styling$indentation <- + dplyr::bind_rows( + x$table_styling$indentation, + dplyr::tibble( + column = columns, + rows = list(rows), + n_spaces = as.integer(indentation) + ) + ) } # missing_symbol ------------------------------------------------------------- diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 2da9c03d48..3ee2869b00 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -152,7 +152,7 @@ tbl_summary <- function(data, columns = "label", label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), - text_format = "indent" + indentation = 4L ) |> modify_table_styling( columns = all_stat_cols(), diff --git a/R/utils-as.R b/R/utils-as.R index dc557875fe..894aa32ad3 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -1,59 +1,12 @@ -.convert_header_to_rows_one_column <- function(x, column) { - if (column %in% c("footnote", "footnote_abbrev")) { - x$table_styling[[column]] <- - x$table_header %>% - dplyr::select(all_of(c("column", .env$column))) %>% - set_names(c("column", "footnote")) %>% - dplyr::filter(!is.na(.data$footnote)) %>% - dplyr::mutate( - rows = list(expr(NULL)), - text_interpret = "gt::md" - ) %>% - dplyr::select(all_of(c("column", "rows", "text_interpret", "footnote"))) - } - else if (column %in% c("indent", "bold", "italic")) { - x$table_styling$text_format <- - x$table_header %>% - dplyr::select(all_of(c("column", .env$column))) %>% - dplyr::filter(!is.na(.data[[column]])) %>% - set_names(c("column", "rows")) %>% - dplyr::mutate( - rows = map(.data$rows, ~ parse_expr(.x)), - format_type = .env$column, - undo_text_format = FALSE - ) %>% - dplyr::bind_rows(x$table_styling$text_format) - } - else if (column %in% "missing_emdash") { - x$table_styling[["fmt_missing"]] <- - x$table_header %>% - dplyr::select(all_of(c("column", .env$column))) %>% - dplyr::filter(!is.na(.data[[column]])) %>% - set_names(c("column", "rows")) %>% - dplyr::mutate( - rows = map(.data$rows, ~ parse_expr(.x)), - symbol = get_theme_element("tbl_regression-str:ref_row_text", - default = "\U2014" - ) - ) - } - else if (column %in% "fmt_fun") { - x$table_styling[[column]] <- - x$table_header %>% - dplyr::select(all_of(c("column", .env$column))) %>% - dplyr::filter(!map_lgl(.data[[column]], is.null)) %>% - dplyr::mutate(rows = list(expr(NULL))) %>% - dplyr::select(all_of(c("column", "rows", .env$column))) - } - - # return gtsummary table - x -} # takes a table_body and a character rows expression, and returns the resulting row numbers .rows_expr_to_row_numbers <- function(table_body, rows, return_when_null = NA) { rows_evaluated <- rlang::eval_tidy(rows, data = table_body) + # if a single lgl value, then expand it to the length of the tabel_body + if (is_scalar_logical(rows_evaluated)) + rows_evaluated <- rep_len(rows_evaluated, length.out = nrow(table_body)) + if (is.null(rows_evaluated)) { return(return_when_null) } @@ -83,11 +36,11 @@ #' @keywords internal #' @export #' -# #' @examples -# #' tbl <- -# #' trial %>% -# #' tbl_summary(include = c(age, grade)) %>% -# #' .table_styling_expr_to_row_number() +#' @examples +#' tbl <- +#' trial %>% +#' tbl_summary(include = c(age, grade)) %>% +#' .table_styling_expr_to_row_number() .table_styling_expr_to_row_number <- function(x) { # text_format ---------------------------------------------------------------- x$table_styling$text_format <- @@ -117,6 +70,34 @@ dplyr::select("column", "row_numbers", everything()) %>% dplyr::ungroup() + # indentation ---------------------------------------------------------------- + x$table_styling$indentation <- + x$table_styling$indentation %>% + dplyr::filter(.data$column %in% .cols_to_show(x)) %>% + dplyr::rowwise() %>% + dplyr::mutate( + row_numbers = + switch(nrow(.) == 0, + integer(0) + ) %||% + .rows_expr_to_row_numbers( + x$table_body, .data$rows, + return_when_null = seq_len(nrow(x$table_body)) + ) %>% + list(), + ) %>% + dplyr::select(-"rows") %>% + tidyr::unnest("row_numbers") %>% + dplyr::group_by(.data$column, .data$row_numbers) %>% + dplyr::filter(dplyr::row_number() == dplyr::n()) %>% + dplyr::select("column", "row_numbers", "n_spaces") %>% + dplyr::ungroup() %>% + tidyr::nest(row_numbers = "row_numbers") %>% + dplyr::rowwise() %>% + dplyr::mutate(row_numbers = unlist(.data$row_numbers) %>% unname() %>% list()) %>% + dplyr::ungroup() |> + dplyr::filter(.data$n_spaces != 0) + # fmt_missing ---------------------------------------------------------------- x$table_styling$fmt_missing <- x$table_styling$fmt_missing %>% diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 848f5e660d..e0d51d32c3 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -34,11 +34,12 @@ construct_initial_table_styling <- function(x) { ) x$table_styling$indentation <- - if (all(c("label", "row_type") %in% x$table_styling$header$column)) { + # if there is a label column, make it + if ("label" %in% x$table_styling$header$column) { dplyr::tibble( - column = c("label", "label"), - rows = list(rlang::expr(TRUE), rlang::expr(.data$row_type %in% c("level", "missing"))), - n_spaces = c(0L, 4L) + column = "label", + rows = list(rlang::expr(TRUE)), + n_spaces = 0L ) } else { diff --git a/man/dot-table_styling_expr_to_row_number.Rd b/man/dot-table_styling_expr_to_row_number.Rd index c5a25fd87a..426fc79c5e 100644 --- a/man/dot-table_styling_expr_to_row_number.Rd +++ b/man/dot-table_styling_expr_to_row_number.Rd @@ -17,4 +17,10 @@ Ahead of a gtsummary object being converted to an output type, each logical expression saved in \code{x$table_styling} is converted to a list of row numbers. } +\examples{ +tbl <- + trial \%>\% + tbl_summary(include = c(age, grade)) \%>\% + .table_styling_expr_to_row_number() +} \keyword{internal} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 8b364720c0..d9ac50611a 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -17,7 +17,8 @@ modify_table_styling( missing_symbol = NULL, fmt_fun = NULL, text_format = NULL, - undo_text_format = FALSE, + undo_text_format = NULL, + indentation = NULL, text_interpret = c("md", "html"), cols_merge_pattern = NULL ) @@ -50,12 +51,10 @@ and text formatting. Default is \code{NULL}. See details below.} \item{fmt_fun}{function that formats the statistics in the columns/rows in \verb{columns=} and \verb{rows=}} -\item{text_format}{string indicated which type of text formatting to apply to the rows and columns. -Must be one of \code{c("bold", "italic", "indent", "indent2")}. Do not assign -both \code{"indent"} and \code{"indent2"} to the same cell.} +\item{text_format, undo_text_format}{string indicated which type of text formatting to apply/remove to the rows and columns. +Must be one of \code{c("bold", "italic")}.} -\item{undo_text_format}{rarely used. Logical that undoes the indent, bold, -and italic styling when \code{TRUE}} +\item{indentation}{an integer indicating how many space to indent text} \item{text_interpret}{string, must be one of \code{"md"} or \code{"html"}} From 85905a26ab16a29e9e935fd26a196847e0a0c575 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 1 Jan 2024 14:50:08 -0800 Subject: [PATCH 14/74] check updates --- DESCRIPTION | 2 +- R/as_gt.R | 2 +- R/modify_column_hide.R | 4 +-- R/modify_fmt_fun.R | 2 +- R/modify_table_styling.R | 2 +- R/standalone-checks.R | 41 ++++++++++++++++++++++++++++-- R/tbl_summary.R | 22 ++++++---------- man/check_class.Rd | 54 ++++++++++++++++++++++++++++++++++++++++ man/check_not_missing.Rd | 35 ++++++++++++++++++++++++++ 9 files changed, 141 insertions(+), 23 deletions(-) create mode 100644 man/check_class.Rd create mode 100644 man/check_not_missing.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f95a237d67..e2bf3d14a6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9004), + cards (>= 0.0.0.9008), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/R/as_gt.R b/R/as_gt.R index 0870de2d6d..e51562b1e8 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -25,7 +25,7 @@ #' # tbl_summary(by = trt) %>% #' # as_gt() as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { - assert_class(x, "gtsummary") + check_class(x, "gtsummary") # running pre-conversion function, if present -------------------------------- # x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index ab81975dff..37d568a0ee 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -23,7 +23,7 @@ NULL #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @export modify_column_hide <- function(x, columns) { - assert_class(x, "gtsummary") + check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) x <- modify_table_styling( @@ -39,7 +39,7 @@ modify_column_hide <- function(x, columns) { #' @rdname modify_column_hide #' @export modify_column_unhide <- function(x, columns) { - assert_class(x, "gtsummary") + check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) x <- modify_table_styling( diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R index 41569197fe..018b625e89 100644 --- a/R/modify_fmt_fun.R +++ b/R/modify_fmt_fun.R @@ -30,7 +30,7 @@ # #' } modify_fmt_fun <- function(x, update, rows = NULL) { updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) - assert_class(x, "gtsummary") + check_class(x, "gtsummary") # converting update arg to a tidyselect list --------------------------------- cards::process_formula_selectors( diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index f9d453311f..c5490a3aff 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -92,7 +92,7 @@ modify_table_styling <- function(x, cols_merge_pattern = NULL) { updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) # checking inputs ------------------------------------------------------------ - assert_class(x, "gtsummary") + check_class(x, "gtsummary") # deprecation ---------------------------------------------------------------- if (isTRUE(undo_text_format)) { diff --git a/R/standalone-checks.R b/R/standalone-checks.R index 1b77eaaa98..dcff9336b2 100644 --- a/R/standalone-checks.R +++ b/R/standalone-checks.R @@ -13,12 +13,49 @@ # # nocov start -assert_class <- function(x, class, arg_name = rlang::caller_arg(x), env = rlang::caller_env()) { +#' Check Argument Class +#' +#' @param x object whose class will be checked +#' @param class character vector or string indicating accepted classes. +#' Passed to `inherits(what=class)` +#' @param allow_empty logical indicating whether empty arguments are allowed. +#' Empty is defined by `rlang::is_empty()`, where empty elements include +#' `NULL`, `list()`, `character()`, etc. Default is `FALSE` +#' @param arg_name string indicating the argument name. Default is `rlang::caller_arg(x)` +#' @param allow_null Logical indicating whether a NULL value will pass the test. +#' Default is `FALSE` +#' @inheritParams cli::cli_abort +#' @keywords internal +#' @name check_class +NULL + +#' @rdname check_class +check_class <- function(x, class, allow_empty = FALSE, + arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { if (!inherits(x, class)) { cli::cli_abort( c("Argument {.arg {arg_name}} must be class {.cls {class}}.", "i" = "The class of {.arg {arg_name}} is {.cls {class(x)}}."), - call = env + call = call ) } + invisible() +} + +#' @rdname check_class +check_class_data_frame <- function(x, arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { + check_class(x = x, class = "data.frame", arg_name = arg_name, call = call) +} + +#' Check Argument not Missing +#' +#' @param x argument to check +#' @param arg_name string indicating the name of the argument. Used in the error messaging. +#' @inheritParams check_class +#' @keywords internal +check_not_missing <- function(x, arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { + if (missing(x)) { + cli::cli_abort("The {.arg {arg_name}} argument cannot be missing.", call = call) + } + invisible() } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 3ee2869b00..82d406b4dc 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -51,13 +51,16 @@ tbl_summary <- function(data, sort = all_categorical(FALSE) ~ "alphanumeric", percent = c("column", "row", "cell"), include = everything()) { + # data argument checks ------------------------------------------------------- + check_not_missing(data) + check_class_data_frame(data) + # process arguments ---------------------------------------------------------- data <- dplyr::ungroup(data) - cards::process_selectors(data, by = {{by}}, include = {{include}}) + cards::process_selectors(data, by = {{ by }}, include = {{ include }}) include <- setdiff(include, by) # remove by variable from list vars included - include <- .remove_na_columns(data, include) - missing <- rlang::arg_match(arg = missing) - percent <- rlang::arg_match(arg = percent) + missing <- arg_match(arg = missing) + percent <- arg_match(arg = percent) cards::process_formula_selectors(data = data[include], value = value) # assign summary type -------------------------------------------------------- @@ -210,17 +213,6 @@ tbl_summary <- function(data, names(x)[unlist(x) %in% type] } -.remove_na_columns <- function(data, include) { - is_all_na <- map_lgl(include, function(x) all(is.na(x))) - if (any(is_all_na)) { - paste("Columns {.val {include[is_all_na]}} are all {.cls NA}", - "and have been removed from the summary table.") |> - cli::cli_inform() - } - - include[!is_all_na] -} - .assign_default_values <- function(data, value, type) { lapply( names(data), diff --git a/man/check_class.Rd b/man/check_class.Rd new file mode 100644 index 0000000000..183396431e --- /dev/null +++ b/man/check_class.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/standalone-checks.R +\name{check_class} +\alias{check_class} +\alias{check_class_data_frame} +\title{Check Argument Class} +\usage{ +check_class( + x, + class, + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), + call = rlang::caller_env() +) + +check_class_data_frame( + x, + arg_name = rlang::caller_arg(x), + call = rlang::caller_env() +) +} +\arguments{ +\item{x}{object whose class will be checked} + +\item{class}{character vector or string indicating accepted classes. +Passed to \code{inherits(what=class)}} + +\item{allow_empty}{logical indicating whether empty arguments are allowed. +Empty is defined by \code{rlang::is_empty()}, where empty elements include +\code{NULL}, \code{list()}, \code{character()}, etc. Default is \code{FALSE}} + +\item{arg_name}{string indicating the argument name. Default is \code{rlang::caller_arg(x)}} + +\item{call}{The execution environment of a currently running +function, e.g. \code{call = caller_env()}. The corresponding function +call is retrieved and mentioned in error messages as the source +of the error. + +You only need to supply \code{call} when throwing a condition from a +helper function which wouldn't be relevant to mention in the +message. + +Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to +respectively not display any call or hard-code a code to display. + +For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} + +\item{allow_null}{Logical indicating whether a NULL value will pass the test. +Default is \code{FALSE}} +} +\description{ +Check Argument Class +} +\keyword{internal} diff --git a/man/check_not_missing.Rd b/man/check_not_missing.Rd new file mode 100644 index 0000000000..a744a7d379 --- /dev/null +++ b/man/check_not_missing.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/standalone-checks.R +\name{check_not_missing} +\alias{check_not_missing} +\title{Check Argument not Missing} +\usage{ +check_not_missing( + x, + arg_name = rlang::caller_arg(x), + call = rlang::caller_env() +) +} +\arguments{ +\item{x}{argument to check} + +\item{arg_name}{string indicating the name of the argument. Used in the error messaging.} + +\item{call}{The execution environment of a currently running +function, e.g. \code{call = caller_env()}. The corresponding function +call is retrieved and mentioned in error messages as the source +of the error. + +You only need to supply \code{call} when throwing a condition from a +helper function which wouldn't be relevant to mention in the +message. + +Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to +respectively not display any call or hard-code a code to display. + +For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} +} +\description{ +Check Argument not Missing +} +\keyword{internal} From 0ea2bfce975fbd2b4267cf43ea100933fa4b5219 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 4 Jan 2024 18:20:25 -0800 Subject: [PATCH 15/74] Update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e2bf3d14a6..e94414b283 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9008), + cards (>= 0.0.0.9009), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), From b94919d4a60285581b521c9c1945404bb3853591 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 12 Jan 2024 18:13:03 -0800 Subject: [PATCH 16/74] Adding `tbl_summary(percent)` argument (#1585) * updates * updates --- DESCRIPTION | 2 +- R/bridge_summary.R | 17 +++++++++-------- R/tbl_summary.R | 9 +++++---- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e94414b283..95d33b9021 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9009), + cards (>= 0.0.0.9010), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 43102fa3ab..cc2cc1cd14 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -140,7 +140,7 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { .data$variable_level %in% list(NULL) | .data$variable_level %in% list(value[[.data$variable[1]]]) ) |> - # updating the context to continuous, because it will be process that way below + # updating the context to continuous, because it will be processed that way below dplyr::mutate( context = ifelse(.data$context %in% "categorical", "continuous", .data$context) ) @@ -169,8 +169,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin cards::get_ard_statistics( df_variable_stats, .data$variable_level %in% list(NULL), - .column = "statistic_fmt", - .attributes = NULL + .column = "statistic_fmt" ) str_statistic_pre_glue <- @@ -193,7 +192,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin glue::glue( str_to_glue, .envir = - cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt", .attributes = NULL) |> + cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt") |> c(lst_variable_stats) ) |> as.character() @@ -286,7 +285,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin stat = glue::glue( str_to_glue, - .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) + .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") ) |> as.character() } @@ -299,7 +298,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin label = glue::glue( str_to_glue, - .envir = cards::get_ard_statistics(.x, .column = "stat_label", .attributes = NULL) + .envir = cards::get_ard_statistics(.x, .column = "stat_label") ) |> as.character() } @@ -362,6 +361,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { + if (is_empty(variables)) return(dplyr::tibble()) # subsetting cards object on continuous summaries ---------------------------- card <- x$cards |> @@ -379,7 +379,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing stat = glue::glue( x$inputs$statistic[[.data$variable[1]]], - .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt", .attributes = NULL) + .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") ) |> as.character() ) @@ -502,7 +502,8 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { df_by_stats |> dplyr::filter(.data$stat_name %in% "N") |> dplyr::pull("statistic") |> - unlist() + unlist() |> + getElement(1L) ) |> dplyr::left_join( df_by_stats_wide, diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 82d406b4dc..88de91e383 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -125,14 +125,15 @@ tbl_summary <- function(data, # tabulate categorical summaries cards::ard_categorical( data, - by = by, - variables = .get_variables_by_type(type, c("categorical", "dichotomous")), - fmt_fn = digits + by = all_of(by), + variables = all_of(.get_variables_by_type(type, c("categorical", "dichotomous"))), + fmt_fn = digits, + denominator = percent ), # calculate categorical summaries cards::ard_continuous( data, - by = by, + by = all_of(by), variables = .get_variables_by_type(type, c("continuous", "continuous2")), fmt_fn = digits ) From 0ed6149462f369bd260218e28a04a8de2c0db1a6 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 3 Feb 2024 18:39:46 -0800 Subject: [PATCH 17/74] progress (#1595) --- DESCRIPTION | 4 +- R/assign_summary_digits.R | 2 +- R/assign_summary_type.R | 38 ++++-- R/modify_fmt_fun.R | 10 +- R/modify_header.R | 8 +- R/select_helpers.R | 8 +- R/standalone-checks.R | 38 +++++- R/tbl_summary.R | 246 ++++++++++++++++++++++++++++++++----- man/assign_summary_type.Rd | 18 ++- man/check_class.Rd | 5 +- man/check_length.Rd | 40 ++++++ man/check_not_missing.Rd | 6 +- man/tbl_summary.Rd | 126 +++++++++++++++---- 13 files changed, 454 insertions(+), 95 deletions(-) create mode 100644 man/check_length.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 95d33b9021..7250e2f4fe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9010), + cards (>= 0.0.0.9024), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), @@ -70,4 +70,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index cbebcb11a8..1731bdd78a 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -30,7 +30,7 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { # if the passed value fully specifies the formatting for each 'statistic', # then return it. Otherwise, the remaining stat will be filled below if (setequal(statistic[[variable]], names(digits[[variable]]))) { - return(digits[[variable]]) + return(lst_all_fmt_fns |> utils::modifyList(digits[[variable]])) } } diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index f09466332b..b4bfbcc042 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -3,11 +3,18 @@ #' Function inspects data and assigns a summary type when not specified #' in the `type` argument. #' -#' @param data a data frame -#' @param variables character vector of column names in `data` -#' @param value named list of values to show for dichotomous variables, where -#' the names are the variables -#' @param type named list of summary types, where names are the variables +#' @param data (`data.frame`)\cr +#' a data frame +#' @param variables (`character`)\cr +#' character vector of column names in `data` +#' @param value (`named list`)\cr +#' named list of values to show for dichotomous variables, where +#' the names are the variables +#' @param type (`named list`)\cr +#' named list of summary types, where names are the variables +#' @param cat_threshold (`integer`)\cr +#' for base R numeric classes with fewer levels than +#' this threshold will default to a categorical summary. Default is `10L` #' #' @return named list #' @export @@ -18,7 +25,7 @@ #' variables = c("age", "grade", "response"), #' value = NULL #' ) -assign_summary_type <- function(data, variables, value, type = NULL) { +assign_summary_type <- function(data, variables, value, type = NULL, cat_threshold = 10L) { # base classes that can be summarized as continuous base_numeric_classes <- c("numeric", "integer", "difftime", "Date", "POSIXt", "double") @@ -32,18 +39,29 @@ assign_summary_type <- function(data, variables, value, type = NULL) { return(type[[variable]]) } + # if user supplied a dichotomous value, make it dichotomous if (!is.null(.get_default_dichotomous_value(data[[variable]]))) { return("dichotomous") } - # factors and characters are categorical - if (inherits(data[[variable]], c("factor", "character"))) { + # factors are categorical + if (inherits(data[[variable]], "factor")) { return("categorical") } - # numeric variables with fewer than 10 levels will be categorical + # if all missing, the continuous + if (all(is.na(data[[variable]]))) { + return("continuous") + } + + # characters are categorical + if (inherits(data[[variable]], "character")) { + return("categorical") + } + + # numeric variables with fewer than 'cat_threshold' levels will be categorical if (inherits(data[[variable]], base_numeric_classes) && - length(unique(stats::na.omit(data[[variable]]))) < 10) { + length(unique(stats::na.omit(data[[variable]]))) < cat_threshold) { return("categorical") } diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R index 018b625e89..04ba7e36e0 100644 --- a/R/modify_fmt_fun.R +++ b/R/modify_fmt_fun.R @@ -35,16 +35,14 @@ modify_fmt_fun <- function(x, update, rows = NULL) { # converting update arg to a tidyselect list --------------------------------- cards::process_formula_selectors( data = x$table_body, - udpate = update + update = update ) cards::check_list_elements( - check = function(x) is_function(x), - error_msg = list( - check = "The value passed in {.arg {arg_name}} for variable {.val {variable}} must be a function." - ) + x = update, + predicate = function(x) is_function(x), + error_msg = "The value passed in {.arg {arg_name}} for variable {.val {variable}} must be a function." ) - # updating formatting functions ---------------------------------------------- x <- modify_table_styling( diff --git a/R/modify_header.R b/R/modify_header.R index 1848f2b616..c5b5c93110 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -18,9 +18,11 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), cards::process_formula_selectors(data = x$table_body, dots = dots) cards::check_list_elements( - dots = function(x) is_string(x), - error_msg = list(dots = c("All values passed in {.arg ...} must be strings.", - "i" = "For example, {.code label = '**Variable**'}")) + x = dots, + predicate = function(x) is_string(x), + error_msg = + c("All values passed in {.arg ...} must be strings.", + "i" = "For example, {.code label = '**Variable**'}") ) # evaluate the strings with glue diff --git a/R/select_helpers.R b/R/select_helpers.R index 279428bc5c..274ffc7c2b 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -38,13 +38,13 @@ NULL all_continuous <- function(continuous2 = TRUE) { types <- if (continuous2) c("continuous", "continuous2") else "continuous" - where(function(x) attr(x, "gtsummary.type") %in% types) + where(function(x) isTRUE(attr(x, "gtsummary.type") %in% types)) } #' @rdname select_helpers #' @export all_continuous2 <- function() { - where(function(x) attr(x, "gtsummary.type") %in% "continuous2") + where(function(x) isTRUE(attr(x, "gtsummary.type") %in% "continuous2")) } #' @rdname select_helpers @@ -52,13 +52,13 @@ all_continuous2 <- function() { all_categorical <- function(dichotomous = TRUE) { types <- if (dichotomous) c("categorical", "dichotomous") else "categorical" - where(function(x) attr(x, "gtsummary.type") %in% types) + where(function(x) isTRUE(attr(x, "gtsummary.type") %in% types)) } #' @rdname select_helpers #' @export all_dichotomous <- function() { - where(function(x) attr(x, "gtsummary.type") %in% "dichotomous") + where(function(x) isTRUE(attr(x, "gtsummary.type") %in% "dichotomous")) } # #' @rdname select_helpers diff --git a/R/standalone-checks.R b/R/standalone-checks.R index dcff9336b2..03f79719f7 100644 --- a/R/standalone-checks.R +++ b/R/standalone-checks.R @@ -18,6 +18,7 @@ #' @param x object whose class will be checked #' @param class character vector or string indicating accepted classes. #' Passed to `inherits(what=class)` +#' @param length if not `NULL`, the `x` object must be length specified #' @param allow_empty logical indicating whether empty arguments are allowed. #' Empty is defined by `rlang::is_empty()`, where empty elements include #' `NULL`, `list()`, `character()`, etc. Default is `FALSE` @@ -30,8 +31,15 @@ NULL #' @rdname check_class -check_class <- function(x, class, allow_empty = FALSE, +check_class <- function(x, class, length = NULL, allow_empty = FALSE, arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible()) + } + if (!is.null(length)) { + check_length(x = x, length = length, arg_name = arg_name, call = call) + } + if (!inherits(x, class)) { cli::cli_abort( c("Argument {.arg {arg_name}} must be class {.cls {class}}.", @@ -43,7 +51,7 @@ check_class <- function(x, class, allow_empty = FALSE, } #' @rdname check_class -check_class_data_frame <- function(x, arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { +check_class_data_frame <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { check_class(x = x, class = "data.frame", arg_name = arg_name, call = call) } @@ -53,9 +61,33 @@ check_class_data_frame <- function(x, arg_name = rlang::caller_arg(x), call = rl #' @param arg_name string indicating the name of the argument. Used in the error messaging. #' @inheritParams check_class #' @keywords internal -check_not_missing <- function(x, arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { +check_not_missing <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { if (missing(x)) { cli::cli_abort("The {.arg {arg_name}} argument cannot be missing.", call = call) } invisible() } + +#' Check Length +#' +#' @param msg (`string`)\cr +#' string passed to `cli::cli_abort(message=)` +#' @param length (`integer(1)`)\cr +#' integer specifying the required length +#' @inheritParams check_class +#' @keywords internal +#' @name check_length +NULL + +#' @rdname check_length +check_length <- function(x, length, arg_name = caller_arg(x), call = parent.frame()) { + if (length(x) != length) { + cli::cli_abort("The {.arg {arg_name}} argument must be length {.val {length}}.", call = call) + } + invisible() +} + +#' @rdname check_length +check_scalar <- function(x, arg_name = caller_arg(x), call = parent.frame()) { + check_length(x = x, length = 1L, arg_name = arg_name, call = call) +} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 88de91e383..4a1a008924 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -1,9 +1,24 @@ -#' Title +#' Summary statistics table #' -#' @param data TODO: -#' @param by TODO: -#' @param label TODO: -#' @param statistic TODO: +#' The `tbl_summary()` function calculates descriptive statistics for +#' continuous, categorical, and dichotomous variables. +#' Review the +#' \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} +#' for detailed examples. +#' +#' @param data (`data.frame`)\cr A data frame +#' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' A single column from `data`. Summary statistics will be stratified by this variable. +#' Default is `NULL` +#' @param label ([`formula-list-selector`][syntax])\cr +#' Used to override default labels in summary table, e.g. `list(age = "Age, years")`. +#' The default for each variable is the column label attribute, `attr(., 'label')`. +#' If no label has been set, the column name is used. +#' @param statistic ([`formula-list-selector`][syntax])\cr +#' Used to specify the summary statistics for each variable. +#' The default is +#' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. +#' See below for details. #' @param digits TODO: #' @param type TODO: #' @param value TODO: @@ -17,25 +32,85 @@ #' @return a gtsummary table of class `"tbl_summary"` #' @export #' +#' @section statistic argument: +#' The statistic argument specifies the statistics presented in the table. The +#' input dictates the summary statistics presented in the table. For example, +#' `statistic = list(age ~ "{mean} ({sd})")` would report the mean and +#' standard deviation for age; `statistic = list(all_continuous() ~ "{mean} ({sd})")` +#' would report the mean and standard deviation for all continuous variables. +#' +#' The values are interpreted using [`glue::glue()`] syntax: +#' a name that appears between curly brackets will be interpreted as a function +#' name and the formatted result of that function will be placed in the table. +#' +#' For categorical variables, the following statistics are available to display. +#' \itemize{ +#' \item `{n}` frequency +#' \item `{N}` denominator, or cohort size +#' \item `{p}` formatted percentage +#' } +#' +#' For continuous variables, **any univariate function may be used**. Below is a list +#' of the _most commonly_ used statistics. +#' \itemize{ +#' \item `{median}` median +#' \item `{mean}` mean +#' \item `{sd}` standard deviation +#' \item `{var}` variance +#' \item `{min}` minimum +#' \item `{max}` maximum +#' \item `{sum}` sum +#' \item `{p##}` any integer percentile, where `##` is an integer from 0 to 100 +#' } +#' +#' When the summary type is `"continuous2"`, pass a vector of statistics. +#' Each element of the vector will result in a separate row in the summary table. +#' +#' For both categorical and continuous variables, statistics on the number of +#' missing and non-missing observations and their proportions are available to +#' display. +#' \itemize{ +#' \item `{N_obs}` total number of observations +#' \item `{N_miss}` number of missing observations +#' \item `{N_nonmiss}` number of non-missing observations +#' \item `{p_miss}` percentage of observations missing +#' \item `{p_nonmiss}` percentage of observations not missing +#' } +#' +#' @export +#' @return A table of class `c('tbl_summary', 'gtsummary')` +#' +#' @family tbl_summary tools +#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial +#' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples +#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' @author Daniel D. Sjoberg #' @examples -#' tbl <- +#' # Example 1 ---------------------------------- +#' tbl_summary_ex1 <- +#' trial |> +#' select(age, grade, response) |> +#' tbl_summary() +#' +#' # Example 2 ---------------------------------- +#' tbl_summary_ex2 <- +#' trial |> +#' select(age, grade, response, trt) |> +#' tbl_summary( +#' by = trt, +#' label = list(age = "Patient Age"), +#' statistic = list(all_continuous() ~ "{mean} ({sd})"), +#' digits = list(age ~ c(0, 1)) +#' ) +#' +#' # Example 3 ---------------------------------- +#' tbl_summary_ex3 <- +#' trial |> +#' select(age, marker) |> #' tbl_summary( -#' data = mtcars, -#' include = c("cyl", "am", "mpg", "hp"), -#' type = -#' list( -#' cyl = "categorical", -#' am = "dichotomous", -#' mpg = "continuous", -#' hp = "continuous2" -#' ), -#' value = list(am = 1), -#' statistic = -#' list( -#' c(cyl, am) ~ "{n} ({p}%)", -#' mpg = "{mean} ({sd})", -#' hp = c("{mean}", "{median}") -#' ) +#' type = all_continuous() ~ "continuous2", +#' statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), +#' missing = "no" #' ) tbl_summary <- function(data, by = NULL, @@ -54,6 +129,7 @@ tbl_summary <- function(data, # data argument checks ------------------------------------------------------- check_not_missing(data) check_class_data_frame(data) + .data_dim_checks(data) # process arguments ---------------------------------------------------------- data <- dplyr::ungroup(data) @@ -74,13 +150,14 @@ tbl_summary <- function(data, # fill in any types not specified by user type <- utils::modifyList(default_types, type) } + data <- .add_summary_type_as_attr(data, type) value <- .assign_default_values(data[include], value, type) # evaluate the remaining list-formula arguments ------------------------------ # processed arguments are saved into this env cards::process_formula_selectors( - data = .add_summary_type_as_attr(data[include], type), + data = data[include], label = label, statistic = .ifelse1( @@ -95,26 +172,52 @@ tbl_summary <- function(data, sort ) ) + + cards::process_formula_selectors( + data = data[include], + digits = + .ifelse1( + missing(digits), + get_theme_element("TODO:fill-this-in", default = digits), + digits + ) + ) + # fill in unspecified variables cards::fill_formula_selectors( data[include], statistic = - get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])) + get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])), + sort = + get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["sort"]])), + digits = + get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["digits"]])) ) - cards::process_formula_selectors( - data = .add_summary_type_as_attr(data[include], type), - digits = digits + # fill each element of digits argument + # TODO: this needs to be updated to account for the scenario where there is a template override that may not fill in all the values + if (!missing(digits)) { + digits <- assign_summary_digits(data[include], statistic, type, digits = digits) + } + + # check inputs --------------------------------------------------------------- + check_class(missing_text, class = "character", length = 1L) + check_class(missing_stat, class = "character", length = 1L) + .check_haven_labelled(data[c(include, by)]) + .check_tbl_summary_args( + data = data, label = label, statistic = statistic, + digits = digits, type = type, value = value, sort = sort ) # sort requested columns by frequency + # TODO: Does this break the type attribute? If so, need to re-apply data <- .sort_data_infreq(data, sort) - # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) call <- match.call() + # construct cards ------------------------------------------------------------ cards <- cards::bind_ard( @@ -126,7 +229,7 @@ tbl_summary <- function(data, cards::ard_categorical( data, by = all_of(by), - variables = all_of(.get_variables_by_type(type, c("categorical", "dichotomous"))), + variables = all_categorical(), fmt_fn = digits, denominator = percent ), @@ -134,7 +237,7 @@ tbl_summary <- function(data, cards::ard_continuous( data, by = all_of(by), - variables = .get_variables_by_type(type, c("continuous", "continuous2")), + variables = all_continuous(), fmt_fn = digits ) ) @@ -204,8 +307,8 @@ tbl_summary <- function(data, stats::setNames(include) |> compact() |> unlist() |> - unique() |> - paste(collapse = ", ") + unique() %>% + {switch(!is.null(.), paste(collapse = ", "))} } @@ -234,3 +337,82 @@ tbl_summary <- function(data, ) |> stats::setNames(names(data)) } + + +.data_dim_checks <- function(data, call = rlang::caller_env()) { + # cannot be empty data frame + if (nrow(data) == 0L || ncol(data) == 0L) { + cli::cli_abort("Expecting {.arg data} argument to have at least 1 row and 1 column.", call = call) + } + invisible() +} + +.check_haven_labelled <- function(data) { + if (some(data, ~ inherits(., "haven_labelled"))) { + # list of columns with haven_labelled + haven_labelled_vars <- + map_lgl(data, ~ inherits(.x, "haven_labelled")) %>% + keep(identity) %>% + names() + + cnvt_funs <- + c("haven::as_factor", "labelled::to_factor", "labelled::unlabelled", "unclass") + + hyperlinks <- c( + "https://haven.tidyverse.org/articles/semantics.html", + "https://larmarange.github.io/labelled/articles/intro_labelled.html#unlabelled" + ) + + c( + "!" = "Column(s) {.val {haven_labelled_vars}} are class {.val haven_labelled}.", + "i" = "This is an intermediate datastructure not meant for analysis.", + "i" = "Convert columns with {.fun {cnvt_funs}}. Failure to convert may have unintended consequences or result in error.", + paste0("{.url ", hyperlinks, "}") + ) |> + cli::cli_inform() + } + + invisible() +} + + +.check_tbl_summary_args <- function(data, label, statistic, digits, type, value, sort, env = parent.frame()) { + # first check the structure of each of the inputs ---------------------------- + type_accepted <- c("continuous", "continuous2", "categorical", "dichotomous") + sort_accepted <- c("alphanumeric", "frequency") + + cards::check_list_elements( + x = label, + predicate = function(x) is_string(x), + error_msg = "Error in argument {arg_name} for column {variable}: value must be a string.", + env = env + ) + + cards::check_list_elements( + x = statistic, + predicate = function(x) is.character(x), + error_msg = "Error in argument {arg_name} for column {variable}: value must be a character vector.", + env = env + ) + + cards::check_list_elements( + x = type, + predicate = function(x) is_string(x) && x %in% type_accepted, + error_msg = "Error in argument {arg_name} for column {variable}: value must be one of {.val {type_accepted}}.", + env = env + ) + + cards::check_list_elements( + x = value, + predicate = function(x) is.null(x) || length(x) == 1L, + error_msg = "Error in argument {arg_name} for column {variable}: value must be either {.val {NULL}} or a scalar.", + env = env + ) + + cards::check_list_elements( + x = sort, + predicate = function(x) is.null(x) || (is_string(x) && x %in% sort_accepted), + error_msg = "Error in argument {arg_name} for column {variable}: value must be one of {.val {sort_accepted}}.", + env = env + ) +} diff --git a/man/assign_summary_type.Rd b/man/assign_summary_type.Rd index 173e231e1e..c6ac573969 100644 --- a/man/assign_summary_type.Rd +++ b/man/assign_summary_type.Rd @@ -4,17 +4,25 @@ \alias{assign_summary_type} \title{Assign Default Summary Type} \usage{ -assign_summary_type(data, variables, value, type = NULL) +assign_summary_type(data, variables, value, type = NULL, cat_threshold = 10L) } \arguments{ -\item{data}{a data frame} +\item{data}{(\code{data.frame})\cr +a data frame} -\item{variables}{character vector of column names in \code{data}} +\item{variables}{(\code{character})\cr +character vector of column names in \code{data}} -\item{value}{named list of values to show for dichotomous variables, where +\item{value}{(\verb{named list})\cr +named list of values to show for dichotomous variables, where the names are the variables} -\item{type}{named list of summary types, where names are the variables} +\item{type}{(\verb{named list})\cr +named list of summary types, where names are the variables} + +\item{cat_threshold}{(\code{integer})\cr +for base R numeric classes with fewer levels than +this threshold will default to a categorical summary. Default is \code{10L}} } \value{ named list diff --git a/man/check_class.Rd b/man/check_class.Rd index 183396431e..497e8b84db 100644 --- a/man/check_class.Rd +++ b/man/check_class.Rd @@ -8,6 +8,7 @@ check_class( x, class, + length = NULL, allow_empty = FALSE, arg_name = rlang::caller_arg(x), call = rlang::caller_env() @@ -16,7 +17,7 @@ check_class( check_class_data_frame( x, arg_name = rlang::caller_arg(x), - call = rlang::caller_env() + call = parent.frame() ) } \arguments{ @@ -25,6 +26,8 @@ check_class_data_frame( \item{class}{character vector or string indicating accepted classes. Passed to \code{inherits(what=class)}} +\item{length}{if not \code{NULL}, the \code{x} object must be length specified} + \item{allow_empty}{logical indicating whether empty arguments are allowed. Empty is defined by \code{rlang::is_empty()}, where empty elements include \code{NULL}, \code{list()}, \code{character()}, etc. Default is \code{FALSE}} diff --git a/man/check_length.Rd b/man/check_length.Rd new file mode 100644 index 0000000000..26c1a21ac5 --- /dev/null +++ b/man/check_length.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/standalone-checks.R +\name{check_length} +\alias{check_length} +\alias{check_scalar} +\title{Check Length} +\usage{ +check_length(x, length, arg_name = caller_arg(x), call = parent.frame()) + +check_scalar(x, arg_name = caller_arg(x), call = parent.frame()) +} +\arguments{ +\item{x}{object whose class will be checked} + +\item{length}{(\code{integer(1)})\cr +integer specifying the required length} + +\item{arg_name}{string indicating the argument name. Default is \code{rlang::caller_arg(x)}} + +\item{call}{The execution environment of a currently running +function, e.g. \code{call = caller_env()}. The corresponding function +call is retrieved and mentioned in error messages as the source +of the error. + +You only need to supply \code{call} when throwing a condition from a +helper function which wouldn't be relevant to mention in the +message. + +Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to +respectively not display any call or hard-code a code to display. + +For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} + +\item{msg}{(\code{string})\cr +string passed to \code{cli::cli_abort(message=)}} +} +\description{ +Check Length +} +\keyword{internal} diff --git a/man/check_not_missing.Rd b/man/check_not_missing.Rd index a744a7d379..22a122109f 100644 --- a/man/check_not_missing.Rd +++ b/man/check_not_missing.Rd @@ -4,11 +4,7 @@ \alias{check_not_missing} \title{Check Argument not Missing} \usage{ -check_not_missing( - x, - arg_name = rlang::caller_arg(x), - call = rlang::caller_env() -) +check_not_missing(x, arg_name = rlang::caller_arg(x), call = parent.frame()) } \arguments{ \item{x}{argument to check} diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 4fc6721e67..33bf955889 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tbl_summary.R \name{tbl_summary} \alias{tbl_summary} -\title{Title} +\title{Summary statistics table} \usage{ tbl_summary( data, @@ -21,13 +21,22 @@ tbl_summary( ) } \arguments{ -\item{data}{TODO:} +\item{data}{(\code{data.frame})\cr A data frame} -\item{by}{TODO:} +\item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +A single column from \code{data}. Summary statistics will be stratified by this variable. +Default is \code{NULL}} -\item{label}{TODO:} +\item{label}{(\code{\link[=syntax]{formula-list-selector}})\cr +Used to override default labels in summary table, e.g. \code{list(age = "Age, years")}. +The default for each variable is the column label attribute, \code{attr(., 'label')}. +If no label has been set, the column name is used.} -\item{statistic}{TODO:} +\item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr +Used to specify the summary statistics for each variable. +The default is +\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. +See below for details.} \item{digits}{TODO:} @@ -49,28 +58,99 @@ tbl_summary( } \value{ a gtsummary table of class \code{"tbl_summary"} + +A table of class \code{c('tbl_summary', 'gtsummary')} } \description{ -Title +The \code{tbl_summary()} function calculates descriptive statistics for +continuous, categorical, and dichotomous variables. +Review the +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} +for detailed examples. +} +\section{statistic argument}{ + +The statistic argument specifies the statistics presented in the table. The +input dictates the summary statistics presented in the table. For example, +\code{statistic = list(age ~ "{mean} ({sd})")} would report the mean and +standard deviation for age; \code{statistic = list(all_continuous() ~ "{mean} ({sd})")} +would report the mean and standard deviation for all continuous variables. + +The values are interpreted using \code{\link[glue:glue]{glue::glue()}} syntax: +a name that appears between curly brackets will be interpreted as a function +name and the formatted result of that function will be placed in the table. + +For categorical variables, the following statistics are available to display. +\itemize{ +\item \code{{n}} frequency +\item \code{{N}} denominator, or cohort size +\item \code{{p}} formatted percentage +} + +For continuous variables, \strong{any univariate function may be used}. Below is a list +of the \emph{most commonly} used statistics. +\itemize{ +\item \code{{median}} median +\item \code{{mean}} mean +\item \code{{sd}} standard deviation +\item \code{{var}} variance +\item \code{{min}} minimum +\item \code{{max}} maximum +\item \code{{sum}} sum +\item \verb{\{p##\}} any integer percentile, where \verb{##} is an integer from 0 to 100 +} + +When the summary type is \code{"continuous2"}, pass a vector of statistics. +Each element of the vector will result in a separate row in the summary table. + +For both categorical and continuous variables, statistics on the number of +missing and non-missing observations and their proportions are available to +display. +\itemize{ +\item \code{{N_obs}} total number of observations +\item \code{{N_miss}} number of missing observations +\item \code{{N_nonmiss}} number of non-missing observations +\item \code{{p_miss}} percentage of observations missing +\item \code{{p_nonmiss}} percentage of observations not missing } +} + \examples{ -tbl <- +# Example 1 ---------------------------------- +tbl_summary_ex1 <- + trial |> + select(age, grade, response) |> + tbl_summary() + +# Example 2 ---------------------------------- +tbl_summary_ex2 <- + trial |> + select(age, grade, response, trt) |> + tbl_summary( + by = trt, + label = list(age = "Patient Age"), + statistic = list(all_continuous() ~ "{mean} ({sd})"), + digits = list(age ~ c(0, 1)) + ) + +# Example 3 ---------------------------------- +tbl_summary_ex3 <- + trial |> + select(age, marker) |> tbl_summary( - data = mtcars, - include = c("cyl", "am", "mpg", "hp"), - type = - list( - cyl = "categorical", - am = "dichotomous", - mpg = "continuous", - hp = "continuous2" - ), - value = list(am = 1), - statistic = - list( - c(cyl, am) ~ "{n} ({p}\%)", - mpg = "{mean} ({sd})", - hp = c("{mean}", "{median}") - ) + type = all_continuous() ~ "continuous2", + statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), + missing = "no" ) } +\seealso{ +See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial + +See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples + +Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary +} +\author{ +Daniel D. Sjoberg +} +\concept{tbl_summary tools} From e2bd055964b7e8068cc2c7c14c3052e0a1874342 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 3 Feb 2024 21:11:04 -0800 Subject: [PATCH 18/74] doc updates --- NAMESPACE | 1 + R/assign_summary_digits.R | 29 ++++++++-- R/tbl_summary.R | 94 ++++++++++++++++++++++---------- man/assign_summary_digits.Rd | 36 +++++++++++++ man/bridge_summary.Rd | 12 +++-- man/tbl_summary.Rd | 102 ++++++++++++++++++++++++----------- 6 files changed, 208 insertions(+), 66 deletions(-) create mode 100644 man/assign_summary_digits.Rd diff --git a/NAMESPACE b/NAMESPACE index 2f037b3f32..09c549faa3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ export(all_stat_cols) export(any_of) export(as_gt) export(as_tibble) +export(assign_summary_digits) export(assign_summary_type) export(brdg_summary) export(contains) diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index 1731bdd78a..486753bc54 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -1,9 +1,32 @@ - - +#' Assign Default Digits +#' +#' Used to assign the default formatting for variables summarized with +#' `tbl_summary()`. +#' +#' @param data (`data.frame`)\cr +#' a data frame +#' @param statistic (`named list`)\cr +#' a named list; notably, _not_ a [`formula-list-selector`][syntax] +#' @param type (`named list`)\cr +#' a named list; notably, _not_ a [`formula-list-selector`][syntax] +#' @param digits (`named list`)\cr +#' a named list; notably, _not_ a [`formula-list-selector`][syntax]. +#' Default is `NULL` +#' +#' @return a named list +#' @export +#' +#' @examples +#' assign_summary_digits( +#' mtcars, +#' statistic = list(mpg = "{mean}"), +#' type = list(mpg = "continuous") +#' ) assign_summary_digits <- function(data, statistic, type, digits = NULL) { # stats returned for all variables lst_cat_summary_fns <- .categorical_summary_functions(c("n", "p")) - lst_all_fmt_fns <- .categorical_summary_functions() + lst_all_fmt_fns <- + .categorical_summary_functions(c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss")) # extract the statistics statistic <- lapply(statistic, function(x) .extract_glue_elements(x) |> unlist()) diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 4a1a008924..50021db9a4 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -19,15 +19,36 @@ #' The default is #' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. #' See below for details. -#' @param digits TODO: -#' @param type TODO: -#' @param value TODO: -#' @param missing TODO: -#' @param missing_text TODO: -#' @param missing_stat TODO: -#' @param sort TODO: -#' @param percent TODO: -#' @param include TODO: +#' @param digits ([`formula-list-selector`][syntax])\cr +#' Specifies how summary statistics are rounded. Values may be either integer(s) +#' or function(s). If not specified, default formatting is assigned +#' via `assign_summary_digits()`. See below for details. +#' @param type ([`formula-list-selector`][syntax])\cr +#' Specifies the summary type. Accepted value are +#' `c("continuous", "continuous2", "categorical", "dichotomous")`. +#' If not specified, default type is assigned via +#' `assign_summary_type()`. See below for details. +#' @param value ([`formula-list-selector`][syntax])\cr +#' Specifies the level of a variable to display on a single row. +#' The gtsummary type selectors, e.g. `all_dichotomous()`, cannot be used +#' with this argument. Default is `NULL`. See below for details. +#' @param statistic ([`formula-list-selector`][syntax])\cr +#' Specifies summary statistics to display for each variable. The default is +#' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. +#' See below for details. +#' @param missing,missing_text,missing_stat +#' Arguments dictating how and if missing values are presented: +#' - `missing`: must be one of `c("ifany", "no", "always")` +#' - `missing_text`: string indicating text shown on missing row. Default is `"Unknown"` +#' - `missing_stat`: statistic to show on missing row. Default is `"{N_miss}"`. +#' Possible values are `N_miss`, `N_obs`, `N_nonmiss`, `p_miss`, `p_nonmiss` +#' @param sort ([`formula-list-selector`][syntax])\cr +#' Specifies sorting to perform for categorical variables. +#' Values must be one of `c("alphanumeric", "frequency")`. +#' Default is `all_categorical(FALSE) ~ "alphanumeric"` +#' @param percent Indicates the type of percentage to return. +#' Must be one of `c("column", "row", "cell")`. Default is `"column"`. +#' @param include variables to include in the summary table. Default is `everything()` #' #' @return a gtsummary table of class `"tbl_summary"` #' @export @@ -43,25 +64,14 @@ #' a name that appears between curly brackets will be interpreted as a function #' name and the formatted result of that function will be placed in the table. #' -#' For categorical variables, the following statistics are available to display. -#' \itemize{ -#' \item `{n}` frequency -#' \item `{N}` denominator, or cohort size -#' \item `{p}` formatted percentage -#' } +#' For categorical variables, the following statistics are available to display: +#' `{n}` (frequency), `{N}` (denominator), `{p}` (percent). #' -#' For continuous variables, **any univariate function may be used**. Below is a list -#' of the _most commonly_ used statistics. -#' \itemize{ -#' \item `{median}` median -#' \item `{mean}` mean -#' \item `{sd}` standard deviation -#' \item `{var}` variance -#' \item `{min}` minimum -#' \item `{max}` maximum -#' \item `{sum}` sum -#' \item `{p##}` any integer percentile, where `##` is an integer from 0 to 100 -#' } +#' For continuous variables, **any univariate function may be used**. +#' The most commonly used functions are `{median}`, `{mean}`, `{sd}`, `{min}`, +#' and `{max}`. +#' Additionally, `{p##}` is available for percentiles, where `##` is an integer from 0 to 100. +#' For example, `p25: quantile(probs=0.25, type=2)`. #' #' When the summary type is `"continuous2"`, pass a vector of statistics. #' Each element of the vector will result in a separate row in the summary table. @@ -77,6 +87,36 @@ #' \item `{p_nonmiss}` percentage of observations not missing #' } #' +#' @section digits argument: +#' The digits argument specifies the the number of digits (or formatting function) +#' statistics are rounded to. +#' +#' The values passed can either be a single integer, a vector of integers, a +#' function, or a list of functions. If a single integer or function is passed, +#' it is recycled to the length of the number of statistics presented. +#' For example, if the statistic is `"{mean} ({sd})"`, it is equivalent to +#' pass `1`, `c(1, 1)`, `styfn_number(digits=1)`, and +#' `list(styfn_number(digits=1), styfn_number(digits=1))`. +#' +#' Named lists are also accepted to change the default formatting for a single +#' statistic, e.g. `list(sd = styfn_number(digits=1))`. +#' +#' @section type and value arguments: +#' There are four summary types: +#' - `"continuous"` summaries are shown on a *single row*. Most numeric +#' variables default to summary type continuous. +#' - `"continuous2"` summaries are shown on *2 or more rows* +#' - `"categorical"` *multi-line* summaries of nominal data. Character variables, +#' factor variables, and numeric variables with fewer than 10 unique levels default to +#' type categorical. To change a numeric variable to continuous that +#' defaulted to categorical, use `type = list(varname ~ "continuous")` +#' - `"dichotomous"` categorical variables that are displayed on a *single row*, +#' rather than one row per level of the variable. +#' Variables coded as `TRUE`/`FALSE`, `0`/`1`, or `yes`/`no` are assumed to be dichotomous, +#' and the `TRUE`, `1`, and `yes` rows are displayed. +#' Otherwise, the value to display must be specified in the `value` +#' argument, e.g. `value = list(varname ~ "level to show")` +#' #' @export #' @return A table of class `c('tbl_summary', 'gtsummary')` #' diff --git a/man/assign_summary_digits.Rd b/man/assign_summary_digits.Rd new file mode 100644 index 0000000000..0e27003c33 --- /dev/null +++ b/man/assign_summary_digits.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/assign_summary_digits.R +\name{assign_summary_digits} +\alias{assign_summary_digits} +\title{Assign Default Digits} +\usage{ +assign_summary_digits(data, statistic, type, digits = NULL) +} +\arguments{ +\item{data}{(\code{data.frame})\cr +a data frame} + +\item{statistic}{(\verb{named list})\cr +a named list; notably, \emph{not} a \code{\link[=syntax]{formula-list-selector}}} + +\item{type}{(\verb{named list})\cr +a named list; notably, \emph{not} a \code{\link[=syntax]{formula-list-selector}}} + +\item{digits}{(\verb{named list})\cr +a named list; notably, \emph{not} a \code{\link[=syntax]{formula-list-selector}}. +Default is \code{NULL}} +} +\value{ +a named list +} +\description{ +Used to assign the default formatting for variables summarized with +\code{tbl_summary()}. +} +\examples{ +assign_summary_digits( + mtcars, + statistic = list(mpg = "{mean}"), + type = list(mpg = "continuous") +) +} diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 314078c183..1fdca1effe 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -34,11 +34,13 @@ internally to organize results.} \item{value}{named list of values to be summarized. the names are the variable names.} -\item{missing}{TODO:} - -\item{missing_text}{TODO:} - -\item{missing_stat}{TODO:} +\item{missing, missing_text, missing_stat}{Arguments dictating how and if missing values are presented: +\itemize{ +\item \code{missing}: must be one of \code{c("ifany", "no", "always")} +\item \code{missing_text}: string indicating text shown on missing row. Default is \code{"Unknown"} +\item \code{missing_stat}: statistic to show on missing row. Default is \code{"{N_miss}"}. +Possible values are \code{N_miss}, \code{N_obs}, \code{N_nonmiss}, \code{p_miss}, \code{p_nonmiss} +}} } \value{ data frame diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 33bf955889..a81f4e32cd 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -33,28 +33,43 @@ The default for each variable is the column label attribute, \code{attr(., 'labe If no label has been set, the column name is used.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr -Used to specify the summary statistics for each variable. -The default is +Specifies summary statistics to display for each variable. The default is \code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. See below for details.} -\item{digits}{TODO:} +\item{digits}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies how summary statistics are rounded. Values may be either integer(s) +or function(s). If not specified, default formatting is assigned +via \code{assign_summary_digits()}. See below for details.} -\item{type}{TODO:} +\item{type}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the summary type. Accepted value are +\code{c("continuous", "continuous2", "categorical", "dichotomous")}. +If not specified, default type is assigned via +\code{assign_summary_type()}. See below for details.} -\item{value}{TODO:} +\item{value}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the level of a variable to display on a single row. +The gtsummary type selectors, e.g. \code{all_dichotomous()}, cannot be used +with this argument. Default is \code{NULL}. See below for details.} -\item{missing}{TODO:} - -\item{missing_text}{TODO:} - -\item{missing_stat}{TODO:} +\item{missing, missing_text, missing_stat}{Arguments dictating how and if missing values are presented: +\itemize{ +\item \code{missing}: must be one of \code{c("ifany", "no", "always")} +\item \code{missing_text}: string indicating text shown on missing row. Default is \code{"Unknown"} +\item \code{missing_stat}: statistic to show on missing row. Default is \code{"{N_miss}"}. +Possible values are \code{N_miss}, \code{N_obs}, \code{N_nonmiss}, \code{p_miss}, \code{p_nonmiss} +}} -\item{sort}{TODO:} +\item{sort}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies sorting to perform for categorical variables. +Values must be one of \code{c("alphanumeric", "frequency")}. +Default is \code{all_categorical(FALSE) ~ "alphanumeric"}} -\item{percent}{TODO:} +\item{percent}{Indicates the type of percentage to return. +Must be one of \code{c("column", "row", "cell")}. Default is \code{"column"}.} -\item{include}{TODO:} +\item{include}{variables to include in the summary table. Default is \code{everything()}} } \value{ a gtsummary table of class \code{"tbl_summary"} @@ -80,25 +95,14 @@ The values are interpreted using \code{\link[glue:glue]{glue::glue()}} syntax: a name that appears between curly brackets will be interpreted as a function name and the formatted result of that function will be placed in the table. -For categorical variables, the following statistics are available to display. -\itemize{ -\item \code{{n}} frequency -\item \code{{N}} denominator, or cohort size -\item \code{{p}} formatted percentage -} +For categorical variables, the following statistics are available to display: +\code{{n}} (frequency), \code{{N}} (denominator), \code{{p}} (percent). -For continuous variables, \strong{any univariate function may be used}. Below is a list -of the \emph{most commonly} used statistics. -\itemize{ -\item \code{{median}} median -\item \code{{mean}} mean -\item \code{{sd}} standard deviation -\item \code{{var}} variance -\item \code{{min}} minimum -\item \code{{max}} maximum -\item \code{{sum}} sum -\item \verb{\{p##\}} any integer percentile, where \verb{##} is an integer from 0 to 100 -} +For continuous variables, \strong{any univariate function may be used}. +The most commonly used functions are \code{{median}}, \code{{mean}}, \code{{sd}}, \code{{min}}, +and \code{{max}}. +Additionally, \verb{\{p##\}} is available for percentiles, where \verb{##} is an integer from 0 to 100. +For example, \code{p25: quantile(probs=0.25, type=2)}. When the summary type is \code{"continuous2"}, pass a vector of statistics. Each element of the vector will result in a separate row in the summary table. @@ -115,6 +119,42 @@ display. } } +\section{digits argument}{ + +The digits argument specifies the the number of digits (or formatting function) +statistics are rounded to. + +The values passed can either be a single integer, a vector of integers, a +function, or a list of functions. If a single integer or function is passed, +it is recycled to the length of the number of statistics presented. +For example, if the statistic is \code{"{mean} ({sd})"}, it is equivalent to +pass \code{1}, \code{c(1, 1)}, \code{styfn_number(digits=1)}, and +\code{list(styfn_number(digits=1), styfn_number(digits=1))}. + +Named lists are also accepted to change the default formatting for a single +statistic, e.g. \code{list(sd = styfn_number(digits=1))}. +} + +\section{type and value arguments}{ + +There are four summary types: +\itemize{ +\item \code{"continuous"} summaries are shown on a \emph{single row}. Most numeric +variables default to summary type continuous. +\item \code{"continuous2"} summaries are shown on \emph{2 or more rows} +\item \code{"categorical"} \emph{multi-line} summaries of nominal data. Character variables, +factor variables, and numeric variables with fewer than 10 unique levels default to +type categorical. To change a numeric variable to continuous that +defaulted to categorical, use \code{type = list(varname ~ "continuous")} +\item \code{"dichotomous"} categorical variables that are displayed on a \emph{single row}, +rather than one row per level of the variable. +Variables coded as \code{TRUE}/\code{FALSE}, \code{0}/\code{1}, or \code{yes}/\code{no} are assumed to be dichotomous, +and the \code{TRUE}, \code{1}, and \code{yes} rows are displayed. +Otherwise, the value to display must be specified in the \code{value} +argument, e.g. \code{value = list(varname ~ "level to show")} +} +} + \examples{ # Example 1 ---------------------------------- tbl_summary_ex1 <- From 8697026ae0ab76793c5d142abf2f89287782c2f7 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 4 Feb 2024 14:45:08 -0800 Subject: [PATCH 19/74] adding default stat labels --- NAMESPACE | 1 + NEWS.md | 4 ++- R/default_stat_labels.R | 44 +++++++++++++++++++++++++ R/tbl_summary.R | 67 +++++++++++++++++++++++++++++++++----- man/default_stat_labels.Rd | 17 ++++++++++ man/tbl_summary.Rd | 3 +- 6 files changed, 125 insertions(+), 11 deletions(-) create mode 100644 R/default_stat_labels.R create mode 100644 man/default_stat_labels.Rd diff --git a/NAMESPACE b/NAMESPACE index 09c549faa3..1682182aaf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ export(assign_summary_digits) export(assign_summary_type) export(brdg_summary) export(contains) +export(default_stat_labels) export(ends_with) export(everything) export(last_col) diff --git a/NEWS.md b/NEWS.md index 6bcca00f64..c30f704b15 100644 --- a/NEWS.md +++ b/NEWS.md @@ -16,6 +16,8 @@ * The inputs for `modify_table_styling(undo_text_format)` has been updated to mirror its counterpart `modify_table_styling(text_format)` and no longer accepts `TRUE` or `FALSE`. +* In `tbl_summary()`, the default calculation for quantiles (e.g. statistics of the form `"p25"` or `"p75"`) has been updated with type `quantile(type=2)`. + #### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. @@ -28,7 +30,7 @@ * Global options have been deprecated in gtsummary since v1.3.1 (2020-06-02). They have now been fully removed from the package. -* The `modify_header(stat_by)` argument was deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the packaage. +* The `modify_header(stat_by)` argument was deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the package. # gtsummary 1.7.2 diff --git a/R/default_stat_labels.R b/R/default_stat_labels.R new file mode 100644 index 0000000000..f72e75a432 --- /dev/null +++ b/R/default_stat_labels.R @@ -0,0 +1,44 @@ +#' Default Statistics Labels +#' +#' @return named list +#' @export +#' +#' @examples +#' default_stat_labels() +default_stat_labels <- function() { + list( + # standard summary stat labels + mean = "Mean", + sd = "SD", + var = "Variance", + median = "Median", + min = "Min", + max = "Max", + var = "Variance", + sum = "Sum", + n = "n", + N = "N", + p = "%", + N_obs = "No. obs.", + N_miss = "N Missing", + N_nonmiss = "N Non-missing", + p_miss = "% Missing", + p_nonmiss = "% Non-missing", + + # survey statistics + N_unweighted = "N (unweighted)", + n_unweighted = "n (unweighted)", + N_obs_unweighted = "Total N (unweighted)", + N_miss_unweighted = "N Missing (unweighted)", + N_nonmiss_unweighted = "N not Missing (unweighted)", + p_unweighted = "% (unweighted)", + p_miss_unweighted = "% Missing (unweighted)", + p_nonmiss_unweighted = "% not Missing (unweighted)", + mean.std.error = "SE", + p.std.error = "SE(%)", + deff = "Design effect" + ) |> + # adding the percentile labels + c(paste0(0:100, "% Centile") |> as.list() |> set_names(paste0("p", 0:100))) |> + utils::modifyList(val = list(p25 = "Q1", p50 = "Q2", p75 = "Q3")) +} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 50021db9a4..6bc45e0c67 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -155,7 +155,7 @@ tbl_summary <- function(data, by = NULL, label = NULL, - statistic = list(all_continuous() ~ "{mean} ({sd})", + statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)"), digits = assign_summary_digits(data, statistic, type), type = assign_summary_type(data, include, value), @@ -262,23 +262,29 @@ tbl_summary <- function(data, cards <- cards::bind_ard( cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), - cards::ard_missing(data, variables = all_of(include), by = all_of(by)), + cards::ard_missing(data, variables = all_of(include), by = all_of(by), + stat_labels = ~default_stat_labels()), # tabulate by variable for header stats - if (!rlang::is_empty(by)) cards::ard_categorical(data, variables = all_of(by)), + if (!rlang::is_empty(by)) cards::ard_categorical(data, variables = all_of(by), + stat_labels = ~default_stat_labels()), # tabulate categorical summaries cards::ard_categorical( data, by = all_of(by), variables = all_categorical(), fmt_fn = digits, - denominator = percent + denominator = percent, + stat_labels = ~default_stat_labels() ), # calculate categorical summaries cards::ard_continuous( data, by = all_of(by), variables = all_continuous(), - fmt_fn = digits + statistics = + .continuous_statistics_chr_to_fun(statistic[select(data, all_continuous()) |> names()]), + fmt_fn = digits, + stat_labels = ~default_stat_labels() ) ) @@ -339,16 +345,17 @@ tbl_summary <- function(data, dplyr::filter(.data$variable %in% .env$variable) |> dplyr::select("stat_name", "stat_label") |> dplyr::distinct() %>% - {as.list(.$stat_label) |> stats::setNames(.$stat_name)}|> - glue::glue_data(statistic[[variable]]) %>% - {gsub(pattern = "(%%)+", replacement = "%", x = .)} + {stats::setNames(as.list(.$stat_label), .$stat_name)} |> + glue::glue_data( + gsub("\\{(p|p_miss|p_nonmiss)\\}%", "{\\1}", x = statistic[[variable]]) + ) } ) |> stats::setNames(include) |> compact() |> unlist() |> unique() %>% - {switch(!is.null(.), paste(collapse = ", "))} + {switch(!is.null(.), paste(., collapse = ", "))} } @@ -415,6 +422,48 @@ tbl_summary <- function(data, invisible() } +.continuous_statistics_chr_to_fun <- function(statistics) { + # vector of all the categorical summary function names + # these are defined internally, and we don't need to convert them to true fns + chr_protected_cat_names <- .categorical_summary_functions() |> names() |> c("N") + + # this chunk converts the character strings that define the statistics + # into named lists of functions, + # e.g. list(age = "{mean}") becomes list(age = list(mean = function(x) mean(x))) + lst_stat_fns_chr <- + lapply( + statistics, + function(x) { + chr_fun_names <- + .extract_glue_elements(x) |> unlist() |> setdiff(chr_protected_cat_names) + lgl_fun_is_quantile <- grepl(x = chr_fun_names, pattern = "^p\\d{1,3}$") + + map2( + chr_fun_names, lgl_fun_is_quantile, + function(chr_fun_name, is_quantile) { + # if it's a quantile function, return the quantile function + if (is_quantile) { + return(.str_to_quantile_fun(chr_fun_name)) + } + # otherwise, convert the string to an expr and evaluate + # TODO: for values that were converted from formulas, + # this needs to be updated to evaluate from the formula env + # this will first require an updated to the {cards} function that processes the inputs. + # i am not sure if we need to track any other env, or just the formulas... + eval(rlang::parse_expr(chr_fun_name)) + } + ) |> + set_names(chr_fun_names) + } + ) + + lst_stat_fns_chr +} + +.str_to_quantile_fun <- function(str) { + function(x) stats::quantile(x, probs = as.numeric(substr(str, 2, nchar(str))) / 100, type = 2) |> unname() +} + .check_tbl_summary_args <- function(data, label, statistic, digits, type, value, sort, env = parent.frame()) { # first check the structure of each of the inputs ---------------------------- diff --git a/man/default_stat_labels.Rd b/man/default_stat_labels.Rd new file mode 100644 index 0000000000..32fb65b045 --- /dev/null +++ b/man/default_stat_labels.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/default_stat_labels.R +\name{default_stat_labels} +\alias{default_stat_labels} +\title{Default Statistics Labels} +\usage{ +default_stat_labels() +} +\value{ +named list +} +\description{ +Default Statistics Labels +} +\examples{ +default_stat_labels() +} diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index a81f4e32cd..49fdc08674 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -8,7 +8,8 @@ tbl_summary( data, by = NULL, label = NULL, - statistic = list(all_continuous() ~ "{mean} ({sd})", all_categorical() ~ "{n} ({p}\%)"), + statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ + "{n} ({p}\%)"), digits = assign_summary_digits(data, statistic, type), type = assign_summary_type(data, include, value), value = NULL, From 02af7ccbff26b18ef6078bfc956aa35f73b60285 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 5 Feb 2024 15:58:49 -0800 Subject: [PATCH 20/74] progress --- DESCRIPTION | 2 +- R/assign_summary_type.R | 5 + R/bridge_summary.R | 22 ++-- R/tbl_summary.R | 63 ++++++---- man/tbl_summary.Rd | 4 +- tests/testthat/_snaps/tbl_summary.md | 178 +++++++++++++++++++++++++++ tests/testthat/test-tbl_summary.R | 52 +++++++- 7 files changed, 283 insertions(+), 43 deletions(-) create mode 100644 tests/testthat/_snaps/tbl_summary.md diff --git a/DESCRIPTION b/DESCRIPTION index 7250e2f4fe..67d4cf9209 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9024), + cards (>= 0.0.0.9026), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index b4bfbcc042..fa0d18025c 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -40,6 +40,11 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho } # if user supplied a dichotomous value, make it dichotomous + if (!is.null(value[[variable]])) { + return("dichotomous") + } + + # if a type with a default dichotomous value, make it dichotomous if (!is.null(.get_default_dichotomous_value(data[[variable]]))) { return("dichotomous") } diff --git a/R/bridge_summary.R b/R/bridge_summary.R index cc2cc1cd14..b2b345d0a6 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -74,7 +74,11 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { # adding the name of the column the stats will populate if (is_empty(x$inputs$by)) { x$cards$gts_column <- - ifelse(x$cards$context %in% c("continuous", "categorical", "missing"), "stat_0", NA_character_) + ifelse( + x$cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), + "stat_0", + NA_character_ + ) } else { x$cards <- @@ -83,7 +87,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { .by = cards::all_ard_groups(), gts_column = ifelse( - .data$context %in% c("continuous", "categorical", "missing") & + .data$context %in% c("continuous", "categorical", "dichotomous", "missing") & !.data$variable %in% .env$x$inputs$tbl_summary$by, paste0("stat_", dplyr::cur_group_id() - 1L), NA_character_ @@ -131,18 +135,12 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { #' @export pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { if (is_empty(variables)) return(dplyr::tibble()) - # subsetting cards object on dichotomous summaries --------------------------- + + # updating the context to continuous, because it will be processed that way below x$cards <- x$cards |> - dplyr::filter( - .by = c(cards::all_ard_groups(), "variable"), - .data$variable %in% .env$variables, - .data$variable_level %in% list(NULL) | - .data$variable_level %in% list(value[[.data$variable[1]]]) - ) |> - # updating the context to continuous, because it will be processed that way below dplyr::mutate( - context = ifelse(.data$context %in% "categorical", "continuous", .data$context) + context = ifelse(.data$context %in% "dichotomous", "continuous", .data$context) ) pier_summary_continuous(x = x, variables = variables) @@ -471,7 +469,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { df_by_stats |> dplyr::filter(.data$stat_name %in% c("n", "p")) |> dplyr::mutate( - .by = .data$variable_level, + .by = "variable_level", column = paste0("stat_", dplyr::cur_group_id()) ) %>% {dplyr::bind_rows( diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 6bc45e0c67..03667896ce 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -157,8 +157,8 @@ tbl_summary <- function(data, label = NULL, statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)"), - digits = assign_summary_digits(data, statistic, type), - type = assign_summary_type(data, include, value), + digits = NULL, + type = NULL, value = NULL, missing = c("ifany", "no", "always"), missing_text = "Unknown", @@ -180,16 +180,19 @@ tbl_summary <- function(data, cards::process_formula_selectors(data = data[include], value = value) # assign summary type -------------------------------------------------------- - if (!missing(type)) { + if (!is_empty(type)) { # first set default types, so selectors like `all_continuous()` can be used # to recast the summary type, e.g. make all continuous type "continuous2" - default_types <- formals(gtsummary::tbl_summary)[["type"]] |> eval() + default_types <- assign_summary_type(data, include, value) data <- .add_summary_type_as_attr(data, default_types) # process the user-passed type argument cards::process_formula_selectors(data = data[include], type = type) # fill in any types not specified by user type <- utils::modifyList(default_types, type) } + else { + type <- assign_summary_type(data, include, value) + } data <- .add_summary_type_as_attr(data, type) value <- .assign_default_values(data[include], value, type) @@ -217,8 +220,8 @@ tbl_summary <- function(data, data = data[include], digits = .ifelse1( - missing(digits), - get_theme_element("TODO:fill-this-in", default = digits), + is_empty(digits), + get_theme_element("TODO:fill-this-in", default = assign_summary_digits(data, statistic, type)), digits ) ) @@ -250,8 +253,7 @@ tbl_summary <- function(data, ) # sort requested columns by frequency - # TODO: Does this break the type attribute? If so, need to re-apply - data <- .sort_data_infreq(data, sort) + data <- .sort_data_infreq(data, sort, type) # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) @@ -271,9 +273,19 @@ tbl_summary <- function(data, cards::ard_categorical( data, by = all_of(by), - variables = all_categorical(), + variables = all_categorical(FALSE), + fmt_fn = digits, + denominator = percent, + stat_labels = ~default_stat_labels() + ), + # tabulate dichotomous summaries + cards::ard_dichotomous( + data, + by = all_of(by), + variables = all_dichotomous(), fmt_fn = digits, denominator = percent, + values = value, stat_labels = ~default_stat_labels() ), # calculate categorical summaries @@ -299,31 +311,30 @@ tbl_summary <- function(data, structure(class = c("tbl_summary", "gtsummary")) # adding styling ------------------------------------------------------------- - x <- + x <- x |> + # add header to label column and add default indentation modify_table_styling( - x, columns = "label", label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), indentation = 4L ) |> + # adding the statistic footnote modify_table_styling( columns = all_stat_cols(), footnote = .construct_summary_footnote(x$cards, x$inputs$include, x$inputs$statistic, x$inputs$type) - ) - - x <- + ) |> + # updating the headers for the stats columns modify_header( - x, all_stat_cols() ~ ifelse(is_empty(by), "**N = {N}**", "**{level}** \nN = {n}") ) - # return object + # return tbl_summary table --------------------------------------------------- x } -.sort_data_infreq <- function(data, sort) { +.sort_data_infreq <- function(data, sort, type) { # if no frequency sorts requested, just return data frame if (every(sort, function(x) x %in% "alphanumeric")) return(data) @@ -333,7 +344,7 @@ tbl_summary <- function(data, } } - data + .add_summary_type_as_attr(data, type) } .construct_summary_footnote <- function(card, include, statistic, type) { @@ -468,40 +479,40 @@ tbl_summary <- function(data, .check_tbl_summary_args <- function(data, label, statistic, digits, type, value, sort, env = parent.frame()) { # first check the structure of each of the inputs ---------------------------- type_accepted <- c("continuous", "continuous2", "categorical", "dichotomous") - sort_accepted <- c("alphanumeric", "frequency") cards::check_list_elements( x = label, predicate = function(x) is_string(x), - error_msg = "Error in argument {arg_name} for column {variable}: value must be a string.", + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a string.", env = env ) cards::check_list_elements( x = statistic, predicate = function(x) is.character(x), - error_msg = "Error in argument {arg_name} for column {variable}: value must be a character vector.", + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a character vector.", env = env ) cards::check_list_elements( x = type, - predicate = function(x) is_string(x) && x %in% type_accepted, - error_msg = "Error in argument {arg_name} for column {variable}: value must be one of {.val {type_accepted}}.", + predicate = function(x) is_string(x) && x %in% c("continuous", "continuous2", "categorical", "dichotomous"), + error_msg = + "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('continuous', 'continuous2', 'categorical', 'dichotomous')}}.", env = env ) cards::check_list_elements( x = value, predicate = function(x) is.null(x) || length(x) == 1L, - error_msg = "Error in argument {arg_name} for column {variable}: value must be either {.val {NULL}} or a scalar.", + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be either {.val {NULL}} or a scalar.", env = env ) cards::check_list_elements( x = sort, - predicate = function(x) is.null(x) || (is_string(x) && x %in% sort_accepted), - error_msg = "Error in argument {arg_name} for column {variable}: value must be one of {.val {sort_accepted}}.", + predicate = function(x) is.null(x) || (is_string(x) && x %in% c("alphanumeric", "frequency")), + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('alphanumeric', 'frequency')}}.", env = env ) } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 49fdc08674..b236427407 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -10,8 +10,8 @@ tbl_summary( label = NULL, statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)"), - digits = assign_summary_digits(data, statistic, type), - type = assign_summary_type(data, include, value), + digits = NULL, + type = NULL, value = NULL, missing = c("ifany", "no", "always"), missing_text = "Unknown", diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md new file mode 100644 index 0000000000..0227df0543 --- /dev/null +++ b/tests/testthat/_snaps/tbl_summary.md @@ -0,0 +1,178 @@ +# standard tbl_summary() creates correct + + Code + as.data.frame(tbl_summary(data = trial)) + Output + **Characteristic** **N = 200** + 1 Chemotherapy Treatment + 2 Drug A 98 (49%) + 3 Drug B 102 (51%) + 4 Age 47 (38, 57) + 5 Unknown 11 + 6 Marker Level (ng/mL) 0.64 (0.22, 1.41) + 7 Unknown 10 + 8 T Stage + 9 T1 53 (27%) + 10 T2 54 (27%) + 11 T3 43 (22%) + 12 T4 50 (25%) + 13 Grade + 14 I 68 (34%) + 15 II 68 (34%) + 16 III 64 (32%) + 17 Tumor Response 61 (32%) + 18 Unknown 7 + 19 Patient Died 112 (56%) + 20 Months to Death/Censor 22.4 (15.9, 24.0) + +--- + + Code + as.data.frame(tbl_summary(data = mtcars)) + Output + **Characteristic** **N = 32** + 1 mpg 19.2 (15.4, 22.8) + 2 cyl + 3 4 11 (34%) + 4 6 7 (22%) + 5 8 14 (44%) + 6 disp 196 (121, 334) + 7 hp 123 (96, 180) + 8 drat 3.70 (3.08, 3.92) + 9 wt 3.33 (2.54, 3.65) + 10 qsec 17.71 (16.89, 18.90) + 11 vs 14 (44%) + 12 am 13 (41%) + 13 gear + 14 3 15 (47%) + 15 4 12 (38%) + 16 5 5 (16%) + 17 carb + 18 1 7 (22%) + 19 2 10 (31%) + 20 3 3 (9.4%) + 21 4 10 (31%) + 22 6 1 (3.1%) + 23 8 1 (3.1%) + +--- + + Code + as.data.frame(tbl_summary(data = iris)) + Output + **Characteristic** **N = 150** + 1 Sepal.Length 5.80 (5.10, 6.40) + 2 Sepal.Width 3.00 (2.80, 3.30) + 3 Petal.Length 4.35 (1.60, 5.10) + 4 Petal.Width 1.30 (0.30, 1.80) + 5 Species + 6 setosa 50 (33%) + 7 versicolor 50 (33%) + 8 virginica 50 (33%) + +# tbl_summary(by) creates output without error/warning + + Code + as.data.frame(tbl_summary(data = trial, by = trt)) + Output + **Characteristic** **Drug A** \nN = 98 **Drug B** \nN = 102 + 1 Age 46 (37, 60) 48 (39, 56) + 2 Unknown 7 4 + 3 Marker Level (ng/mL) 0.84 (0.23, 1.60) 0.52 (0.18, 1.21) + 4 Unknown 6 4 + 5 T Stage + 6 T1 28 (29%) 25 (25%) + 7 T2 25 (26%) 29 (28%) + 8 T3 22 (22%) 21 (21%) + 9 T4 23 (23%) 27 (26%) + 10 Grade + 11 I 35 (36%) 33 (32%) + 12 II 32 (33%) 36 (35%) + 13 III 31 (32%) 33 (32%) + 14 Tumor Response 28 (29%) 33 (34%) + 15 Unknown 3 4 + 16 Patient Died 52 (53%) 60 (59%) + 17 Months to Death/Censor 23.5 (17.4, 24.0) 21.2 (14.5, 24.0) + +--- + + Code + as.data.frame(tbl_summary(data = mtcars, by = am)) + Output + **Characteristic** **0** \nN = 19 **1** \nN = 13 + 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) + 2 cyl + 3 4 3 (16%) 8 (62%) + 4 6 4 (21%) 3 (23%) + 5 8 12 (63%) 2 (15%) + 6 disp 276 (168, 360) 120 (79, 160) + 7 hp 175 (110, 205) 109 (66, 113) + 8 drat 3.15 (3.07, 3.70) 4.08 (3.85, 4.22) + 9 wt 3.52 (3.44, 3.85) 2.32 (1.94, 2.78) + 10 qsec 17.82 (17.05, 19.44) 17.02 (16.46, 18.61) + 11 vs 7 (37%) 7 (54%) + 12 gear + 13 3 15 (79%) 0 (0%) + 14 4 4 (21%) 8 (62%) + 15 5 0 (0%) 5 (38%) + 16 carb + 17 1 3 (16%) 4 (31%) + 18 2 6 (32%) 4 (31%) + 19 3 3 (16%) 0 (0%) + 20 4 7 (37%) 3 (23%) + 21 6 0 (0%) 1 (7.7%) + 22 8 0 (0%) 1 (7.7%) + +--- + + Code + as.data.frame(tbl_summary(data = iris, by = Species)) + Output + **Characteristic** **setosa** \nN = 50 **versicolor** \nN = 50 + 1 Sepal.Length 5.00 (4.80, 5.20) 5.90 (5.60, 6.30) + 2 Sepal.Width 3.40 (3.20, 3.70) 2.80 (2.50, 3.00) + 3 Petal.Length 1.50 (1.40, 1.60) 4.35 (4.00, 4.60) + 4 Petal.Width 0.20 (0.20, 0.30) 1.30 (1.20, 1.50) + **virginica** \nN = 50 + 1 6.50 (6.20, 6.90) + 2 3.00 (2.80, 3.20) + 3 5.55 (5.10, 5.90) + 4 2.00 (1.80, 2.30) + +# tbl_summary(label) allows for named list input + + Code + as.data.frame(tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl"), + include = c(mpg, cyl))) + Output + **Characteristic** **0** \nN = 19 **1** \nN = 13 + 1 New mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) + 2 New cyl + 3 4 3 (16%) 8 (62%) + 4 6 4 (21%) 3 (23%) + 5 8 12 (63%) 2 (15%) + +# tbl_summary(sort) works + + Code + tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + Condition + Error in `tbl_summary()`: + ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + +--- + + Code + tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + Condition + Error in `tbl_summary()`: + ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + +# tbl_summary(value) works + + Code + as.data.frame(tbl_summary(trial, value = "grade" ~ "III", include = grade)) + Output + **Characteristic** **N = 200** + 1 Grade 64 (32%) + diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index 8849056e25..c9ecf91724 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -1,3 +1,51 @@ -test_that("multiplication works", { - expect_equal(2 * 2, 4) +test_that("standard tbl_summary() creates correct", { + expect_snapshot(tbl_summary(data = trial) |> as.data.frame()) + expect_snapshot(tbl_summary(data = mtcars) |> as.data.frame()) + expect_snapshot(tbl_summary(data = iris) |> as.data.frame()) +}) + + +test_that("tbl_summary(by) creates output without error/warning", { + expect_snapshot(tbl_summary(data = trial, by = trt) |> as.data.frame()) + expect_snapshot(tbl_summary(data = mtcars, by = am) |> as.data.frame()) + expect_snapshot(tbl_summary(data = iris, by = Species) |> as.data.frame()) +}) + +test_that("tbl_summary(label) allows for named list input", { + expect_snapshot( + tbl_summary( + mtcars, + by = am, + label = list(mpg = "New mpg", cyl = "New cyl"), + include = c(mpg, cyl) + ) |> + as.data.frame() + ) +}) + +test_that("tbl_summary(sort) works", { + expect_equal( + tbl_summary(mtcars, sort = all_categorical() ~ "frequency", include = cyl) |> + getElement("table_body") |> + dplyr::filter(row_type %in% "level") |> + dplyr::pull(label), + c("8", "4", "6") + ) + + # proper errors are returned + expect_snapshot( + error = TRUE, + tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + ) + expect_snapshot( + error = TRUE, + tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + ) +}) + +test_that("tbl_summary(value) works", { + expect_snapshot( + tbl_summary(trial, value = "grade" ~ "III", include = grade) |> + as.data.frame() + ) }) From ffb0b7c3c9a546b915d36e5fe43045630b7fe205 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 5 Feb 2024 16:00:27 -0800 Subject: [PATCH 21/74] Update tbl_summary.R --- R/tbl_summary.R | 75 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 51 insertions(+), 24 deletions(-) diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 03667896ce..0d1494abb5 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -155,8 +155,10 @@ tbl_summary <- function(data, by = NULL, label = NULL, - statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", - all_categorical() ~ "{n} ({p}%)"), + statistic = list( + all_continuous() ~ "{median} ({p25}, {p75})", + all_categorical() ~ "{n} ({p}%)" + ), digits = NULL, type = NULL, value = NULL, @@ -189,8 +191,7 @@ tbl_summary <- function(data, cards::process_formula_selectors(data = data[include], type = type) # fill in any types not specified by user type <- utils::modifyList(default_types, type) - } - else { + } else { type <- assign_summary_type(data, include, value) } data <- .add_summary_type_as_attr(data, type) @@ -264,11 +265,17 @@ tbl_summary <- function(data, cards <- cards::bind_ard( cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), - cards::ard_missing(data, variables = all_of(include), by = all_of(by), - stat_labels = ~default_stat_labels()), + cards::ard_missing(data, + variables = all_of(include), by = all_of(by), + stat_labels = ~ default_stat_labels() + ), # tabulate by variable for header stats - if (!rlang::is_empty(by)) cards::ard_categorical(data, variables = all_of(by), - stat_labels = ~default_stat_labels()), + if (!rlang::is_empty(by)) { + cards::ard_categorical(data, + variables = all_of(by), + stat_labels = ~ default_stat_labels() + ) + }, # tabulate categorical summaries cards::ard_categorical( data, @@ -276,7 +283,7 @@ tbl_summary <- function(data, variables = all_categorical(FALSE), fmt_fn = digits, denominator = percent, - stat_labels = ~default_stat_labels() + stat_labels = ~ default_stat_labels() ), # tabulate dichotomous summaries cards::ard_dichotomous( @@ -286,7 +293,7 @@ tbl_summary <- function(data, fmt_fn = digits, denominator = percent, values = value, - stat_labels = ~default_stat_labels() + stat_labels = ~ default_stat_labels() ), # calculate categorical summaries cards::ard_continuous( @@ -296,7 +303,7 @@ tbl_summary <- function(data, statistics = .continuous_statistics_chr_to_fun(statistic[select(data, all_continuous()) |> names()]), fmt_fn = digits, - stat_labels = ~default_stat_labels() + stat_labels = ~ default_stat_labels() ) ) @@ -336,7 +343,9 @@ tbl_summary <- function(data, .sort_data_infreq <- function(data, sort, type) { # if no frequency sorts requested, just return data frame - if (every(sort, function(x) x %in% "alphanumeric")) return(data) + if (every(sort, function(x) x %in% "alphanumeric")) { + return(data) + } for (i in seq_along(sort[intersect(names(sort), names(data))])) { if (sort[[i]] %in% "frequency") { @@ -351,12 +360,16 @@ tbl_summary <- function(data, include |> lapply( function(variable) { - if (type[[variable]] %in% "continuous2") return(NULL) + if (type[[variable]] %in% "continuous2") { + return(NULL) + } card |> dplyr::filter(.data$variable %in% .env$variable) |> dplyr::select("stat_name", "stat_label") |> dplyr::distinct() %>% - {stats::setNames(as.list(.$stat_label), .$stat_name)} |> + { + stats::setNames(as.list(.$stat_label), .$stat_name) + } |> glue::glue_data( gsub("\\{(p|p_miss|p_nonmiss)\\}%", "{\\1}", x = statistic[[variable]]) ) @@ -366,7 +379,11 @@ tbl_summary <- function(data, compact() |> unlist() |> unique() %>% - {switch(!is.null(.), paste(., collapse = ", "))} + { + switch(!is.null(.), + paste(., collapse = ", ") + ) + } } @@ -380,13 +397,19 @@ tbl_summary <- function(data, names(data), function(variable) { # if user passed value, then use it - if (!is.null(value[[variable]])) return(value[[variable]]) + if (!is.null(value[[variable]])) { + return(value[[variable]]) + } # if not a dichotomous summary type, then return NULL - if (!type[[variable]] %in% "dichotomous") return(NULL) + if (!type[[variable]] %in% "dichotomous") { + return(NULL) + } # otherwise, return default value default_value <- .get_default_dichotomous_value(data[[variable]]) - if (!is.null(default_value)) return(default_value) + if (!is.null(default_value)) { + return(default_value) + } cli::cli_abort(c( "Error in argument {.arg value} for variable {.val {variable}}.", "i" = "Summary type is {.val dichotomous} but no summary value has been assigned." @@ -417,9 +440,9 @@ tbl_summary <- function(data, c("haven::as_factor", "labelled::to_factor", "labelled::unlabelled", "unclass") hyperlinks <- c( - "https://haven.tidyverse.org/articles/semantics.html", - "https://larmarange.github.io/labelled/articles/intro_labelled.html#unlabelled" - ) + "https://haven.tidyverse.org/articles/semantics.html", + "https://larmarange.github.io/labelled/articles/intro_labelled.html#unlabelled" + ) c( "!" = "Column(s) {.val {haven_labelled_vars}} are class {.val haven_labelled}.", @@ -436,7 +459,9 @@ tbl_summary <- function(data, .continuous_statistics_chr_to_fun <- function(statistics) { # vector of all the categorical summary function names # these are defined internally, and we don't need to convert them to true fns - chr_protected_cat_names <- .categorical_summary_functions() |> names() |> c("N") + chr_protected_cat_names <- .categorical_summary_functions() |> + names() |> + c("N") # this chunk converts the character strings that define the statistics # into named lists of functions, @@ -446,7 +471,9 @@ tbl_summary <- function(data, statistics, function(x) { chr_fun_names <- - .extract_glue_elements(x) |> unlist() |> setdiff(chr_protected_cat_names) + .extract_glue_elements(x) |> + unlist() |> + setdiff(chr_protected_cat_names) lgl_fun_is_quantile <- grepl(x = chr_fun_names, pattern = "^p\\d{1,3}$") map2( @@ -511,7 +538,7 @@ tbl_summary <- function(data, cards::check_list_elements( x = sort, - predicate = function(x) is.null(x) || (is_string(x) && x %in% c("alphanumeric", "frequency")), + predicate = function(x) is.null(x) || (is_string(x) && x %in% c("alphanumeric", "frequency")), error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('alphanumeric', 'frequency')}}.", env = env ) From 6d85d9b23e113e10f67774555d5d5c3423ffb25a Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 5 Feb 2024 16:00:45 -0800 Subject: [PATCH 22/74] Update bridge_summary.R --- R/bridge_summary.R | 173 +++++++++++++++++++++++++-------------------- 1 file changed, 96 insertions(+), 77 deletions(-) diff --git a/R/bridge_summary.R b/R/bridge_summary.R index b2b345d0a6..8b016011e3 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -41,24 +41,24 @@ #' ) #' #' pier_summary_dichotomous( -#' x = tbl, -#' variables = "am", -#' value = list(am = 1) +#' x = tbl, +#' variables = "am", +#' value = list(am = 1) #' ) #' #' pier_summary_categorical( -#' x = tbl, -#' variables = "cyl" +#' x = tbl, +#' variables = "cyl" #' ) #' #' pier_summary_continuous2( -#' x = tbl, -#' variables = "hp" +#' x = tbl, +#' variables = "hp" #' ) #' #' pier_summary_continuous( -#' x = tbl, -#' variables = "mpg" +#' x = tbl, +#' variables = "mpg" #' ) NULL @@ -79,8 +79,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { "stat_0", NA_character_ ) - } - else { + } else { x$cards <- x$cards |> dplyr::mutate( @@ -134,7 +133,9 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { #' @rdname bridge_summary #' @export pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # updating the context to continuous, because it will be processed that way below x$cards <- @@ -149,7 +150,9 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { #' @rdname bridge_summary #' @export pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # subsetting cards object on categorical summaries ---------------------------- card <- x$cards |> @@ -177,32 +180,31 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin .data = df_groups_and_variable, df_stats = dplyr::filter(df_variable_stats, !.data$variable_level %in% list(NULL)) |> - dplyr::group_by(.data$variable_level) |> - dplyr::group_map( - function(df_variable_level_stats, df_variable_levels) { - dplyr::mutate( - .data = df_variable_levels, - stat = - map( - str_statistic_pre_glue, - function(str_to_glue) { - stat = - glue::glue( - str_to_glue, - .envir = - cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt") |> - c(lst_variable_stats) - ) |> - as.character() - - } - ), - label = unlist(.data$variable_level) |> as.character() - ) - } - ) |> - dplyr::bind_rows() |> - list() + dplyr::group_by(.data$variable_level) |> + dplyr::group_map( + function(df_variable_level_stats, df_variable_levels) { + dplyr::mutate( + .data = df_variable_levels, + stat = + map( + str_statistic_pre_glue, + function(str_to_glue) { + stat <- + glue::glue( + str_to_glue, + .envir = + cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt") |> + c(lst_variable_stats) + ) |> + as.character() + } + ), + label = unlist(.data$variable_level) |> as.character() + ) + } + ) |> + dplyr::bind_rows() |> + list() ) } ) |> @@ -214,9 +216,11 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin # merge in variable label dplyr::left_join( x$cards |> - dplyr::filter(.data$variable %in% .env$variables, - .data$context %in% "attributes", - .data$stat_name %in% "label") |> + dplyr::filter( + .data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label" + ) |> dplyr::select("variable", var_label = "statistic"), by = "variable" ) |> @@ -239,7 +243,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin df_results <- map( variables, - ~dplyr::bind_rows( + ~ dplyr::bind_rows( df_result_levels |> dplyr::select("variable", "var_label", "row_type") |> dplyr::filter(.data$variable %in% .x) |> @@ -260,7 +264,9 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # subsetting cards object on continuous2 summaries ---------------------------- card <- x$cards |> @@ -280,7 +286,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin map( x$inputs$statistic[[.y$variable[1]]], function(str_to_glue) { - stat = + stat <- glue::glue( str_to_glue, .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") @@ -288,12 +294,12 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin as.character() } ) |> - list(), + list(), label = map( x$inputs$statistic[[.y$variable[1]]], function(str_to_glue) { - label = + label <- glue::glue( str_to_glue, .envir = cards::get_ard_statistics(.x, .column = "stat_label") @@ -301,7 +307,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin as.character() } ) |> - list() + list() ) } ) |> @@ -313,9 +319,11 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin # merge in variable label dplyr::left_join( x$cards |> - dplyr::filter(.data$variable %in% .env$variables, - .data$context %in% "attributes", - .data$stat_name %in% "label") |> + dplyr::filter( + .data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label" + ) |> dplyr::select("variable", var_label = "statistic"), by = "variable" ) |> @@ -338,7 +346,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin df_results <- map( variables, - ~dplyr::bind_rows( + ~ dplyr::bind_rows( df_result_levels |> dplyr::select("variable", "var_label", "row_type") |> dplyr::filter(.data$variable %in% .x) |> @@ -359,7 +367,9 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # subsetting cards object on continuous summaries ---------------------------- card <- x$cards |> @@ -372,14 +382,14 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing card |> dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( - ~dplyr::mutate( + ~ dplyr::mutate( .data = .y, stat = glue::glue( x$inputs$statistic[[.data$variable[1]]], .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") ) |> - as.character() + as.character() ) ) |> dplyr::bind_rows() @@ -390,9 +400,11 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing # merge in variable label dplyr::left_join( x$cards |> - dplyr::filter(.data$variable %in% .env$variables, - .data$context %in% "attributes", - .data$stat_name %in% "label") |> + dplyr::filter( + .data$variable %in% .env$variables, + .data$context %in% "attributes", + .data$stat_name %in% "label" + ) |> dplyr::select("variable", var_label = "statistic"), by = "variable" ) |> @@ -415,9 +427,13 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing #' @rdname bridge_summary #' @export pier_summary_missing_row <- function(x, variables = x$inputs$include) { - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # keeping variables to report missing obs for (or returning empty df if none) - if (x$inputs$missing == "no") return(dplyr::tibble()) + if (x$inputs$missing == "no") { + return(dplyr::tibble()) + } if (x$inputs$missing == "ifany") { variables <- x$cards |> @@ -426,7 +442,9 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { dplyr::pull("variable") |> unique() } - if (is_empty(variables)) return(dplyr::tibble()) + if (is_empty(variables)) { + return(dplyr::tibble()) + } # slightly modifying the `x` object for missing value calculations x$inputs$statistic <- rep_named(variables, list(x$inputs$missing_stat)) @@ -451,16 +469,15 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { dplyr::mutate( modify_stat_N = x$cards |> - dplyr::filter(.data$stat_name %in% "N_obs") |> - dplyr::pull("statistic") |> - unlist() |> - getElement(1), + dplyr::filter(.data$stat_name %in% "N_obs") |> + dplyr::pull("statistic") |> + unlist() |> + getElement(1), modify_stat_n = .data$modify_stat_N, modify_stat_p = 1, modify_stat_level = "Overall" ) - } - else { + } else { df_by_stats <- x$cards |> dplyr::filter(.data$variable %in% .env$x$inputs$by & .data$stat_name %in% c("N", "n", "p")) @@ -472,12 +489,14 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { .by = "variable_level", column = paste0("stat_", dplyr::cur_group_id()) ) %>% - {dplyr::bind_rows( - ., - dplyr::select(., "variable_level", "column", statistic = "variable_level") |> - dplyr::mutate(stat_name = "level") |> - dplyr::distinct() - )} |> + { + dplyr::bind_rows( + ., + dplyr::select(., "variable_level", "column", statistic = "variable_level") |> + dplyr::mutate(stat_name = "level") |> + dplyr::distinct() + ) + } |> tidyr::pivot_wider( id_cols = "column", names_from = "stat_name", @@ -498,10 +517,10 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { dplyr::mutate( modify_stat_N = df_by_stats |> - dplyr::filter(.data$stat_name %in% "N") |> - dplyr::pull("statistic") |> - unlist() |> - getElement(1L) + dplyr::filter(.data$stat_name %in% "N") |> + dplyr::pull("statistic") |> + unlist() |> + getElement(1L) ) |> dplyr::left_join( df_by_stats_wide, From 0a61c00f5947981a212c52f7377dfe09ea3b5d03 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 5 Feb 2024 16:05:53 -0800 Subject: [PATCH 23/74] style --- R/as_gt.R | 15 +++++++-------- R/as_tibble.R | 3 ++- R/assign_summary_digits.R | 17 ++++++++++++----- R/assign_summary_type.R | 12 ++++++------ R/modify_header.R | 15 +++++++++------ R/modify_table_styling.R | 36 ++++++++++++++++-------------------- R/print.R | 1 - R/standalone-checks.R | 3 ++- R/standalone-purrr.R | 8 ++++++-- R/styfn.R | 1 - R/style_number.R | 2 +- R/utils-as.R | 16 ++++++++-------- R/utils-gtsummary_core.R | 6 ++---- R/utils-misc.R | 5 +++-- man/bridge_summary.Rd | 18 +++++++++--------- 15 files changed, 83 insertions(+), 75 deletions(-) diff --git a/R/as_gt.R b/R/as_gt.R index e51562b1e8..fd0b22108b 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -83,14 +83,14 @@ table_styling_to_gt_calls <- function(x, ...) { # gt ------------------------------------------------------------------------- groupname_col <- switch("groupname_col" %in% x$table_styling$header$column, - "groupname_col" + "groupname_col" ) caption <- switch(!is.null(x$table_styling$caption), - rlang::call2( - attr(x$table_styling$caption, "text_interpret"), - x$table_styling$caption - ) + rlang::call2( + attr(x$table_styling$caption, "text_interpret"), + x$table_styling$caption + ) ) gt_calls[["gt"]] <- expr(gt::gt( @@ -213,10 +213,9 @@ table_styling_to_gt_calls <- function(x, ...) { # tab_footnote --------------------------------------------------------------- if (nrow(x$table_styling$footnote) == 0 && - nrow(x$table_styling$footnote_abbrev) == 0) { + nrow(x$table_styling$footnote_abbrev) == 0) { gt_calls[["tab_footnote"]] <- list() - } - else { + } else { df_footnotes <- dplyr::bind_rows( x$table_styling$footnote, diff --git a/R/as_tibble.R b/R/as_tibble.R index 539878cf9d..d7966b659f 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -71,8 +71,9 @@ as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, as.data.frame.gtsummary <- function(...) { res <- as_tibble(...) - if (inherits(res, "data.frame")) + if (inherits(res, "data.frame")) { return(as.data.frame(res)) + } res } diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index 486753bc54..f2528bb7ec 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -84,10 +84,13 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { x, function(value, stat_name) { # if not an integer, simply return the value - if (!is_integerish(value)) return(value) + if (!is_integerish(value)) { + return(value) + } # if an integer is passed for a percentage, process stat with style_percent() - if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) + if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) { return(styfn_percent(digits = value)) + } # otherwise, use style_numer() to style number return(styfn_number(digits = value)) } @@ -96,7 +99,9 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { .guess_continuous_summary_digits <- function(x) { # if all missing, return 0 - if (all(is.na(x))) return(styfn_number(digits = 0L)) + if (all(is.na(x))) { + return(styfn_number(digits = 0L)) + } # if class is integer, then round everything to nearest integer if (inherits(x, "integer")) { @@ -122,9 +127,11 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { } .categorical_summary_functions <- - function(statistics = c(" + function(statistics = c( + " N", "N_obs", "N_miss", "N_nonmiss", "n_unweighted", "N_unweighted", - "p_miss", "p_nonmiss", "p_unweighted")) { + "p_miss", "p_nonmiss", "p_unweighted" + )) { lst_defaults <- c( c("n", "N", "N_obs", "N_miss", "N_nonmiss", "n_unweighted", "N_unweighted") |> diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index fa0d18025c..1d3120e1b3 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -66,7 +66,7 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # numeric variables with fewer than 'cat_threshold' levels will be categorical if (inherits(data[[variable]], base_numeric_classes) && - length(unique(stats::na.omit(data[[variable]]))) < cat_threshold) { + length(unique(stats::na.omit(data[[variable]]))) < cat_threshold) { return("categorical") } @@ -93,21 +93,21 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # numeric variables that are 0 and 1 only, will be dichotomous if (inherits(x, c("integer", "numeric")) && - length(setdiff(stats::na.omit(x), c(0, 1))) == 0) { + length(setdiff(stats::na.omit(x), c(0, 1))) == 0) { return(stats::na.omit(x) |> unique() |> sort() |> dplyr::last()) } # factor variables that are "No" and "Yes" only, will be dichotomous if (inherits(x, "factor") && - length(levels(x)) == 2L && - setequal(toupper(levels(x)), c("NO", "YES"))) { + length(levels(x)) == 2L && + setequal(toupper(levels(x)), c("NO", "YES"))) { return(levels(x)[toupper(levels(x)) %in% "YES"]) } # character variables that are "No" and "Yes" only, will be dichotomous if (inherits(x, "character") && - setequal(toupper(stats::na.omit(x)), c("NO", "YES")) && - length(stats::na.omit(x)) == 2L) { + setequal(toupper(stats::na.omit(x)), c("NO", "YES")) && + length(stats::na.omit(x)) == 2L) { return(unique(x)[toupper(unique(x)) %in% "YES"]) } diff --git a/R/modify_header.R b/R/modify_header.R index c5b5c93110..ad9628bb5c 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -1,5 +1,3 @@ - - modify_header <- function(x, ..., text_interpret = c("md", "html"), quiet = NULL, update = NULL) { # process inputs ------------------------------------------------------------- @@ -12,8 +10,11 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), "2.0.0", "gtsummary::modify_header(update=)", details = "Use `modify_header(...)` input instead." ) - if (is.factor(dots)) dots <- c(list(dots), update) - else dots <- c(list(dots), update) + if (is.factor(dots)) { + dots <- c(list(dots), update) + } else { + dots <- c(list(dots), update) + } } cards::process_formula_selectors(data = x$table_body, dots = dots) @@ -22,7 +23,8 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), predicate = function(x) is_string(x), error_msg = c("All values passed in {.arg ...} must be strings.", - "i" = "For example, {.code label = '**Variable**'}") + "i" = "For example, {.code label = '**Variable**'}" + ) ) # evaluate the strings with glue @@ -69,8 +71,9 @@ modify_header <- function(x, ..., text_interpret = c("md", "html"), data = df_header_subset ) - if (!is.null(glued_value$result)) + if (!is.null(glued_value$result)) { return(glued_value$result) + } cli::cli_abort("There was an error the {.fun glue::glue} evaluation of {.val {value}}.") } diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index c5490a3aff..ff05b6e2b4 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -125,8 +125,8 @@ modify_table_styling <- function(x, indentation = ifelse("indent" %in% text_format, 4L, 8L), text_format = text_format |> - setdiff(c("indent", "indent2")) %>% - {.ifelse1(is_empty(.), NULL, .)} #nolint + setdiff(c("indent", "indent2")) %>% + {.ifelse1(is_empty(.), NULL, .)} # styler: off ) env_bind(.env = current_env(), !!!lst_new_args) @@ -157,7 +157,7 @@ modify_table_styling <- function(x, rows_eval_error <- tryCatch( eval_tidy(rows, data = x$table_body) %>% - {!is.null(.) && !is.logical(.)}, #nolint + {!is.null(.) && !is.logical(.)}, # styler: off error = function(e) TRUE ) if (rows_eval_error) { @@ -271,8 +271,8 @@ modify_table_styling <- function(x, format_type = text_format, undo_text_format = FALSE ) %>% - {tidyr::expand_grid(!!!.)} %>% # nolint - {dplyr::bind_rows(x$table_styling$text_format, .)} # nolint + {tidyr::expand_grid(!!!.)} %>% # styler: off + {dplyr::bind_rows(x$table_styling$text_format, .)} # styler: off } if (!is.null(undo_text_format)) { x$table_styling$text_format <- @@ -282,8 +282,8 @@ modify_table_styling <- function(x, format_type = undo_text_format, undo_text_format = TRUE ) %>% - {tidyr::expand_grid(!!!.)} %>% # nolint - {dplyr::bind_rows(x$table_styling$text_format, .)} # nolint + {tidyr::expand_grid(!!!.)} %>% # styler: off + {dplyr::bind_rows(x$table_styling$text_format, .)} # styler: off } # indentation ---------------------------------------------------------------- @@ -292,14 +292,14 @@ modify_table_styling <- function(x, cli::cli_abort("The {.arg indentation} argument must be a scalar integer.") } x$table_styling$indentation <- - dplyr::bind_rows( - x$table_styling$indentation, - dplyr::tibble( - column = columns, - rows = list(rows), - n_spaces = as.integer(indentation) + dplyr::bind_rows( + x$table_styling$indentation, + dplyr::tibble( + column = columns, + rows = list(rows), + n_spaces = as.integer(indentation) + ) ) - ) } # missing_symbol ------------------------------------------------------------- @@ -310,12 +310,8 @@ modify_table_styling <- function(x, rows = list(rows), symbol = missing_symbol ) %>% - { - tidyr::expand_grid(!!!.) - } %>% - { - dplyr::bind_rows(x$table_styling$fmt_missing, .) - } + {tidyr::expand_grid(!!!.)} %>% # styler: off + {dplyr::bind_rows(x$table_styling$fmt_missing, .)} # styler: off } # cols_merge_pattern --------------------------------------------------------- diff --git a/R/print.R b/R/print.R index 38b21ac268..07d4b79f27 100644 --- a/R/print.R +++ b/R/print.R @@ -31,4 +31,3 @@ print.gtsummary <- function(x, ) %>% print() } - diff --git a/R/standalone-checks.R b/R/standalone-checks.R index 03f79719f7..68203cead6 100644 --- a/R/standalone-checks.R +++ b/R/standalone-checks.R @@ -43,7 +43,8 @@ check_class <- function(x, class, length = NULL, allow_empty = FALSE, if (!inherits(x, class)) { cli::cli_abort( c("Argument {.arg {arg_name}} must be class {.cls {class}}.", - "i" = "The class of {.arg {arg_name}} is {.cls {class(x)}}."), + "i" = "The class of {.arg {arg_name}} is {.cls {class(x)}}." + ), call = call ) } diff --git a/R/standalone-purrr.R b/R/standalone-purrr.R index 9cb36e941e..2fefd117af 100644 --- a/R/standalone-purrr.R +++ b/R/standalone-purrr.R @@ -165,7 +165,9 @@ every <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { - if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) + if (!rlang::is_true(.p(.x[[i]], ...))) { + return(FALSE) + } } TRUE } @@ -173,7 +175,9 @@ some <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { - if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) + if (rlang::is_true(.p(.x[[i]], ...))) { + return(TRUE) + } } FALSE } diff --git a/R/styfn.R b/R/styfn.R index e49d7aab54..3067c99941 100644 --- a/R/styfn.R +++ b/R/styfn.R @@ -44,4 +44,3 @@ styfn_ratio <- function(digits = 2, big.mark = NULL, decimal.mark = NULL, ...) { styfn_percent <- function(symbol = FALSE, digits = 0, big.mark = NULL, decimal.mark = NULL, ...) { function(x) style_percent(x, symbol = symbol, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...) } - diff --git a/R/style_number.R b/R/style_number.R index 6181076943..825dcf6cf7 100644 --- a/R/style_number.R +++ b/R/style_number.R @@ -55,5 +55,5 @@ style_number <- function(x, digits = 0, big.mark = NULL, decimal.mark = NULL, # this function assures that 5s are rounded up (and not to even, the default in `round()`) # code taken from https://github.com/sfirke/janitor/blob/main/R/round_half_up.R round2 <- function(x, digits = 0) { - trunc(abs(x) * 10 ^ digits + 0.5 + sqrt(.Machine$double.eps)) / 10 ^ digits * sign(as.numeric(x)) + trunc(abs(x) * 10^digits + 0.5 + sqrt(.Machine$double.eps)) / 10^digits * sign(as.numeric(x)) } diff --git a/R/utils-as.R b/R/utils-as.R index 894aa32ad3..ca37b2b6bd 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -1,11 +1,11 @@ - # takes a table_body and a character rows expression, and returns the resulting row numbers .rows_expr_to_row_numbers <- function(table_body, rows, return_when_null = NA) { rows_evaluated <- rlang::eval_tidy(rows, data = table_body) # if a single lgl value, then expand it to the length of the tabel_body - if (is_scalar_logical(rows_evaluated)) + if (is_scalar_logical(rows_evaluated)) { rows_evaluated <- rep_len(rows_evaluated, length.out = nrow(table_body)) + } if (is.null(rows_evaluated)) { return(return_when_null) @@ -78,13 +78,13 @@ dplyr::mutate( row_numbers = switch(nrow(.) == 0, - integer(0) + integer(0) ) %||% - .rows_expr_to_row_numbers( - x$table_body, .data$rows, - return_when_null = seq_len(nrow(x$table_body)) - ) %>% - list(), + .rows_expr_to_row_numbers( + x$table_body, .data$rows, + return_when_null = seq_len(nrow(x$table_body)) + ) %>% + list(), ) %>% dplyr::select(-"rows") %>% tidyr::unnest("row_numbers") %>% diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index e0d51d32c3..a28f8f063c 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -41,8 +41,7 @@ construct_initial_table_styling <- function(x) { rows = list(rlang::expr(TRUE)), n_spaces = 0L ) - } - else { + } else { dplyr::tibble(column = character(), rows = list(), n_spaces = integer()) } @@ -95,7 +94,7 @@ construct_initial_table_styling <- function(x) { for (styling_element in names(x$table_styling)) { # if element is a tibble with a column called 'column' if (is.data.frame(x$table_styling[[styling_element]]) && - "column" %in% names(x$table_styling[[styling_element]])) { + "column" %in% names(x$table_styling[[styling_element]])) { x$table_styling[[styling_element]] <- x$table_styling[[styling_element]] %>% dplyr::filter(!.data$column %in% deleted_columns) @@ -135,4 +134,3 @@ construct_initial_table_styling <- function(x) { by = "column" ) } - diff --git a/R/utils-misc.R b/R/utils-misc.R index 7bef019eb5..27fc3d1343 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -1,8 +1,9 @@ - .extract_glue_elements <- function(x) { regmatches(x, gregexpr("\\{([^\\}]*)\\}", x)) |> unlist() %>% - {substr(., 2, nchar(.) - 1)} + { + substr(., 2, nchar(.) - 1) + } } .ifelse1 <- function(test, yes, no) { diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 1fdca1effe..6059ec95b9 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -74,23 +74,23 @@ tbl <- ) pier_summary_dichotomous( - x = tbl, - variables = "am", - value = list(am = 1) + x = tbl, + variables = "am", + value = list(am = 1) ) pier_summary_categorical( - x = tbl, - variables = "cyl" + x = tbl, + variables = "cyl" ) pier_summary_continuous2( - x = tbl, - variables = "hp" + x = tbl, + variables = "hp" ) pier_summary_continuous( - x = tbl, - variables = "mpg" + x = tbl, + variables = "mpg" ) } From 2c44fb3c1eef0cb1aaedbaa44f5c958b46e79855 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 5 Feb 2024 16:41:55 -0800 Subject: [PATCH 24/74] Update README.Rmd --- _archive/README.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_archive/README.Rmd b/_archive/README.Rmd index 253450b350..1d7583a33a 100644 --- a/_archive/README.Rmd +++ b/_archive/README.Rmd @@ -69,7 +69,7 @@ Example basic table: library(gtsummary) # summarize the data with our package -table1 <- +table1 <- trial %>% tbl_summary(include = c(age, grade, response)) ``` From da1401c17aec051288c49a6f47b8e92c8c4662fe Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 6 Feb 2024 18:15:05 -0800 Subject: [PATCH 25/74] dichotomous variable updates --- R/bridge_summary.R | 14 ++++++------- R/tbl_summary.R | 2 +- man/tbl_summary.Rd | 2 +- tests/testthat/_snaps/tbl_summary.md | 7 ++++--- tests/testthat/test-tbl_summary.R | 30 +++++++++++++++++++++------- 5 files changed, 36 insertions(+), 19 deletions(-) diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 8b016011e3..13c4a58712 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -98,7 +98,10 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { # build the table body pieces with bridge functions and stack them ----------- x$table_body <- dplyr::left_join( - dplyr::tibble(variable = x$inputs$include), + dplyr::tibble( + variable = x$inputs$include, + summary_type = x$inputs$type[.data$variable] |> unlist() |> unname() + ), dplyr::bind_rows( pier_summary_continuous( x, @@ -446,16 +449,13 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { return(dplyr::tibble()) } - # slightly modifying the `x` object for missing value calculations + # slightly modifying the `x` object for missing value calculations ----------- + # make all the summary stats the same for all vars x$inputs$statistic <- rep_named(variables, list(x$inputs$missing_stat)) - x$cards <- - x$cards |> - dplyr::mutate( - context = ifelse(.data$context %in% "categorical", "continuous", .data$context) - ) pier_summary_continuous(x, variables = variables) |> + # update the row_type and label dplyr::mutate( row_type = "missing", label = x$inputs$missing_text diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 0d1494abb5..e32a24dfea 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -48,7 +48,7 @@ #' Default is `all_categorical(FALSE) ~ "alphanumeric"` #' @param percent Indicates the type of percentage to return. #' Must be one of `c("column", "row", "cell")`. Default is `"column"`. -#' @param include variables to include in the summary table. Default is `everything()` +#' @param include Variables to include in the summary table. Default is `everything()` #' #' @return a gtsummary table of class `"tbl_summary"` #' @export diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index b236427407..315806a418 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -70,7 +70,7 @@ Default is \code{all_categorical(FALSE) ~ "alphanumeric"}} \item{percent}{Indicates the type of percentage to return. Must be one of \code{c("column", "row", "cell")}. Default is \code{"column"}.} -\item{include}{variables to include in the summary table. Default is \code{everything()}} +\item{include}{Variables to include in the summary table. Default is \code{everything()}} } \value{ a gtsummary table of class \code{"tbl_summary"} diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 0227df0543..a249f2675d 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -142,8 +142,7 @@ # tbl_summary(label) allows for named list input Code - as.data.frame(tbl_summary(mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl"), - include = c(mpg, cyl))) + as.data.frame(tbl) Output **Characteristic** **0** \nN = 19 **1** \nN = 13 1 New mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) @@ -171,8 +170,10 @@ # tbl_summary(value) works Code - as.data.frame(tbl_summary(trial, value = "grade" ~ "III", include = grade)) + as.data.frame(tbl) Output **Characteristic** **N = 200** 1 Grade 64 (32%) + 2 Tumor Response 61 (32%) + 3 Unknown 7 diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index c9ecf91724..c88e0b47f4 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -12,14 +12,22 @@ test_that("tbl_summary(by) creates output without error/warning", { }) test_that("tbl_summary(label) allows for named list input", { - expect_snapshot( - tbl_summary( + expect_error( + tbl <- tbl_summary( mtcars, by = am, label = list(mpg = "New mpg", cyl = "New cyl"), include = c(mpg, cyl) - ) |> - as.data.frame() + ), + NA + ) + expect_snapshot(as.data.frame(tbl)) + + expect_equal( + tbl$table_body |> + dplyr::filter(row_type %in% "header") |> + dplyr::pull(label), + c("New mpg", "New cyl") ) }) @@ -44,8 +52,16 @@ test_that("tbl_summary(sort) works", { }) test_that("tbl_summary(value) works", { - expect_snapshot( - tbl_summary(trial, value = "grade" ~ "III", include = grade) |> - as.data.frame() + # ensure grade is coerced to dichotomous and response defaults to dichotomous + expect_error( + tbl <- tbl_summary(trial, value = "grade" ~ "III", include = c(grade, response)), + NA + ) + expect_snapshot(as.data.frame(tbl)) + + # check all summary types are assigned to dichotomous + expect_equal( + tbl$table_body$summary_type |> unique(), + "dichotomous" ) }) From aaee0bdc5a7839bb2aabb1bfb262b69e6f344fb1 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 6 Feb 2024 20:49:15 -0800 Subject: [PATCH 26/74] Update test-tbl_summary.R --- tests/testthat/test-tbl_summary.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index c88e0b47f4..59a12eef28 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -1,14 +1,24 @@ -test_that("standard tbl_summary() creates correct", { +test_that("tbl_summary(data)", { + # creates table when data frame is passed expect_snapshot(tbl_summary(data = trial) |> as.data.frame()) expect_snapshot(tbl_summary(data = mtcars) |> as.data.frame()) expect_snapshot(tbl_summary(data = iris) |> as.data.frame()) + + # errors thrown when bad data argument passed + expect_snapshot(error = TRUE, tbl_summary()) + expect_snapshot(error = TRUE, tbl_summary(data = letters)) + expect_snapshot(error = TRUE, tbl_summary(data = dplyr::tibble())) }) -test_that("tbl_summary(by) creates output without error/warning", { +test_that("tbl_summary(by)", { expect_snapshot(tbl_summary(data = trial, by = trt) |> as.data.frame()) expect_snapshot(tbl_summary(data = mtcars, by = am) |> as.data.frame()) expect_snapshot(tbl_summary(data = iris, by = Species) |> as.data.frame()) + + # errors thrown when bad data argument passed + expect_snapshot(error = TRUE, tbl_summary(mtcars, by = c("mpg", "am"))) + }) test_that("tbl_summary(label) allows for named list input", { From 44d4f2c1c96d3c0fcf07f456dbaa9d8447186e81 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 6 Feb 2024 21:28:57 -0800 Subject: [PATCH 27/74] checks updates --- R/import-standalone-checks.R | 236 +++++++++++++++++++++++++++ R/standalone-checks.R | 94 ----------- R/tbl_summary.R | 7 +- man/check_class.Rd | 57 ------- man/check_length.Rd | 40 ----- man/check_not_missing.Rd | 31 ---- tests/testthat/_snaps/tbl_summary.md | 36 +++- 7 files changed, 275 insertions(+), 226 deletions(-) create mode 100644 R/import-standalone-checks.R delete mode 100644 R/standalone-checks.R delete mode 100644 man/check_class.Rd delete mode 100644 man/check_length.Rd delete mode 100644 man/check_not_missing.Rd diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R new file mode 100644 index 0000000000..e1755e19e3 --- /dev/null +++ b/R/import-standalone-checks.R @@ -0,0 +1,236 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: ddsjoberg/standalone +# file: standalone-checks.R +# last-updated: 2024-01-24 +# license: https://unlicense.org +# imports: [rlang, cli] +# --- +# +# This file provides a minimal functions to check argument values and types +# passed by users to functions in packages. +# +# ## Changelog +# nocov start +# styler: off + +#' Check Class +#' +#' @param class (`character`)\cr +#' character vector or string indicating accepted classes. +#' Passed to `inherits(what=class)` +#' @param x `(object)`\cr +#' object to check +#' @param allow_empty (`logical(1)`)\cr +#' Logical indicating whether an empty value will pass the test. +#' Default is `FALSE` +#' @param arg_name (`string`)\cr +#' string indicating the label/symbol of the object being checked. +#' Default is `rlang::caller_arg(x)` +#' @inheritParams cli::cli_abort +#' @keywords internal +#' @noRd +check_class <- function(x, class, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be class + {.cls {class}}, not {.obj_type_friendly {x}}.", + arg_name = rlang::caller_arg(x), + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible()) + } + + if (!inherits(x, class)) { + cli::cli_abort(message, call = call) + } + invisible() +} + +#' Check Class Data Frame +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_class_data_frame <- function(x, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be class + {.cls {class}}, not {.obj_type_friendly {x}}.", + arg_name = rlang::caller_arg(x), call = parent.frame()) { + check_class( + x = x, class = "data.frame", allow_empty = allow_empty, + message = message, arg_name = arg_name, call = call + ) +} + +#' Check Argument not Missing +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_not_missing <- function(x, + message = "The {.arg {arg_name}} argument cannot be missing.", + arg_name = rlang::caller_arg(x), call = parent.frame()) { + if (missing(x)) { + cli::cli_abort(message, call = call) + } + invisible() +} + +#' Check Length +#' +#' @param msg (`string`)\cr +#' string passed to `cli::cli_abort(message=)` +#' @param length (`integer(1)`)\cr +#' integer specifying the required length +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_length <- function(x, length, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", + "The {.arg {arg_name}} argument must be length {.val {length}}." + ), + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible()) + } + + # check length + if (length(x) != length) { + cli::cli_abort(message, call = call) + } + + invisible() +} + +#' Check is Scalar +#' +#' @param msg (`string`)\cr +#' string passed to `cli::cli_abort(message=)` +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_scalar <- function(x, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", + "The {.arg {arg_name}} argument must be length {.val {length}}." + ), + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), call = parent.frame()) { + check_length( + x = x, length = 1L, message = message, + allow_empty = allow_empty, arg_name = arg_name, call = call + ) +} + +#' Check Range +#' +#' @param x numeric scalar to check +#' @param range numeric vector of length two +#' @param include_bounds logical of length two indicating whether to allow +#' the lower and upper bounds +#' @param scalar logical indicating whether `x` must be a scalar +#' @param msg string passed to `cli::cli_abort(message=)` +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_range <- function(x, + range, + include_bounds = c(FALSE, FALSE), + message = + paste0( + "The {.arg {arg_name}} argument must be in the interval + {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, + {range[2]}{ifelse(include_bounds[2], ']', ')')}}", + ifelse(scalar, " and length {.val {1}}", ""), + "."), + scalar = FALSE, + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible()) + } + + if (isTRUE(scalar)) { + check_scalar(x, message = message, arg_name = arg_name, call = call) + } + + print_error <- FALSE + # check input is numeric + if (!is.numeric(x)) { + print_error <- TRUE + } + + # check the lower bound of range + if (isFALSE(print_error) && isTRUE(include_bounds[1]) && any(x < range[1])) { + print_error <- TRUE + } + if (isFALSE(print_error) && isFALSE(include_bounds[1]) && any(x <= range[1])) { + print_error <- TRUE + } + + # check upper bound of range + if (isFALSE(print_error) && isTRUE(include_bounds[2]) && any(x > range[2])) { + print_error <- TRUE + } + if (isFALSE(print_error) && isFALSE(include_bounds[2]) && any(x >= range[2])) { + print_error <- TRUE + } + + # print error + if (print_error) { + cli::cli_abort(message, call = call) + } + + invisible() +} + + +#' Check Binary +#' +#' Checks if a column in a data frame is binary, +#' that is, if the column is class `` or +#' `` and coded as `c(0, 1)` +#' +#' @param x a vector +#' @param call call environment +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_binary <- function(x, + message = + "Expecting {.arg {arg_name}} to be either {.cls logical} + or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}.", + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible()) + } + + # first check x is either logical or numeric + check_class(x, class = c("logical", "numeric", "integer"), + arg_name = arg_name, message = message, call = call) + + # if "numeric" or "integer", it must be coded as 0, 1 + if (!is.logical(x) && !(rlang::is_integerish(x) && rlang::is_empty(setdiff(x, c(0, 1, NA))))) { + cli::cli_abort(message, call = call) + } + + invisible() +} + +# nocov end +# styler: on diff --git a/R/standalone-checks.R b/R/standalone-checks.R deleted file mode 100644 index 68203cead6..0000000000 --- a/R/standalone-checks.R +++ /dev/null @@ -1,94 +0,0 @@ -# --- -# repo: ddsjoberg/gtsummary -# file: standalone-assertions.R -# last-updated: -# license: https://unlicense.org -# dependencies: rlang, cli -# --- -# -# This file provides a minimal shim to provide checks or assertions, -# typically of function argument inputs. -# -# ## Changelog -# -# nocov start - -#' Check Argument Class -#' -#' @param x object whose class will be checked -#' @param class character vector or string indicating accepted classes. -#' Passed to `inherits(what=class)` -#' @param length if not `NULL`, the `x` object must be length specified -#' @param allow_empty logical indicating whether empty arguments are allowed. -#' Empty is defined by `rlang::is_empty()`, where empty elements include -#' `NULL`, `list()`, `character()`, etc. Default is `FALSE` -#' @param arg_name string indicating the argument name. Default is `rlang::caller_arg(x)` -#' @param allow_null Logical indicating whether a NULL value will pass the test. -#' Default is `FALSE` -#' @inheritParams cli::cli_abort -#' @keywords internal -#' @name check_class -NULL - -#' @rdname check_class -check_class <- function(x, class, length = NULL, allow_empty = FALSE, - arg_name = rlang::caller_arg(x), call = rlang::caller_env()) { - if (isTRUE(allow_empty) && rlang::is_empty(x)) { - return(invisible()) - } - if (!is.null(length)) { - check_length(x = x, length = length, arg_name = arg_name, call = call) - } - - if (!inherits(x, class)) { - cli::cli_abort( - c("Argument {.arg {arg_name}} must be class {.cls {class}}.", - "i" = "The class of {.arg {arg_name}} is {.cls {class(x)}}." - ), - call = call - ) - } - invisible() -} - -#' @rdname check_class -check_class_data_frame <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { - check_class(x = x, class = "data.frame", arg_name = arg_name, call = call) -} - -#' Check Argument not Missing -#' -#' @param x argument to check -#' @param arg_name string indicating the name of the argument. Used in the error messaging. -#' @inheritParams check_class -#' @keywords internal -check_not_missing <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { - if (missing(x)) { - cli::cli_abort("The {.arg {arg_name}} argument cannot be missing.", call = call) - } - invisible() -} - -#' Check Length -#' -#' @param msg (`string`)\cr -#' string passed to `cli::cli_abort(message=)` -#' @param length (`integer(1)`)\cr -#' integer specifying the required length -#' @inheritParams check_class -#' @keywords internal -#' @name check_length -NULL - -#' @rdname check_length -check_length <- function(x, length, arg_name = caller_arg(x), call = parent.frame()) { - if (length(x) != length) { - cli::cli_abort("The {.arg {arg_name}} argument must be length {.val {length}}.", call = call) - } - invisible() -} - -#' @rdname check_length -check_scalar <- function(x, arg_name = caller_arg(x), call = parent.frame()) { - check_length(x = x, length = 1L, arg_name = arg_name, call = call) -} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index e32a24dfea..be6c3d264b 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -176,6 +176,7 @@ tbl_summary <- function(data, # process arguments ---------------------------------------------------------- data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, include = {{ include }}) + check_scalar(by, allow_empty = TRUE) include <- setdiff(include, by) # remove by variable from list vars included missing <- arg_match(arg = missing) percent <- arg_match(arg = percent) @@ -245,8 +246,10 @@ tbl_summary <- function(data, } # check inputs --------------------------------------------------------------- - check_class(missing_text, class = "character", length = 1L) - check_class(missing_stat, class = "character", length = 1L) + check_class(missing_text, class = "character") + check_scalar(missing_text) + check_class(missing_stat, class = "character") + check_scalar(missing_stat) .check_haven_labelled(data[c(include, by)]) .check_tbl_summary_args( data = data, label = label, statistic = statistic, diff --git a/man/check_class.Rd b/man/check_class.Rd deleted file mode 100644 index 497e8b84db..0000000000 --- a/man/check_class.Rd +++ /dev/null @@ -1,57 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standalone-checks.R -\name{check_class} -\alias{check_class} -\alias{check_class_data_frame} -\title{Check Argument Class} -\usage{ -check_class( - x, - class, - length = NULL, - allow_empty = FALSE, - arg_name = rlang::caller_arg(x), - call = rlang::caller_env() -) - -check_class_data_frame( - x, - arg_name = rlang::caller_arg(x), - call = parent.frame() -) -} -\arguments{ -\item{x}{object whose class will be checked} - -\item{class}{character vector or string indicating accepted classes. -Passed to \code{inherits(what=class)}} - -\item{length}{if not \code{NULL}, the \code{x} object must be length specified} - -\item{allow_empty}{logical indicating whether empty arguments are allowed. -Empty is defined by \code{rlang::is_empty()}, where empty elements include -\code{NULL}, \code{list()}, \code{character()}, etc. Default is \code{FALSE}} - -\item{arg_name}{string indicating the argument name. Default is \code{rlang::caller_arg(x)}} - -\item{call}{The execution environment of a currently running -function, e.g. \code{call = caller_env()}. The corresponding function -call is retrieved and mentioned in error messages as the source -of the error. - -You only need to supply \code{call} when throwing a condition from a -helper function which wouldn't be relevant to mention in the -message. - -Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to -respectively not display any call or hard-code a code to display. - -For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} - -\item{allow_null}{Logical indicating whether a NULL value will pass the test. -Default is \code{FALSE}} -} -\description{ -Check Argument Class -} -\keyword{internal} diff --git a/man/check_length.Rd b/man/check_length.Rd deleted file mode 100644 index 26c1a21ac5..0000000000 --- a/man/check_length.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standalone-checks.R -\name{check_length} -\alias{check_length} -\alias{check_scalar} -\title{Check Length} -\usage{ -check_length(x, length, arg_name = caller_arg(x), call = parent.frame()) - -check_scalar(x, arg_name = caller_arg(x), call = parent.frame()) -} -\arguments{ -\item{x}{object whose class will be checked} - -\item{length}{(\code{integer(1)})\cr -integer specifying the required length} - -\item{arg_name}{string indicating the argument name. Default is \code{rlang::caller_arg(x)}} - -\item{call}{The execution environment of a currently running -function, e.g. \code{call = caller_env()}. The corresponding function -call is retrieved and mentioned in error messages as the source -of the error. - -You only need to supply \code{call} when throwing a condition from a -helper function which wouldn't be relevant to mention in the -message. - -Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to -respectively not display any call or hard-code a code to display. - -For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} - -\item{msg}{(\code{string})\cr -string passed to \code{cli::cli_abort(message=)}} -} -\description{ -Check Length -} -\keyword{internal} diff --git a/man/check_not_missing.Rd b/man/check_not_missing.Rd deleted file mode 100644 index 22a122109f..0000000000 --- a/man/check_not_missing.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standalone-checks.R -\name{check_not_missing} -\alias{check_not_missing} -\title{Check Argument not Missing} -\usage{ -check_not_missing(x, arg_name = rlang::caller_arg(x), call = parent.frame()) -} -\arguments{ -\item{x}{argument to check} - -\item{arg_name}{string indicating the name of the argument. Used in the error messaging.} - -\item{call}{The execution environment of a currently running -function, e.g. \code{call = caller_env()}. The corresponding function -call is retrieved and mentioned in error messages as the source -of the error. - -You only need to supply \code{call} when throwing a condition from a -helper function which wouldn't be relevant to mention in the -message. - -Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to -respectively not display any call or hard-code a code to display. - -For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} -} -\description{ -Check Argument not Missing -} -\keyword{internal} diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index a249f2675d..0bcbab2b66 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -1,4 +1,4 @@ -# standard tbl_summary() creates correct +# tbl_summary(data) Code as.data.frame(tbl_summary(data = trial)) @@ -70,7 +70,31 @@ 7 versicolor 50 (33%) 8 virginica 50 (33%) -# tbl_summary(by) creates output without error/warning +--- + + Code + tbl_summary() + Condition + Error in `tbl_summary()`: + ! The `data` argument cannot be missing. + +--- + + Code + tbl_summary(data = letters) + Condition + Error in `tbl_summary()`: + ! The `data` argument must be class , not a character vector. + +--- + + Code + tbl_summary(data = dplyr::tibble()) + Condition + Error in `tbl_summary()`: + ! Expecting `data` argument to have at least 1 row and 1 column. + +# tbl_summary(by) Code as.data.frame(tbl_summary(data = trial, by = trt)) @@ -139,6 +163,14 @@ 3 5.55 (5.10, 5.90) 4 2.00 (1.80, 2.30) +--- + + Code + tbl_summary(mtcars, by = c("mpg", "am")) + Condition + Error in `tbl_summary()`: + ! The `by` argument must be length 1 or empty. + # tbl_summary(label) allows for named list input Code From 32e828b22015792abdba9eb23c40ff5d393889ac Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 6 Feb 2024 21:30:33 -0800 Subject: [PATCH 28/74] forcats shim update --- ...tandalone-forcats.R => import-standalone-forcats.R} | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) rename R/{standalone-forcats.R => import-standalone-forcats.R} (73%) diff --git a/R/standalone-forcats.R b/R/import-standalone-forcats.R similarity index 73% rename from R/standalone-forcats.R rename to R/import-standalone-forcats.R index e6e5039b2c..db001fd9e3 100644 --- a/R/standalone-forcats.R +++ b/R/import-standalone-forcats.R @@ -1,6 +1,10 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# # --- # file: standalone-forcats.R -# last-updated: 2023-12-29 +# last-updated: 2024-01-24 # license: https://unlicense.org # imports: # --- @@ -10,10 +14,9 @@ # of programming. # # ## Changelog -# 2023-12-29 -# First functions added # # nocov start +# styler: off fct_infreq <- function(f, ordered = NA) { # reorder by frequency @@ -33,3 +36,4 @@ fct_inorder <- function(f, ordered = NA) { } # nocov end +# styler: on From bb1114f0778fc3e134fd1067074142b90e5f6e51 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 6 Feb 2024 21:32:18 -0800 Subject: [PATCH 29/74] purrr shim update --- R/{standalone-purrr.R => import-standalone-purrr.R} | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) rename R/{standalone-purrr.R => import-standalone-purrr.R} (94%) diff --git a/R/standalone-purrr.R b/R/import-standalone-purrr.R similarity index 94% rename from R/standalone-purrr.R rename to R/import-standalone-purrr.R index 2fefd117af..623142a0eb 100644 --- a/R/standalone-purrr.R +++ b/R/import-standalone-purrr.R @@ -1,3 +1,7 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# # --- # repo: r-lib/rlang # file: standalone-purrr.R @@ -165,9 +169,7 @@ every <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { - if (!rlang::is_true(.p(.x[[i]], ...))) { - return(FALSE) - } + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) } TRUE } @@ -175,9 +177,7 @@ some <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { - if (rlang::is_true(.p(.x[[i]], ...))) { - return(TRUE) - } + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) } FALSE } From 483507b7353718101965169c4aaf761241d30ae2 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 8 Feb 2024 07:53:45 -0800 Subject: [PATCH 30/74] Update test-tbl_summary.R --- tests/testthat/test-tbl_summary.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index 59a12eef28..d23be5f2cc 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -18,10 +18,9 @@ test_that("tbl_summary(by)", { # errors thrown when bad data argument passed expect_snapshot(error = TRUE, tbl_summary(mtcars, by = c("mpg", "am"))) - }) -test_that("tbl_summary(label) allows for named list input", { +test_that("tbl_summary(label)", { expect_error( tbl <- tbl_summary( mtcars, From bc449d26b2694f5bc0384bacb4abc41b768f18f8 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 8 Feb 2024 20:23:05 -0800 Subject: [PATCH 31/74] new checks file --- R/import-standalone-checks.R | 49 +++++++++++++++++++++++++++++++----- R/tbl_summary.R | 2 +- 2 files changed, 44 insertions(+), 7 deletions(-) diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index e1755e19e3..f98135e811 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -54,16 +54,53 @@ check_class <- function(x, class, allow_empty = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_class_data_frame <- function(x, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be class +check_data_frame <- function(x, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be class {.cls {class}}, not {.obj_type_friendly {x}}.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { + arg_name = rlang::caller_arg(x), call = parent.frame()) { check_class( x = x, class = "data.frame", allow_empty = allow_empty, message = message, arg_name = arg_name, call = call ) } +#' Check Class Logical +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_logical <- function(x, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be class + {.cls {class}}, not {.obj_type_friendly {x}}.", + arg_name = rlang::caller_arg(x), call = parent.frame()) { + check_class( + x = x, class = "logical", allow_empty = allow_empty, + message = message, arg_name = arg_name, call = call + ) +} + +#' Check Class Logical and Scalar +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_scalar_logical <- function(x, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be a scalar with class + {.cls {class}}, not {.obj_type_friendly {x}}.", + arg_name = rlang::caller_arg(x), call = parent.frame()) { + check_logical( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + call = call + ) + + check_scalar( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + call = call + ) +} + #' Check Argument not Missing #' #' @inheritParams check_class @@ -148,11 +185,11 @@ check_range <- function(x, include_bounds = c(FALSE, FALSE), message = paste0( - "The {.arg {arg_name}} argument must be in the interval + "The {.arg {arg_name}} argument must be in the interval {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, {range[2]}{ifelse(include_bounds[2], ']', ')')}}", - ifelse(scalar, " and length {.val {1}}", ""), - "."), + ifelse(scalar, " and length {.val {1}}", ""), + "."), scalar = FALSE, allow_empty = FALSE, arg_name = rlang::caller_arg(x), diff --git a/R/tbl_summary.R b/R/tbl_summary.R index be6c3d264b..31f147215f 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -170,7 +170,7 @@ tbl_summary <- function(data, include = everything()) { # data argument checks ------------------------------------------------------- check_not_missing(data) - check_class_data_frame(data) + check_data_frame(data) .data_dim_checks(data) # process arguments ---------------------------------------------------------- From a896032423040a4ff333c0f96a91506e7c5b2ed2 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 14 Feb 2024 14:19:06 -0800 Subject: [PATCH 32/74] lil updates --- R/import-standalone-checks.R | 22 ++++++++++++++++++++++ R/tbl_summary.R | 2 +- man/tbl_summary.Rd | 2 +- 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index f98135e811..497acc6836 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -101,6 +101,28 @@ check_scalar_logical <- function(x, allow_empty = FALSE, ) } +#' Check String +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_string <- function(x, allow_empty = FALSE, + message = "The {.arg {arg_name}} argument must be a string, + not {.obj_type_friendly {x}}.", + arg_name = rlang::caller_arg(x), call = parent.frame()) { + check_class( + x = x, class = "character", allow_empty = allow_empty, + message = message, arg_name = arg_name, + call = call + ) + + check_scalar( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + call = call + ) +} + #' Check Argument not Missing #' #' @inheritParams check_class diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 31f147215f..3572f1ec24 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -140,7 +140,7 @@ #' by = trt, #' label = list(age = "Patient Age"), #' statistic = list(all_continuous() ~ "{mean} ({sd})"), -#' digits = list(age ~ c(0, 1)) +#' digits = list(age = c(0, 1)) #' ) #' #' # Example 3 ---------------------------------- diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 315806a418..10d865b19c 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -171,7 +171,7 @@ tbl_summary_ex2 <- by = trt, label = list(age = "Patient Age"), statistic = list(all_continuous() ~ "{mean} ({sd})"), - digits = list(age ~ c(0, 1)) + digits = list(age = c(0, 1)) ) # Example 3 ---------------------------------- From 9e54a4c2d856fdc31989a536b623e34c779d7540 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 19 Feb 2024 15:38:15 -0800 Subject: [PATCH 33/74] Adding more `tbl_summary()` tests and organizing snapshot tests (#1604) * data arg update * by arg update for snaps * snap updates for label argument * snaps sort arg * more updates * trucking along * Update tbl_summary.md * more testing * doc update --- DESCRIPTION | 2 +- NEWS.md | 6 +- R/assign_summary_digits.R | 39 ++- R/assign_summary_type.R | 4 +- R/tbl_summary.R | 79 ++++- R/utils-misc.R | 18 + man/is_date_time.Rd | 23 ++ tests/testthat/_snaps/tbl_summary.md | 207 ++++++++++- tests/testthat/test-tbl_summary.R | 495 ++++++++++++++++++++++++++- 9 files changed, 823 insertions(+), 50 deletions(-) create mode 100644 man/is_date_time.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 67d4cf9209..19ee91b726 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9026), + cards (>= 0.0.0.9039), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/NEWS.md b/NEWS.md index c30f704b15..dea2db78ca 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,11 +6,11 @@ * The counts in the header of `tbl_summary(by)` tables now appear on a new line. -* If a column is all `NA` it is now removed from the summary table created with `tbl_summary()`. +* If a column is all `NA_character_` in `tbl_summary()`, the default summary type is now `"continuous"`, where previously it was `"dichotomous"`. * Added a family of function `styfn_*()` that are similar to the `style_*()` except they return a styling _function_, rather than a styled value. -* Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be explicitly defined in a factor. +* Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be either explicitly defined in a factor or be a logical vector. This means that a vector of all `"yes"` values will default to a categorical summary. * Previously, indentation was handled with `modify_table_styling(text_format = c("indent", "indent2"))`, which would indent a cell 4 and 8 spaces, respectively. Handling of indentation has been migrated to `modify_table_styling(indentation = integer())`, and by default, the label column is indented to zero spaces. This makes it easier to indent a group of rows. @@ -18,6 +18,8 @@ * In `tbl_summary()`, the default calculation for quantiles (e.g. statistics of the form `"p25"` or `"p75"`) has been updated with type `quantile(type=2)`. +* In `tbl_summary()`, dates and times showed the minimum and maximum values only by default. They are now treated as all other continuous summaries and share their default statistics of the median and IQR. + #### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index f2528bb7ec..4bed328374 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -91,7 +91,7 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) { return(styfn_percent(digits = value)) } - # otherwise, use style_numer() to style number + # otherwise, use style_number() to style number return(styfn_number(digits = value)) } ) @@ -108,22 +108,31 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { return(styfn_number(digits = 0L)) } - # otherwise guess the number of dignits to use based on the spread + # if it's a date or time, then convert the result to character + if (is_date_time(x)) { + return(as.character) + } + + # otherwise guess the number of digits to use based on the spread # calculate the spread of the variable - var_spread <- - stats::quantile(x, probs = c(0.95), na.rm = TRUE) - - stats::quantile(x, probs = c(0.05), na.rm = TRUE) - - styfn_number( - digits = - dplyr::case_when( - var_spread < 0.01 ~ 4L, - var_spread >= 0.01 & var_spread < 0.1 ~ 3L, - var_spread >= 0.1 & var_spread < 10 ~ 2L, - var_spread >= 10 & var_spread < 20 ~ 1L, - var_spread >= 20 ~ 0L - ) + tryCatch({ + var_spread <- + stats::quantile(x, probs = c(0.95), na.rm = TRUE) - + stats::quantile(x, probs = c(0.05), na.rm = TRUE) + + styfn_number( + digits = + dplyr::case_when( + var_spread < 0.01 ~ 4L, + var_spread >= 0.01 & var_spread < 0.1 ~ 3L, + var_spread >= 0.1 & var_spread < 10 ~ 2L, + var_spread >= 10 & var_spread < 20 ~ 1L, + var_spread >= 20 ~ 0L + ) + )}, + error = function(e) 0L ) + } .categorical_summary_functions <- diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index 1d3120e1b3..8501dcbbb3 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -93,7 +93,7 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # numeric variables that are 0 and 1 only, will be dichotomous if (inherits(x, c("integer", "numeric")) && - length(setdiff(stats::na.omit(x), c(0, 1))) == 0) { + setequal(unique(stats::na.omit(x)), c(0, 1))) { return(stats::na.omit(x) |> unique() |> sort() |> dplyr::last()) } @@ -107,7 +107,7 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # character variables that are "No" and "Yes" only, will be dichotomous if (inherits(x, "character") && setequal(toupper(stats::na.omit(x)), c("NO", "YES")) && - length(stats::na.omit(x)) == 2L) { + length(unique(stats::na.omit(x))) == 2L) { return(unique(x)[toupper(unique(x)) %in% "YES"]) } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 3572f1ec24..161615b43d 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -203,13 +203,21 @@ tbl_summary <- function(data, # processed arguments are saved into this env cards::process_formula_selectors( data = data[include], - label = label, statistic = .ifelse1( missing(statistic), get_theme_element("TODO:fill-this-in", default = statistic), statistic ), + include_env = TRUE + ) + + # add the calling env to the statistics + statistic <- .add_env_to_list_elements(statistic, env = caller_env()) + + cards::process_formula_selectors( + data = data[include], + label = label, sort = .ifelse1( missing(sort), @@ -269,7 +277,9 @@ tbl_summary <- function(data, cards::bind_ard( cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), cards::ard_missing(data, - variables = all_of(include), by = all_of(by), + variables = all_of(include), + by = all_of(by), + fmt_fn = digits, stat_labels = ~ default_stat_labels() ), # tabulate by variable for header stats @@ -295,7 +305,7 @@ tbl_summary <- function(data, variables = all_dichotomous(), fmt_fn = digits, denominator = percent, - values = value, + value = value, stat_labels = ~ default_stat_labels() ), # calculate categorical summaries @@ -303,12 +313,16 @@ tbl_summary <- function(data, data, by = all_of(by), variables = all_continuous(), - statistics = + statistic = .continuous_statistics_chr_to_fun(statistic[select(data, all_continuous()) |> names()]), fmt_fn = digits, stat_labels = ~ default_stat_labels() ) - ) + ) |> + cards::replace_null_statistic() + + # print all warnings and errors that occurred while calculating requested stats + cards::print_ard_conditions(cards) # construct initial tbl_summary object --------------------------------------- x <- @@ -317,6 +331,7 @@ tbl_summary <- function(data, inputs = tbl_summary_inputs, call_list = list(tbl_summary = call) ) |> + .check_stats_available() |> brdg_summary() |> structure(class = c("tbl_summary", "gtsummary")) @@ -344,6 +359,42 @@ tbl_summary <- function(data, x } +.check_stats_available <- function(x, call = parent.frame()) { + # TODO: this could be made more accurate by grouping the cards data frame by the group##_level columns + x$inputs$statistic |> + imap( + function(pre_glue_stat, variable) { + extracted_stats <- .extract_glue_elements(pre_glue_stat) + available_stats <- + x$cards |> + dplyr::filter(.data$variable %in% .env$variable, !.data$context %in% "attributes") |> + dplyr::pull("stat_name") + + missing_stats <- extracted_stats[!extracted_stats %in% available_stats] + if (!is_empty(missing_stats)) { + cli::cli_abort( + c("Statistic {.val {missing_stats}} is not available for variable {.val {variable}}.", + i = "Select among {.val {rev(unique(available_stats))}}."), + call = call + ) + } + } + ) + + + x +} + +.add_env_to_list_elements <- function(x, env) { + lapply( + x, + function(.x) { + attr(.x, ".Environment") <- attr(.x, ".Environment") %||% env + .x + } + ) +} + .sort_data_infreq <- function(data, sort, type) { # if no frequency sorts requested, just return data frame if (every(sort, function(x) x %in% "alphanumeric")) { @@ -459,7 +510,7 @@ tbl_summary <- function(data, invisible() } -.continuous_statistics_chr_to_fun <- function(statistics) { +.continuous_statistics_chr_to_fun <- function(statistics, call = parent.frame()) { # vector of all the categorical summary function names # these are defined internally, and we don't need to convert them to true fns chr_protected_cat_names <- .categorical_summary_functions() |> @@ -487,11 +538,17 @@ tbl_summary <- function(data, return(.str_to_quantile_fun(chr_fun_name)) } # otherwise, convert the string to an expr and evaluate - # TODO: for values that were converted from formulas, - # this needs to be updated to evaluate from the formula env - # this will first require an updated to the {cards} function that processes the inputs. - # i am not sure if we need to track any other env, or just the formulas... - eval(rlang::parse_expr(chr_fun_name)) + tryCatch( + eval(parse_expr(chr_fun_name), envir = attr(x, ".Environment") %||% current_env()), + error = function(e) { + cli::cli_abort(c( + "Problem with the {.arg statistic} argument.", + "Error converting string {.val {chr_fun_name}} to a function.", + i = "Is the name spelled correctly and available?" + ), call = call) + } + ) + } ) |> set_names(chr_fun_names) diff --git a/R/utils-misc.R b/R/utils-misc.R index 27fc3d1343..03e879c052 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -29,3 +29,21 @@ add_expr_after <- function(calls, add_after, expr, new_name = NULL) { # insert list append(calls, new_list, after = index) } + + +#' Is a date/time +#' +#' `is_date_time()`: Predicate for date, time, or date-time vector identification. +#' +#' @param x a vector +#' +#' @return a scalar logical +#' @keywords internal +#' +#' @examples +#' iris |> +#' dplyr::mutate(date = as.Date("2000-01-01") + dplyr::row_number()) |> +#' lapply(gtsummary:::is_date_time) +is_date_time <- function(x) { + inherits(x, c("Date", "POSIXct", "POSIXlt")) +} diff --git a/man/is_date_time.Rd b/man/is_date_time.Rd new file mode 100644 index 0000000000..9076f49764 --- /dev/null +++ b/man/is_date_time.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-misc.R +\name{is_date_time} +\alias{is_date_time} +\title{Is a date/time} +\usage{ +is_date_time(x) +} +\arguments{ +\item{x}{a vector} +} +\value{ +a scalar logical +} +\description{ +\code{is_date_time()}: Predicate for date, time, or date-time vector identification. +} +\examples{ +iris |> + dplyr::mutate(date = as.Date("2000-01-01") + dplyr::row_number()) |> + lapply(gtsummary:::is_date_time) +} +\keyword{internal} diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 0bcbab2b66..8e819fd549 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -70,7 +70,7 @@ 7 versicolor 50 (33%) 8 virginica 50 (33%) ---- +# tbl_summary(data) errors properly Code tbl_summary() @@ -163,7 +163,7 @@ 3 5.55 (5.10, 5.90) 4 2.00 (1.80, 2.30) ---- +# tbl_summary(by) errors properly Code tbl_summary(mtcars, by = c("mpg", "am")) @@ -171,7 +171,7 @@ Error in `tbl_summary()`: ! The `by` argument must be length 1 or empty. -# tbl_summary(label) allows for named list input +# tbl_summary(label) Code as.data.frame(tbl) @@ -183,23 +183,92 @@ 4 6 4 (21%) 3 (23%) 5 8 12 (63%) 2 (15%) -# tbl_summary(sort) works +# tbl_summary(label) errors properly Code - tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + tbl_summary(trial["age"], label = list(age = letters)) Condition Error in `tbl_summary()`: - ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + ! Error in argument `label` for column "age": value must be a string. --- Code - tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + tbl_summary(trial["age"], label = letters) Condition Error in `tbl_summary()`: - ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + ! The `label` argument must be a named list, list of formulas, or a single formula. + i Review ?syntax (`?cards::syntax()`) for examples and details. + +# tbl_summary(statistic) errors properly -# tbl_summary(value) works + Code + tbl_summary(trial, include = response, statistic = ~"{n} ({not_a_statistic})") + Condition + Error in `tbl_summary()`: + ! Statistic "not_a_statistic" is not available for variable "response". + i Select among "p", "N", "n", "p_nonmiss", "p_miss", "N_nonmiss", "N_miss", and "N_obs". + +--- + + Code + tbl_summary(trial, include = age, statistic = ~"({not_a_summary_statistic})") + Condition + Error in `tbl_summary()`: + ! Problem with the `statistic` argument. + Error converting string "not_a_summary_statistic" to a function. + i Is the name spelled correctly and available? + +# tbl_summary(type) + + Code + dplyr::select(getElement(tbl_summary(trial, include = c(age, marker, response, + stage), type = list(age = "continuous", marker = "continuous2", response = "dichotomous", + state = "categorical"), missing = "no"), "table_body"), variable, + summary_type, row_type, label) + Output + # A tibble: 9 x 4 + variable summary_type row_type label + + 1 age continuous header Age + 2 marker continuous2 header Marker Level (ng/mL) + 3 marker continuous2 level Median (Q1, Q3) + 4 response dichotomous header Tumor Response + 5 stage categorical header T Stage + 6 stage categorical level T1 + 7 stage categorical level T2 + 8 stage categorical level T3 + 9 stage categorical level T4 + +# tbl_summary(type) proper errors/messages + + Code + tbl <- tbl_summary(trial, include = grade, type = grade ~ "continuous") + Message + The following errors were returned while calculating statistics: + x For variable `grade` and "median" statistic: need numeric data + x For variable `grade` and "p25" and "p75" statistics: (unordered) factors are not allowed + +--- + + Code + tbl_summary(trial, include = grade, type = grade ~ "dichotomous", value = grade ~ + "IV") + Condition + Error in `cards::ard_dichotomous()`: + ! Error in argument `value` for variable "grade". + i A value of "IV" was passed, but must be one of I, II, and III. + +--- + + Code + tbl_summary(trial, include = grade, type = grade ~ "dichotomous") + Condition + Error in `FUN()`: + ! Error in argument `value` for variable "grade". + i Summary type is "dichotomous" but no summary value has been assigned. + +# tbl_summary(value) Code as.data.frame(tbl) @@ -209,3 +278,123 @@ 2 Tumor Response 61 (32%) 3 Unknown 7 +# tbl_summary(value) errors properly + + Code + tbl_summary(trial, value = "grade" ~ "IV", include = c(grade, response)) + Condition + Error in `cards::ard_dichotomous()`: + ! Error in argument `value` for variable "grade". + i A value of "IV" was passed, but must be one of I, II, and III. + +# tbl_summary(missing) + + Code + tbl_summary(trial, missing = "NOT AN OPTION") + Condition + Error in `tbl_summary()`: + ! `missing` must be one of "ifany", "no", or "always", not "NOT AN OPTION". + +# tbl_summary(missing_text) + + Code + as.data.frame(tbl_summary(trial, include = response, missing_text = "(MISSING)"), + col_label = FALSE) + Output + label stat_0 + 1 Tumor Response 61 (32%) + 2 (MISSING) 7 + +--- + + Code + tbl_summary(trial, include = response, missing_text = letters) + Condition + Error in `tbl_summary()`: + ! The `missing_text` argument must be length 1. + +--- + + Code + tbl_summary(trial, include = response, missing_text = 10L) + Condition + Error in `tbl_summary()`: + ! The `missing_text` argument must be class , not an integer. + +# tbl_summary(missing_stat) + + Code + tbl_summary(trial, include = response, missing_stat = letters) + Condition + Error in `tbl_summary()`: + ! The `missing_stat` argument must be length 1. + +--- + + Code + tbl_summary(trial, include = response, missing_stat = 10L) + Condition + Error in `tbl_summary()`: + ! The `missing_stat` argument must be class , not an integer. + +# tbl_summary(sort) errors properly + + Code + tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + Condition + Error in `tbl_summary()`: + ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + +--- + + Code + tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + Condition + Error in `tbl_summary()`: + ! Error in argument `sort` for column "cyl": value must be one of "alphanumeric" and "frequency". + +# tbl_summary(percent) + + Code + as.data.frame(tbl_summary(trial, by = trt, include = grade, percent = "column", + statistic = ~"{p}%"), col_labels = FALSE) + Output + label stat_1 stat_2 + 1 Grade + 2 I 36% 32% + 3 II 33% 35% + 4 III 32% 32% + +--- + + Code + as.data.frame(tbl_summary(trial, by = trt, include = grade, percent = "row", + statistic = ~"{p}%"), col_labels = FALSE) + Output + label stat_1 stat_2 + 1 Grade + 2 I 51% 49% + 3 II 47% 53% + 4 III 48% 52% + +--- + + Code + as.data.frame(tbl_summary(trial, by = trt, include = grade, percent = "cell", + statistic = ~"{p}%"), col_labels = FALSE) + Output + label stat_1 stat_2 + 1 Grade + 2 I 18% 17% + 3 II 16% 18% + 4 III 16% 17% + +--- + + Code + tbl_summary(trial, by = trt, include = grade, percent = letters, statistic = ~ + "{p}%") + Condition + Error in `tbl_summary()`: + ! `percent` must be one of "column", "row", or "cell", not "a". + diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index d23be5f2cc..9051431a1a 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -1,25 +1,31 @@ +# tbl_summary(data) ------------------------------------------------------------ test_that("tbl_summary(data)", { # creates table when data frame is passed expect_snapshot(tbl_summary(data = trial) |> as.data.frame()) expect_snapshot(tbl_summary(data = mtcars) |> as.data.frame()) expect_snapshot(tbl_summary(data = iris) |> as.data.frame()) +}) +test_that("tbl_summary(data) errors properly", { # errors thrown when bad data argument passed expect_snapshot(error = TRUE, tbl_summary()) expect_snapshot(error = TRUE, tbl_summary(data = letters)) expect_snapshot(error = TRUE, tbl_summary(data = dplyr::tibble())) }) - +# tbl_summary(by) -------------------------------------------------------------- test_that("tbl_summary(by)", { expect_snapshot(tbl_summary(data = trial, by = trt) |> as.data.frame()) expect_snapshot(tbl_summary(data = mtcars, by = am) |> as.data.frame()) expect_snapshot(tbl_summary(data = iris, by = Species) |> as.data.frame()) +}) +test_that("tbl_summary(by) errors properly", { # errors thrown when bad data argument passed expect_snapshot(error = TRUE, tbl_summary(mtcars, by = c("mpg", "am"))) }) +# tbl_summary(label) ----------------------------------------------------------- test_that("tbl_summary(label)", { expect_error( tbl <- tbl_summary( @@ -40,27 +46,301 @@ test_that("tbl_summary(label)", { ) }) -test_that("tbl_summary(sort) works", { +test_that("tbl_summary(label) errors properly", { + expect_snapshot( + error = TRUE, + tbl_summary(trial["age"], label = list(age = letters)) + ) + + expect_snapshot( + error = TRUE, + tbl_summary(trial["age"], label = letters) + ) +}) + +# tbl_summary(statistic) ------------------------------------------------------- +test_that("tbl_summary(statistic)", { + # categorical summary expect_equal( - tbl_summary(mtcars, sort = all_categorical() ~ "frequency", include = cyl) |> + trial |> + tbl_summary( + include = response, + statistic = + response ~ "n={n} | N={N} | p={p} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}", + missing = "no" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0), + "n=61 | N=193 | p=32 | N_obs=200 | N_miss=7 | N_nonmiss=193 | p_miss=3.5 | p_nonmiss=97" + ) + + # continuous summary, testing cv function and passed in formula + expect_equal({ + cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 + trial |> + tbl_summary( + include = age, + statistic = + age ~ "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}", + missing = "no" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0)}, + "cv=30 | N_obs=200 | N_miss=11 | N_nonmiss=189 | p_miss=5.5 | p_nonmiss=95" + ) + + # continuous summary, testing cv function and passed in named list + expect_equal({ + cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 + trial |> + tbl_summary( + include = age, + statistic = + list(age = "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}"), + missing = "no" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0)}, + "cv=30 | N_obs=200 | N_miss=11 | N_nonmiss=189 | p_miss=5.5 | p_nonmiss=95" + ) +}) + +test_that("tbl_summary(statistic) errors properly", { + expect_snapshot( + error = TRUE, + tbl_summary( + trial, + include = response, + statistic = ~"{n} ({not_a_statistic})" + ) + ) + + expect_snapshot( + error = TRUE, + tbl_summary( + trial, + include = age, + statistic = ~"({not_a_summary_statistic})" + ) + ) +}) + +# tbl_summary(digit) ----------------------------------------------------------- +test_that("tbl_summary(digit)", { + expect_error( + tbl <- tbl_summary( + trial, + include = c(age, response, marker, ttdeath), + digits = list( + # using named list to change 2 of the 3 statistics + age = list(median = 4, p25 = \(x) style_number(x, digits = 2)), + # using a vector of integers + response = c(0, 3), + # using a single integer that will apply to all stats + marker = 0, + # passing a single function that will apply to all stats + ttdeath = list(\(x) style_number(x, digits = 2)) + ), + missing = "no" + ) |> + modify_column_unhide(variable) |> + as.data.frame(col_labels = FALSE), + NA + ) + + # check the correct stats + expect_equal( + tbl |> + dplyr::filter(variable == "age") |> + dplyr::pull(stat_0), + "47.0000 (38.00, 57)" + ) + + expect_equal( + tbl |> + dplyr::filter(variable == "response") |> + dplyr::pull(stat_0), + "61 (31.606%)" + ) + + expect_equal( + tbl |> + dplyr::filter(variable == "marker") |> + dplyr::pull(stat_0), + "1 (0, 1)" + ) + + expect_equal( + tbl |> + dplyr::filter(variable == "ttdeath") |> + dplyr::pull(stat_0), + "22.41 (15.92, 24.00)" + ) +}) + +test_that("tbl_summary(digit) errors properly", { + expect_error( + tbl_summary( + trial, + include = age, + digits = list( + age = list(median = letters, # this is not a function! + p25 = \(x) style_number(x, digits = 2)) + ), + missing = "no" + ), + "*" + ) +}) + +# tbl_summary(type) ------------------------------------------------------------ +test_that("tbl_summary(type)", { + expect_snapshot( + tbl_summary( + trial, + include = c(age, marker, response, stage), + type = list(age = "continuous", marker = "continuous2", response = "dichotomous", state = "categorical"), + missing = "no" + ) |> getElement("table_body") |> - dplyr::filter(row_type %in% "level") |> - dplyr::pull(label), - c("8", "4", "6") + dplyr::select(variable, summary_type, row_type, label) ) - # proper errors are returned + # can use the default type to select variables to change the summary type + expect_equal( + tbl_summary( + trial, + type = list(all_continuous() ~ "continuous2", all_dichotomous() ~ "continuous"), + include = c(age, marker, response), + missing = "no" + ) |> + getElement("inputs") |> + getElement("type"), + list(age = "continuous2", marker = "continuous2", response = "continuous") + ) + + # yes/no variables default to dichotomous + expect_equal( + data.frame(yn = c("no", "yes", "yes")) |> + tbl_summary() |> + getElement("inputs") |> + getElement("value") |> + getElement("yn"), + "yes" + ) + expect_equal( + data.frame( + yn = c("no", "yes", "yes") |> factor() + ) |> + tbl_summary() |> + getElement("inputs") |> + getElement("value") |> + getElement("yn"), + "yes" + ) + expect_equal( + data.frame( + yn = c("no", "yes", "yes") |> factor(levels = c("yes", "no")) + ) |> + tbl_summary() |> + getElement("inputs") |> + getElement("value") |> + getElement("yn"), + "yes" + ) + expect_equal( + data.frame( + yn = c("no", "no", "no") |> factor(levels = c("no", "yes")) + ) |> + tbl_summary() |> + getElement("inputs") |> + getElement("value") |> + getElement("yn"), + "yes" + ) + + # a yes or no only character defaults to categorical + expect_equal( + data.frame(yn = c("yes", "yes")) |> + tbl_summary() |> + getElement("inputs") |> + getElement("type") |> + getElement("yn"), + "categorical" + ) + expect_equal( + data.frame(yn = c("no", "no")) |> + tbl_summary() |> + getElement("inputs") |> + getElement("type") |> + getElement("yn"), + "categorical" + ) + expect_equal( + data.frame(yn = c("nO", "yEs", "yEs")) |> + tbl_summary() |> + getElement("inputs") |> + getElement("value") |> + getElement("yn"), + "yEs" + ) + + # a zero or one only numeric defaults to categorical + expect_equal( + data.frame(yn = c(0, 0)) |> + tbl_summary() |> + getElement("inputs") |> + getElement("type") |> + getElement("yn"), + "categorical" + ) + expect_equal( + data.frame(yn = c(1, 1)) |> + tbl_summary() |> + getElement("inputs") |> + getElement("type") |> + getElement("yn"), + "categorical" + ) + + +}) + +test_that("tbl_summary(type) proper errors/messages", { + # grade cannot be summarized continuously, and we'll see reports in the console + expect_snapshot( + tbl <- tbl_summary( + trial, + include = grade, + type = grade ~ "continuous" + ) + ) + expect_equal(tbl$table_body$stat_0, "NA (NA, NA)") + + # unobserved levels cannot be summarized for a dichotomous summary expect_snapshot( error = TRUE, - tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + tbl_summary( + trial, + include = grade, + type = grade ~ "dichotomous", + value = grade ~ "IV" + ) ) + + # error when no clear dichotomous value present expect_snapshot( error = TRUE, - tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + tbl_summary( + trial, + include = grade, + type = grade ~ "dichotomous" + ) ) }) -test_that("tbl_summary(value) works", { +# tbl_summary(value) ----------------------------------------------------------- +test_that("tbl_summary(value)", { # ensure grade is coerced to dichotomous and response defaults to dichotomous expect_error( tbl <- tbl_summary(trial, value = "grade" ~ "III", include = c(grade, response)), @@ -73,4 +353,199 @@ test_that("tbl_summary(value) works", { tbl$table_body$summary_type |> unique(), "dichotomous" ) + + # check we can pass unobserved levels to values + expect_equal( + trial |> + dplyr::mutate( + grade = factor(grade, levels = c("I", "II", "III", "IV")), + response = TRUE + ) |> + tbl_summary( + include = c(grade, response), + value = list(grade = "IV", response = FALSE) + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0) |> + unique(), + "0 (0%)" + ) +}) + +test_that("tbl_summary(value) errors properly", { + # passing a value that does not exist + expect_snapshot( + error = TRUE, + tbl_summary(trial, value = "grade" ~ "IV", include = c(grade, response)) + ) +}) + +# tbl_summary(missing) --------------------------------------------------------- +test_that("tbl_summary(missing)", { + # default is correctly "ifany" + expect_equal( + tbl_summary( + trial, + include = c(trt, age) + ) |> + as.data.frame(), + tbl <- tbl_summary( + trial, + include = c(trt, age), + missing = "ifany" + ) |> + as.data.frame() + ) + # age includes an Unknown row, and trt does not + expect_equal(tbl[,1], c("Chemotherapy Treatment", "Drug A", "Drug B", "Age", "Unknown")) + + # all vars have a missing row when requested + expect_equal( + tbl_summary( + trial, + include = c(trt, age), + missing = "always" + ) |> + getElement("table_body") |> + dplyr::filter(row_type %in% "missing") |> + nrow(), + 2L + ) + + # None of the vars have a missing row when requested + expect_equal( + tbl_summary( + trial, + include = c(trt, age), + missing = "no" + ) |> + getElement("table_body") |> + dplyr::filter(row_type %in% "missing") |> + nrow(), + 0L + ) + + expect_snapshot( + error = TRUE, + tbl_summary( + trial, + missing = "NOT AN OPTION" + ) + ) +}) + +# tbl_summary(missing_text) ---------------------------------------------------- +test_that("tbl_summary(missing_text)", { + expect_snapshot( + tbl_summary( + trial, + include = response, + missing_text = "(MISSING)" + ) |> + as.data.frame(col_label = FALSE) + ) + + # errors with invalid inputs + expect_snapshot( + error = TRUE, + tbl_summary( + trial, + include = response, + missing_text = letters + ) + ) + expect_snapshot( + error = TRUE, + tbl_summary( + trial, + include = response, + missing_text = 10L + ) + ) +}) + +# tbl_summary(missing_stat) ---------------------------------------------------- +test_that("tbl_summary(missing_stat)", { + # basic reporting works + expect_equal( + tbl_summary( + trial, + include = response, + missing_stat = "N = {N_miss}" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0) |> + dplyr::last(), + "N = 7" + ) + + # reporting of non-standard stats works as well + expect_equal( + tbl_summary( + trial, + include = response, + missing_stat = "{N_miss}, {N_obs}, {N_nonmiss}, {p_miss}, {p_nonmiss}" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0) |> + dplyr::last(), + "7, 200, 193, 3.5, 97" + ) + + # errors with bad inputs + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = response, missing_stat = letters) + ) + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = response, missing_stat = 10L) + ) +}) + +# tbl_summary(sort) ------------------------------------------------------------ +test_that("tbl_summary(sort)", { + expect_equal( + tbl_summary(mtcars, sort = all_categorical() ~ "frequency", include = cyl) |> + getElement("table_body") |> + dplyr::filter(row_type %in% "level") |> + dplyr::pull(label), + c("8", "4", "6") + ) +}) + +test_that("tbl_summary(sort) errors properly", { + # proper errors are returned + expect_snapshot( + error = TRUE, + tbl_summary(mtcars, sort = list(all_categorical() ~ c("frequency", "two"))) + ) + expect_snapshot( + error = TRUE, + tbl_summary(mtcars, sort = list(all_categorical() ~ "freq5555uency")) + ) +}) + +# tbl_summary(percent) --------------------------------------------------------- +test_that("tbl_summary(percent)", { + expect_snapshot( + tbl_summary(trial, by = trt, include = grade, percent = "column", statistic = ~"{p}%") |> + as.data.frame(col_labels = FALSE) + ) + + expect_snapshot( + tbl_summary(trial, by = trt, include = grade, percent = "row", statistic = ~"{p}%") |> + as.data.frame(col_labels = FALSE) + ) + + expect_snapshot( + tbl_summary(trial, by = trt, include = grade, percent = "cell", statistic = ~"{p}%") |> + as.data.frame(col_labels = FALSE) + ) + + # errors with bad input + expect_snapshot( + error = TRUE, + tbl_summary(trial, by = trt, include = grade, percent = letters, statistic = ~"{p}%") + ) }) From e94896a8b45e467e87a650319493c9abeb7b8bb1 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 19 Feb 2024 16:49:30 -0800 Subject: [PATCH 34/74] messaging update --- NEWS.md | 4 ++++ R/tbl_summary.R | 18 ++++++++++++++++-- tests/testthat/_snaps/tbl_summary.md | 1 + 3 files changed, 21 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index dea2db78ca..73a77385b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +20,10 @@ * In `tbl_summary()`, dates and times showed the minimum and maximum values only by default. They are now treated as all other continuous summaries and share their default statistics of the median and IQR. +* The values passed in `tbl_summary(value)` are now only checked for columns that are summary type `"dichotomous"`. + +* Previously, the gtsummary selecting functions, e.g. `all_categorical()`, `all_continuous()`, etc., would error if used out of context. Now they won't select the columns silently. + #### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 161615b43d..389db6c36f 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -174,14 +174,20 @@ tbl_summary <- function(data, .data_dim_checks(data) # process arguments ---------------------------------------------------------- - data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, include = {{ include }}) - check_scalar(by, allow_empty = TRUE) + check_scalar( + by, + allow_empty = TRUE, + message = c("The {.arg {arg_name}} argument must be length {.val {length}} or empty.", + i = "Use {.fun tbl_strata} for more than one {.arg by} variable.") + ) + data <- dplyr::ungroup(data) |> .drop_missing_by_obs(by = by) # styler: off include <- setdiff(include, by) # remove by variable from list vars included missing <- arg_match(arg = missing) percent <- arg_match(arg = percent) cards::process_formula_selectors(data = data[include], value = value) + # assign summary type -------------------------------------------------------- if (!is_empty(type)) { # first set default types, so selectors like `all_continuous()` can be used @@ -359,6 +365,14 @@ tbl_summary <- function(data, x } +.drop_missing_by_obs <- function(data, by) { + if (is_empty(by) || !any(is.na(data[[by]]))) return(data) + + obs_to_drop <- is.na(data[[by]]) + cli::cli_inform("{.val {sum(obs_to_drop)}} missing observations in the {.val {by}} column have been removed.") + data[!obs_to_drop, ] +} + .check_stats_available <- function(x, call = parent.frame()) { # TODO: this could be made more accurate by grouping the cards data frame by the group##_level columns x$inputs$statistic |> diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 8e819fd549..003e85f0b1 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -170,6 +170,7 @@ Condition Error in `tbl_summary()`: ! The `by` argument must be length 1 or empty. + i Use `tbl_strata()` for more than one `by` variable. # tbl_summary(label) From 6d9ba61634350bddd6c176937f471a292244cd79 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 19 Feb 2024 19:22:42 -0800 Subject: [PATCH 35/74] Update .Rbuildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 5f5790b18e..b28fc8eff5 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,6 +18,7 @@ ^revdep$ ^CRAN-RELEASE$ ^\.covrignore$ +^\.DS_Store$ ^lastMiKTeXException$ ^bench$ ^benchmark$ From 6e62ef19c12be915460768154e6efcc90016cc3b Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 20 Feb 2024 20:07:52 -0800 Subject: [PATCH 36/74] updates --- DESCRIPTION | 2 +- tests/testthat/_snaps/tbl_summary.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 19ee91b726..2ef8edcfde 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9039), + cards (>= 0.0.0.9047), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 003e85f0b1..ea6c8c8a44 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -198,7 +198,7 @@ tbl_summary(trial["age"], label = letters) Condition Error in `tbl_summary()`: - ! The `label` argument must be a named list, list of formulas, or a single formula. + ! The `label` argument must be a named list, list of formulas, a single formula, or empty. i Review ?syntax (`?cards::syntax()`) for examples and details. # tbl_summary(statistic) errors properly From ff2a9507c8547323ff574b60f25511401e98dd58 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 21 Feb 2024 18:24:31 -0800 Subject: [PATCH 37/74] updates after cards rename --- DESCRIPTION | 2 +- R/bridge_summary.R | 46 ++++++++++++++++++++++++---------------------- R/tbl_summary.R | 10 +++++----- 3 files changed, 30 insertions(+), 28 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2ef8edcfde..a82419f3e3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9047), + cards (>= 0.0.0.9053), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 13c4a58712..18b9fc5260 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -160,7 +160,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin card <- x$cards |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("categorical", "missing")) |> - cards::apply_statistic_fmt_fn() + cards::apply_fmt_fn() # construct formatted statistics --------------------------------------------- df_glued <- @@ -173,7 +173,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin cards::get_ard_statistics( df_variable_stats, .data$variable_level %in% list(NULL), - .column = "statistic_fmt" + .column = "stat_fmt" ) str_statistic_pre_glue <- @@ -196,7 +196,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin glue::glue( str_to_glue, .envir = - cards::get_ard_statistics(df_variable_level_stats, .column = "statistic_fmt") |> + cards::get_ard_statistics(df_variable_level_stats, .column = "stat_fmt") |> c(lst_variable_stats) ) |> as.character() @@ -224,7 +224,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin .data$context %in% "attributes", .data$stat_name %in% "label" ) |> - dplyr::select("variable", var_label = "statistic"), + dplyr::select("variable", var_label = "stat"), by = "variable" ) |> dplyr::mutate( @@ -274,7 +274,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin card <- x$cards |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> - cards::apply_statistic_fmt_fn() + cards::apply_fmt_fn() # construct formatted statistics --------------------------------------------- df_glued <- @@ -292,7 +292,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin stat <- glue::glue( str_to_glue, - .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") + .envir = cards::get_ard_statistics(.x, .column = "stat_fmt") ) |> as.character() } @@ -327,7 +327,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin .data$context %in% "attributes", .data$stat_name %in% "label" ) |> - dplyr::select("variable", var_label = "statistic"), + dplyr::select("variable", var_label = "stat"), by = "variable" ) |> dplyr::mutate( @@ -377,7 +377,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing card <- x$cards |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> - cards::apply_statistic_fmt_fn() + cards::apply_fmt_fn() # construct formatted statistics --------------------------------------------- df_glued <- @@ -385,15 +385,17 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing card |> dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( - ~ dplyr::mutate( - .data = .y, - stat = - glue::glue( - x$inputs$statistic[[.data$variable[1]]], - .envir = cards::get_ard_statistics(.x, .column = "statistic_fmt") - ) |> + function(.x, .y) { + dplyr::mutate( + .data = .y, + stat = + glue::glue( + x$inputs$statistic[[.data$variable[1]]], + .envir = cards::get_ard_statistics(.x, .column = "stat_fmt") + ) |> as.character() - ) + ) + } ) |> dplyr::bind_rows() @@ -408,7 +410,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing .data$context %in% "attributes", .data$stat_name %in% "label" ) |> - dplyr::select("variable", var_label = "statistic"), + dplyr::select("variable", var_label = "stat"), by = "variable" ) |> dplyr::mutate( @@ -441,7 +443,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { variables <- x$cards |> dplyr::filter(.data$stat_name == "N_miss", .data$variable %in% .env$variables) |> - dplyr::filter(.data$statistic > 0L) |> + dplyr::filter(.data$stat > 0L) |> dplyr::pull("variable") |> unique() } @@ -470,7 +472,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { modify_stat_N = x$cards |> dplyr::filter(.data$stat_name %in% "N_obs") |> - dplyr::pull("statistic") |> + dplyr::pull("stat") |> unlist() |> getElement(1), modify_stat_n = .data$modify_stat_N, @@ -492,7 +494,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { { dplyr::bind_rows( ., - dplyr::select(., "variable_level", "column", statistic = "variable_level") |> + dplyr::select(., "variable_level", "column", stat = "variable_level") |> dplyr::mutate(stat_name = "level") |> dplyr::distinct() ) @@ -500,7 +502,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { tidyr::pivot_wider( id_cols = "column", names_from = "stat_name", - values_from = "statistic" + values_from = "stat" ) |> dplyr::mutate( dplyr::across(-"column", unlist), @@ -518,7 +520,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { modify_stat_N = df_by_stats |> dplyr::filter(.data$stat_name %in% "N") |> - dplyr::pull("statistic") |> + dplyr::pull("stat") |> unlist() |> getElement(1L) ) |> diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 389db6c36f..6b195dba1c 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -286,13 +286,13 @@ tbl_summary <- function(data, variables = all_of(include), by = all_of(by), fmt_fn = digits, - stat_labels = ~ default_stat_labels() + stat_label = ~ default_stat_labels() ), # tabulate by variable for header stats if (!rlang::is_empty(by)) { cards::ard_categorical(data, variables = all_of(by), - stat_labels = ~ default_stat_labels() + stat_label = ~ default_stat_labels() ) }, # tabulate categorical summaries @@ -302,7 +302,7 @@ tbl_summary <- function(data, variables = all_categorical(FALSE), fmt_fn = digits, denominator = percent, - stat_labels = ~ default_stat_labels() + stat_label = ~ default_stat_labels() ), # tabulate dichotomous summaries cards::ard_dichotomous( @@ -312,7 +312,7 @@ tbl_summary <- function(data, fmt_fn = digits, denominator = percent, value = value, - stat_labels = ~ default_stat_labels() + stat_label = ~ default_stat_labels() ), # calculate categorical summaries cards::ard_continuous( @@ -322,7 +322,7 @@ tbl_summary <- function(data, statistic = .continuous_statistics_chr_to_fun(statistic[select(data, all_continuous()) |> names()]), fmt_fn = digits, - stat_labels = ~ default_stat_labels() + stat_label = ~ default_stat_labels() ) ) |> cards::replace_null_statistic() From 3644b3ac6f498a2ca68033ce36cf6270581641ff Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 8 Mar 2024 21:15:08 -0800 Subject: [PATCH 38/74] adding ARDs as lists inside tbl_summary --- DESCRIPTION | 6 ++-- R/bridge_summary.R | 66 +++++++++++++++++++++++-------------------- R/tbl_summary.R | 6 ++-- man/bridge_summary.Rd | 40 ++++++++++++++++++++++---- 4 files changed, 77 insertions(+), 41 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a82419f3e3..e110fa23d8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Depends: R (>= 4.1) Imports: broom.helpers, - cards (>= 0.0.0.9053), + cards (>= 0.1.0.9003), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), @@ -56,6 +56,7 @@ Imports: tibble (>= 3.2.1), tidyr (>= 1.3.0) Suggests: + cardx (>= 0.0.0.9049), knitr, testthat (>= 3.2.0) VignetteBuilder: @@ -63,7 +64,8 @@ VignetteBuilder: RdMacros: lifecycle Remotes: - insightsengineering/cards + insightsengineering/cards, + insightsengineering/cardx Config/testthat/edition: 3 Config/testthat/parallel: true Encoding: UTF-8 diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 18b9fc5260..21db98e00d 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -66,22 +66,17 @@ NULL #' @export brdg_summary <- function(x, calling_function = "tbl_summary") { # add gts info to the cards table -------------------------------------------- - # add the function call column - x$cards <- - x$cards |> - dplyr::mutate(gts_function = .env$calling_function) - # adding the name of the column the stats will populate if (is_empty(x$inputs$by)) { - x$cards$gts_column <- + x[["cards"]][[calling_function]]$gts_column <- ifelse( - x$cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), + x[["cards"]][[calling_function]]$context %in% c("continuous", "categorical", "dichotomous", "missing"), "stat_0", NA_character_ ) } else { - x$cards <- - x$cards |> + x[["cards"]][[calling_function]] <- + x[["cards"]][[calling_function]] |> dplyr::mutate( .by = cards::all_ard_groups(), gts_column = @@ -105,21 +100,25 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { dplyr::bind_rows( pier_summary_continuous( x, - variables = .get_variables_by_type(x$inputs$type, type = "continuous") + variables = .get_variables_by_type(x$inputs$type, type = "continuous"), + calling_function = calling_function ), pier_summary_continuous2( x, - variables = .get_variables_by_type(x$inputs$type, type = "continuous2") + variables = .get_variables_by_type(x$inputs$type, type = "continuous2"), + calling_function = calling_function ), pier_summary_categorical( x, - variables = .get_variables_by_type(x$inputs$type, type = "categorical") + variables = .get_variables_by_type(x$inputs$type, type = "categorical"), + calling_function = calling_function ), pier_summary_dichotomous( x, - variables = .get_variables_by_type(x$inputs$type, type = "dichotomous") + variables = .get_variables_by_type(x$inputs$type, type = "dichotomous"), + calling_function = calling_function ), - pier_summary_missing_row(x) + pier_summary_missing_row(x, calling_function = calling_function) ), by = "variable" ) @@ -135,14 +134,15 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { #' @rdname bridge_summary #' @export -pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { +pier_summary_dichotomous <- function(x, variables, value = x$inputs$value, + calling_function = "tbl_summary") { if (is_empty(variables)) { return(dplyr::tibble()) } # updating the context to continuous, because it will be processed that way below - x$cards <- - x$cards |> + x[["cards"]][[calling_function]] <- + x[["cards"]][[calling_function]] |> dplyr::mutate( context = ifelse(.data$context %in% "dichotomous", "continuous", .data$context) ) @@ -152,13 +152,14 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value) { #' @rdname bridge_summary #' @export -pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat, + calling_function = "tbl_summary") { if (is_empty(variables)) { return(dplyr::tibble()) } # subsetting cards object on categorical summaries ---------------------------- card <- - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("categorical", "missing")) |> cards::apply_fmt_fn() @@ -218,7 +219,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin df_glued |> # merge in variable label dplyr::left_join( - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -266,13 +267,14 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export -pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat, + calling_function = "tbl_summary") { if (is_empty(variables)) { return(dplyr::tibble()) } # subsetting cards object on continuous2 summaries ---------------------------- card <- - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> cards::apply_fmt_fn() @@ -321,7 +323,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin df_glued |> # merge in variable label dplyr::left_join( - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -369,13 +371,14 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export -pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat) { +pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat, + calling_function = "tbl_summary") { if (is_empty(variables)) { return(dplyr::tibble()) } # subsetting cards object on continuous summaries ---------------------------- card <- - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> cards::apply_fmt_fn() @@ -404,7 +407,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing df_glued |> # merge in variable label dplyr::left_join( - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -431,7 +434,8 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing #' @rdname bridge_summary #' @export -pier_summary_missing_row <- function(x, variables = x$inputs$include) { +pier_summary_missing_row <- function(x, variables = x$inputs$include, + calling_function = "tbl_summary") { if (is_empty(variables)) { return(dplyr::tibble()) } @@ -441,7 +445,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { } if (x$inputs$missing == "ifany") { variables <- - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter(.data$stat_name == "N_miss", .data$variable %in% .env$variables) |> dplyr::filter(.data$stat > 0L) |> dplyr::pull("variable") |> @@ -464,13 +468,13 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { ) } -.add_table_styling_stats <- function(x) { +.add_table_styling_stats <- function(x, calling_function = "tbl_summary") { if (is_empty(x$inputs$by)) { x$table_styling$header <- x$table_styling$header |> dplyr::mutate( modify_stat_N = - x$cards |> + x[["cards"]][[calling_function]] |> dplyr::filter(.data$stat_name %in% "N_obs") |> dplyr::pull("stat") |> unlist() |> @@ -480,7 +484,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include) { modify_stat_level = "Overall" ) } else { - df_by_stats <- x$cards |> + df_by_stats <- x[["cards"]][[calling_function]] |> dplyr::filter(.data$variable %in% .env$x$inputs$by & .data$stat_name %in% c("N", "n", "p")) # get a data frame with the by variable stats diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 6b195dba1c..b4685c4094 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -333,7 +333,7 @@ tbl_summary <- function(data, # construct initial tbl_summary object --------------------------------------- x <- list( - cards = cards, + cards = list(tbl_summary = cards), inputs = tbl_summary_inputs, call_list = list(tbl_summary = call) ) |> @@ -354,7 +354,7 @@ tbl_summary <- function(data, modify_table_styling( columns = all_stat_cols(), footnote = - .construct_summary_footnote(x$cards, x$inputs$include, x$inputs$statistic, x$inputs$type) + .construct_summary_footnote(x$cards[["tbl_summary"]], x$inputs$include, x$inputs$statistic, x$inputs$type) ) |> # updating the headers for the stats columns modify_header( @@ -380,7 +380,7 @@ tbl_summary <- function(data, function(pre_glue_stat, variable) { extracted_stats <- .extract_glue_elements(pre_glue_stat) available_stats <- - x$cards |> + x$cards$tbl_summary |> dplyr::filter(.data$variable %in% .env$variable, !.data$context %in% "attributes") |> dplyr::pull("stat_name") diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 6059ec95b9..a13248d9fb 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -12,15 +12,45 @@ \usage{ brdg_summary(x, calling_function = "tbl_summary") -pier_summary_dichotomous(x, variables, value = x$inputs$value) +pier_summary_dichotomous( + x, + variables, + value = x$inputs$value, + calling_function = "tbl_summary" +) -pier_summary_categorical(x, variables, missing, missing_text, missing_stat) +pier_summary_categorical( + x, + variables, + missing, + missing_text, + missing_stat, + calling_function = "tbl_summary" +) -pier_summary_continuous2(x, variables, missing, missing_text, missing_stat) +pier_summary_continuous2( + x, + variables, + missing, + missing_text, + missing_stat, + calling_function = "tbl_summary" +) -pier_summary_continuous(x, variables, missing, missing_text, missing_stat) +pier_summary_continuous( + x, + variables, + missing, + missing_text, + missing_stat, + calling_function = "tbl_summary" +) -pier_summary_missing_row(x, variables = x$inputs$include) +pier_summary_missing_row( + x, + variables = x$inputs$include, + calling_function = "tbl_summary" +) } \arguments{ \item{x}{gtsummary object of class \code{"tbl_summary"}} From c2358b263905756732c7e33cebb3eafe08bce305 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 9 Mar 2024 07:43:07 -0800 Subject: [PATCH 39/74] Create import-standalone-tibble.R --- R/import-standalone-tibble.R | 43 ++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 R/import-standalone-tibble.R diff --git a/R/import-standalone-tibble.R b/R/import-standalone-tibble.R new file mode 100644 index 0000000000..1133e623c3 --- /dev/null +++ b/R/import-standalone-tibble.R @@ -0,0 +1,43 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# file: standalone-tibble.R +# last-updated: 2024-03-09 +# license: https://unlicense.org +# imports: [dplyr] +# --- +# +# This file provides a minimal shim to provide a tibble-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# nocov start +# styler: off + +enframe <- function(x, name = "name", value = "value") { + if (!is.null(names(x))) { + lst <- list(names(x), unname(x)) |> stats::setNames(c(name, value)) + } + else { + lst <- list(seq_along(x), unname(x)) |> stats::setNames(c(name, value)) + } + dplyr::tibble(!!!lst) +} + +remove_rownames <- function(.data) { + rownames(.data) <- NULL + .data +} + +rownames_to_column <- function(.data, var = "rowname") { + .data[[var]] <- rownames(.data) + + dplyr::relocate(.data, dplyr::all_of(var), .before = 1L) +} + +# nocov end +# styler: on From 59da845446815154b807304522b6d2fa470f3a77 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 10 Mar 2024 15:10:54 -0700 Subject: [PATCH 40/74] selecting updates (#1611) --- R/assign_summary_type.R | 10 ----- R/select_helpers.R | 66 ++++++++++++++++++++++++++++-- R/tbl_summary.R | 91 ++++++++++++++++++++++------------------- man/dot-list2tb.Rd | 25 +++++++++++ man/select_prep.Rd | 23 +++++++++++ 5 files changed, 159 insertions(+), 56 deletions(-) create mode 100644 man/dot-list2tb.Rd create mode 100644 man/select_prep.Rd diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index 8501dcbbb3..59ead89017 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -115,13 +115,3 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho NULL } -.add_summary_type_as_attr <- function(data, type) { - type <- type[names(type) %in% names(data)] - type_names <- names(type) - - for (i in seq_along(type)) { - attr(data[[type_names[i]]], "gtsummary.type") <- type[[i]] - } - - data -} diff --git a/R/select_helpers.R b/R/select_helpers.R index 274ffc7c2b..df3d6f955a 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -38,13 +38,13 @@ NULL all_continuous <- function(continuous2 = TRUE) { types <- if (continuous2) c("continuous", "continuous2") else "continuous" - where(function(x) isTRUE(attr(x, "gtsummary.type") %in% types)) + where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% types)) } #' @rdname select_helpers #' @export all_continuous2 <- function() { - where(function(x) isTRUE(attr(x, "gtsummary.type") %in% "continuous2")) + where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% "continuous2")) } #' @rdname select_helpers @@ -52,13 +52,13 @@ all_continuous2 <- function() { all_categorical <- function(dichotomous = TRUE) { types <- if (dichotomous) c("categorical", "dichotomous") else "categorical" - where(function(x) isTRUE(attr(x, "gtsummary.type") %in% types)) + where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% types)) } #' @rdname select_helpers #' @export all_dichotomous <- function() { - where(function(x) isTRUE(attr(x, "gtsummary.type") %in% "dichotomous")) + where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% "dichotomous")) } # #' @rdname select_helpers @@ -101,6 +101,7 @@ all_stat_cols <- function(stat_0 = TRUE) { } } + # #' @rdname select_helpers # #' @export # all_interaction <- broom.helpers::all_interaction @@ -112,3 +113,60 @@ all_stat_cols <- function(stat_0 = TRUE) { # #' @rdname select_helpers # #' @export # all_contrasts <- broom.helpers::all_contrasts + + + +#' Table Body Select Prep +#' +#' This function uses the information in `.$table_body` and adds them +#' as attributes to `data` (if passed). Once they've been assigned as +#' proper gtsummary attributes, gtsummary selectors like `all_continuous()` +#' will work properly. +#' +#' @param table_body a data frame from `.$table_body` +#' @param data an optional data frame the attributes will be added to +#' +#' @return a data frame +#' @keywords internal +select_prep <- function(table_body, data = NULL) { + # if data not passed, use table_body to construct one + if (is.null(data)) { + data <- dplyr::tibble(!!!rep_named(table_body$variable, character(0L))) + } + + # only keeping rows that have corresponding column names in data + table_body <- table_body |> dplyr::filter(.data$variable %in% names(data)) + + # if table_body passed, add columns as attr to data + if (!is.null(table_body)) { + attr_cols <- intersect(names(table_body), c("summary_type", "test_name")) + for (v in attr_cols) { + df_attr <- table_body[c("variable", v)] |> unique() |> tidyr::drop_na() + for (i in seq_len(nrow(df_attr))) { + attr(data[[df_attr$variable[i]]], paste0("gtsummary.", v)) <- df_attr[[v]][i] + } + } + } + + data +} + + +# converts a named list to a table_body format. +# the result of this fn will often be passed to `select_prep()` +#' Convert Named List to Table Body +#' +#' Many arguments in 'gtsummary' accept named lists. This function converts +#' a named list to the `.$table_body` format expected in `select_prep()` +#' +#' @param x named list +#' @param colname string of column name to assign. Default is `caller_arg(x)` +#' +#' @return `.$table_body` data frame +#' @keywords internal +#' @examples +#' type <- list(age = "continuous", response = "dichotomous") +#' gtsummary:::.list2tb(type, "summary_type") +.list2tb <- function(x, colname = caller_arg(x)) { + enframe(unlist(x), "variable", colname) +} diff --git a/R/tbl_summary.R b/R/tbl_summary.R index b4685c4094..111fcaa22b 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -193,58 +193,61 @@ tbl_summary <- function(data, # first set default types, so selectors like `all_continuous()` can be used # to recast the summary type, e.g. make all continuous type "continuous2" default_types <- assign_summary_type(data, include, value) - data <- .add_summary_type_as_attr(data, default_types) # process the user-passed type argument - cards::process_formula_selectors(data = data[include], type = type) + cards::process_formula_selectors( + data = select_prep(.list2tb(default_types, "summary_type"), data[include]), + type = type + ) # fill in any types not specified by user type <- utils::modifyList(default_types, type) } else { type <- assign_summary_type(data, include, value) } - data <- .add_summary_type_as_attr(data, type) - value <- .assign_default_values(data[include], value, type) + value <- + select_prep(.list2tb(type, "summary_type"), data[include]) |> + .assign_default_values(value, type) # evaluate the remaining list-formula arguments ------------------------------ # processed arguments are saved into this env - cards::process_formula_selectors( - data = data[include], - statistic = - .ifelse1( - missing(statistic), - get_theme_element("TODO:fill-this-in", default = statistic), - statistic - ), - include_env = TRUE - ) + select_prep(.list2tb(type, "summary_type"), data[include]) |> + cards::process_formula_selectors( + statistic = + .ifelse1( + missing(statistic), + get_theme_element("TODO:fill-this-in", default = statistic), + statistic + ), + include_env = TRUE + ) # add the calling env to the statistics statistic <- .add_env_to_list_elements(statistic, env = caller_env()) - cards::process_formula_selectors( - data = data[include], - label = label, - sort = - .ifelse1( - missing(sort), - get_theme_element("TODO:fill-this-in", default = sort), - sort - ) - ) + select_prep(.list2tb(type, "summary_type"), data[include]) |> + cards::process_formula_selectors( + label = label, + sort = + .ifelse1( + missing(sort), + get_theme_element("TODO:fill-this-in", default = sort), + sort + ) + ) - cards::process_formula_selectors( - data = data[include], - digits = - .ifelse1( - is_empty(digits), - get_theme_element("TODO:fill-this-in", default = assign_summary_digits(data, statistic, type)), - digits - ) - ) + select_prep(.list2tb(type, "summary_type"), data[include]) |> + cards::process_formula_selectors( + digits = + .ifelse1( + is_empty(digits), + get_theme_element("TODO:fill-this-in", default = assign_summary_digits(data, statistic, type)), + digits + ) + ) # fill in unspecified variables cards::fill_formula_selectors( - data[include], + select_prep(.list2tb(type, "summary_type"), data[include]), statistic = get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])), sort = @@ -256,7 +259,9 @@ tbl_summary <- function(data, # fill each element of digits argument # TODO: this needs to be updated to account for the scenario where there is a template override that may not fill in all the values if (!missing(digits)) { - digits <- assign_summary_digits(data[include], statistic, type, digits = digits) + digits <- + select_prep(.list2tb(type, "summary_type"), data[include]) |> + assign_summary_digits(statistic, type, digits = digits) } # check inputs --------------------------------------------------------------- @@ -271,7 +276,7 @@ tbl_summary <- function(data, ) # sort requested columns by frequency - data <- .sort_data_infreq(data, sort, type) + data <- .sort_data_infreq(data, sort) # save processed function inputs --------------------------------------------- tbl_summary_inputs <- as.list(environment()) @@ -297,7 +302,7 @@ tbl_summary <- function(data, }, # tabulate categorical summaries cards::ard_categorical( - data, + select_prep(.list2tb(type, "summary_type"), data), by = all_of(by), variables = all_categorical(FALSE), fmt_fn = digits, @@ -306,7 +311,7 @@ tbl_summary <- function(data, ), # tabulate dichotomous summaries cards::ard_dichotomous( - data, + select_prep(.list2tb(type, "summary_type"), data), by = all_of(by), variables = all_dichotomous(), fmt_fn = digits, @@ -316,11 +321,13 @@ tbl_summary <- function(data, ), # calculate categorical summaries cards::ard_continuous( - data, + select_prep(.list2tb(type, "summary_type"), data), by = all_of(by), variables = all_continuous(), statistic = - .continuous_statistics_chr_to_fun(statistic[select(data, all_continuous()) |> names()]), + .continuous_statistics_chr_to_fun( + statistic[select(select_prep(.list2tb(type, "summary_type"), data), all_continuous()) |> names()] + ), fmt_fn = digits, stat_label = ~ default_stat_labels() ) @@ -409,7 +416,7 @@ tbl_summary <- function(data, ) } -.sort_data_infreq <- function(data, sort, type) { +.sort_data_infreq <- function(data, sort) { # if no frequency sorts requested, just return data frame if (every(sort, function(x) x %in% "alphanumeric")) { return(data) @@ -421,7 +428,7 @@ tbl_summary <- function(data, } } - .add_summary_type_as_attr(data, type) + data } .construct_summary_footnote <- function(card, include, statistic, type) { diff --git a/man/dot-list2tb.Rd b/man/dot-list2tb.Rd new file mode 100644 index 0000000000..6601a72d61 --- /dev/null +++ b/man/dot-list2tb.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/select_helpers.R +\name{.list2tb} +\alias{.list2tb} +\title{Convert Named List to Table Body} +\usage{ +.list2tb(x, colname = caller_arg(x)) +} +\arguments{ +\item{x}{named list} + +\item{colname}{string of column name to assign. Default is \code{caller_arg(x)}} +} +\value{ +\code{.$table_body} data frame +} +\description{ +Many arguments in 'gtsummary' accept named lists. This function converts +a named list to the \code{.$table_body} format expected in \code{select_prep()} +} +\examples{ +type <- list(age = "continuous", response = "dichotomous") +gtsummary:::.list2tb(type, "summary_type") +} +\keyword{internal} diff --git a/man/select_prep.Rd b/man/select_prep.Rd new file mode 100644 index 0000000000..2623363331 --- /dev/null +++ b/man/select_prep.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/select_helpers.R +\name{select_prep} +\alias{select_prep} +\title{Table Body Select Prep} +\usage{ +select_prep(table_body, data = NULL) +} +\arguments{ +\item{table_body}{a data frame from \code{.$table_body}} + +\item{data}{an optional data frame the attributes will be added to} +} +\value{ +a data frame +} +\description{ +This function uses the information in \code{.$table_body} and adds them +as attributes to \code{data} (if passed). Once they've been assigned as +proper gtsummary attributes, gtsummary selectors like \code{all_continuous()} +will work properly. +} +\keyword{internal} From 67fc98e7cf3639053b7fef1f3f9695c297ac97b2 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 10 Mar 2024 20:03:01 -0700 Subject: [PATCH 41/74] rename column summary_type to var_type (#1612) --- R/bridge_summary.R | 2 +- R/select_helpers.R | 12 ++++++------ R/tbl_summary.R | 22 +++++++++++----------- man/dot-list2tb.Rd | 2 +- tests/testthat/_snaps/tbl_summary.md | 26 +++++++++++++------------- tests/testthat/test-tbl_summary.R | 4 ++-- 6 files changed, 34 insertions(+), 34 deletions(-) diff --git a/R/bridge_summary.R b/R/bridge_summary.R index 21db98e00d..fd8ba3f960 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -95,7 +95,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { dplyr::left_join( dplyr::tibble( variable = x$inputs$include, - summary_type = x$inputs$type[.data$variable] |> unlist() |> unname() + var_type = x$inputs$type[.data$variable] |> unlist() |> unname() ), dplyr::bind_rows( pier_summary_continuous( diff --git a/R/select_helpers.R b/R/select_helpers.R index df3d6f955a..3f1e26abcf 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -38,13 +38,13 @@ NULL all_continuous <- function(continuous2 = TRUE) { types <- if (continuous2) c("continuous", "continuous2") else "continuous" - where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% types)) + where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% types)) } #' @rdname select_helpers #' @export all_continuous2 <- function() { - where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% "continuous2")) + where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "continuous2")) } #' @rdname select_helpers @@ -52,13 +52,13 @@ all_continuous2 <- function() { all_categorical <- function(dichotomous = TRUE) { types <- if (dichotomous) c("categorical", "dichotomous") else "categorical" - where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% types)) + where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% types)) } #' @rdname select_helpers #' @export all_dichotomous <- function() { - where(function(x) isTRUE(attr(x, "gtsummary.summary_type") %in% "dichotomous")) + where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "dichotomous")) } # #' @rdname select_helpers @@ -139,7 +139,7 @@ select_prep <- function(table_body, data = NULL) { # if table_body passed, add columns as attr to data if (!is.null(table_body)) { - attr_cols <- intersect(names(table_body), c("summary_type", "test_name")) + attr_cols <- intersect(names(table_body), c("var_type", "test_name")) for (v in attr_cols) { df_attr <- table_body[c("variable", v)] |> unique() |> tidyr::drop_na() for (i in seq_len(nrow(df_attr))) { @@ -166,7 +166,7 @@ select_prep <- function(table_body, data = NULL) { #' @keywords internal #' @examples #' type <- list(age = "continuous", response = "dichotomous") -#' gtsummary:::.list2tb(type, "summary_type") +#' gtsummary:::.list2tb(type, "var_type") .list2tb <- function(x, colname = caller_arg(x)) { enframe(unlist(x), "variable", colname) } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 111fcaa22b..dd5467e6a9 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -195,7 +195,7 @@ tbl_summary <- function(data, default_types <- assign_summary_type(data, include, value) # process the user-passed type argument cards::process_formula_selectors( - data = select_prep(.list2tb(default_types, "summary_type"), data[include]), + data = select_prep(.list2tb(default_types, "var_type"), data[include]), type = type ) # fill in any types not specified by user @@ -205,12 +205,12 @@ tbl_summary <- function(data, } value <- - select_prep(.list2tb(type, "summary_type"), data[include]) |> + select_prep(.list2tb(type, "var_type"), data[include]) |> .assign_default_values(value, type) # evaluate the remaining list-formula arguments ------------------------------ # processed arguments are saved into this env - select_prep(.list2tb(type, "summary_type"), data[include]) |> + select_prep(.list2tb(type, "var_type"), data[include]) |> cards::process_formula_selectors( statistic = .ifelse1( @@ -224,7 +224,7 @@ tbl_summary <- function(data, # add the calling env to the statistics statistic <- .add_env_to_list_elements(statistic, env = caller_env()) - select_prep(.list2tb(type, "summary_type"), data[include]) |> + select_prep(.list2tb(type, "var_type"), data[include]) |> cards::process_formula_selectors( label = label, sort = @@ -235,7 +235,7 @@ tbl_summary <- function(data, ) ) - select_prep(.list2tb(type, "summary_type"), data[include]) |> + select_prep(.list2tb(type, "var_type"), data[include]) |> cards::process_formula_selectors( digits = .ifelse1( @@ -247,7 +247,7 @@ tbl_summary <- function(data, # fill in unspecified variables cards::fill_formula_selectors( - select_prep(.list2tb(type, "summary_type"), data[include]), + select_prep(.list2tb(type, "var_type"), data[include]), statistic = get_theme_element("TODO:fill-this-in", default = eval(formals(gtsummary::tbl_summary)[["statistic"]])), sort = @@ -260,7 +260,7 @@ tbl_summary <- function(data, # TODO: this needs to be updated to account for the scenario where there is a template override that may not fill in all the values if (!missing(digits)) { digits <- - select_prep(.list2tb(type, "summary_type"), data[include]) |> + select_prep(.list2tb(type, "var_type"), data[include]) |> assign_summary_digits(statistic, type, digits = digits) } @@ -302,7 +302,7 @@ tbl_summary <- function(data, }, # tabulate categorical summaries cards::ard_categorical( - select_prep(.list2tb(type, "summary_type"), data), + select_prep(.list2tb(type, "var_type"), data), by = all_of(by), variables = all_categorical(FALSE), fmt_fn = digits, @@ -311,7 +311,7 @@ tbl_summary <- function(data, ), # tabulate dichotomous summaries cards::ard_dichotomous( - select_prep(.list2tb(type, "summary_type"), data), + select_prep(.list2tb(type, "var_type"), data), by = all_of(by), variables = all_dichotomous(), fmt_fn = digits, @@ -321,12 +321,12 @@ tbl_summary <- function(data, ), # calculate categorical summaries cards::ard_continuous( - select_prep(.list2tb(type, "summary_type"), data), + select_prep(.list2tb(type, "var_type"), data), by = all_of(by), variables = all_continuous(), statistic = .continuous_statistics_chr_to_fun( - statistic[select(select_prep(.list2tb(type, "summary_type"), data), all_continuous()) |> names()] + statistic[select(select_prep(.list2tb(type, "var_type"), data), all_continuous()) |> names()] ), fmt_fn = digits, stat_label = ~ default_stat_labels() diff --git a/man/dot-list2tb.Rd b/man/dot-list2tb.Rd index 6601a72d61..e27acd1961 100644 --- a/man/dot-list2tb.Rd +++ b/man/dot-list2tb.Rd @@ -20,6 +20,6 @@ a named list to the \code{.$table_body} format expected in \code{select_prep()} } \examples{ type <- list(age = "continuous", response = "dichotomous") -gtsummary:::.list2tb(type, "summary_type") +gtsummary:::.list2tb(type, "var_type") } \keyword{internal} diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index ea6c8c8a44..16c9bbf33d 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -225,21 +225,21 @@ Code dplyr::select(getElement(tbl_summary(trial, include = c(age, marker, response, stage), type = list(age = "continuous", marker = "continuous2", response = "dichotomous", - state = "categorical"), missing = "no"), "table_body"), variable, - summary_type, row_type, label) + state = "categorical"), missing = "no"), "table_body"), variable, var_type, + row_type, label) Output # A tibble: 9 x 4 - variable summary_type row_type label - - 1 age continuous header Age - 2 marker continuous2 header Marker Level (ng/mL) - 3 marker continuous2 level Median (Q1, Q3) - 4 response dichotomous header Tumor Response - 5 stage categorical header T Stage - 6 stage categorical level T1 - 7 stage categorical level T2 - 8 stage categorical level T3 - 9 stage categorical level T4 + variable var_type row_type label + + 1 age continuous header Age + 2 marker continuous2 header Marker Level (ng/mL) + 3 marker continuous2 level Median (Q1, Q3) + 4 response dichotomous header Tumor Response + 5 stage categorical header T Stage + 6 stage categorical level T1 + 7 stage categorical level T2 + 8 stage categorical level T3 + 9 stage categorical level T4 # tbl_summary(type) proper errors/messages diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index 9051431a1a..57b4b6d4c7 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -203,7 +203,7 @@ test_that("tbl_summary(type)", { missing = "no" ) |> getElement("table_body") |> - dplyr::select(variable, summary_type, row_type, label) + dplyr::select(variable, var_type, row_type, label) ) # can use the default type to select variables to change the summary type @@ -350,7 +350,7 @@ test_that("tbl_summary(value)", { # check all summary types are assigned to dichotomous expect_equal( - tbl$table_body$summary_type |> unique(), + tbl$table_body$var_type |> unique(), "dichotomous" ) From 5a9472677b5df086d5b52ad513ba1231ab839c15 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 17 Apr 2024 16:06:08 +0200 Subject: [PATCH 42/74] init --- R/tbl_summary.R | 41 +++-- R/utils_examples.R | 73 +++++++++ .../html_example_outputs/example_html_tbl.rds | Bin 0 -> 1401 bytes .../html_example_outputs/example_html_tbl.txt | 35 +++++ .../example_tbl_to_write.rds | Bin 0 -> 1401 bytes .../example_tbl_to_write.txt | 35 +++++ inst/html_example_outputs/tbl_summary_ex1.rds | Bin 0 -> 1398 bytes inst/html_example_outputs/tbl_summary_ex2.rds | Bin 0 -> 1524 bytes inst/html_example_outputs/tbl_summary_ex3.rds | Bin 0 -> 1157 bytes man/tbl_summary.Rd | 144 ++++++++++++++++-- man/utils_examples.Rd | 37 +++++ tests/testthat/test-utils_examples.R | 43 ++++++ 12 files changed, 386 insertions(+), 22 deletions(-) create mode 100644 R/utils_examples.R create mode 100644 inst/html_example_outputs/example_html_tbl.rds create mode 100644 inst/html_example_outputs/example_html_tbl.txt create mode 100644 inst/html_example_outputs/example_tbl_to_write.rds create mode 100644 inst/html_example_outputs/example_tbl_to_write.txt create mode 100644 inst/html_example_outputs/tbl_summary_ex1.rds create mode 100644 inst/html_example_outputs/tbl_summary_ex2.rds create mode 100644 inst/html_example_outputs/tbl_summary_ex3.rds create mode 100644 man/utils_examples.Rd create mode 100644 tests/testthat/test-utils_examples.R diff --git a/R/tbl_summary.R b/R/tbl_summary.R index dd5467e6a9..93821ef6d4 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -125,16 +125,22 @@ #' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @author Daniel D. Sjoberg -#' @examples -#' # Example 1 ---------------------------------- -#' tbl_summary_ex1 <- -#' trial |> +#' @section Examples: +#' Basic `tbl_summary` function: +#' ```{r, eval = getOption("gtsummary_update_examples", default = FALSE)} +#' ex1 <- trial |> #' select(age, grade, response) |> #' tbl_summary() +#' ``` +#' \if{html}{\out{ +#' ```{r, echo = FALSE, results = 'asis'} +#' write_and_read_html_output(ex1, "tbl_summary") +#' ``` +#' }} #' -#' # Example 2 ---------------------------------- -#' tbl_summary_ex2 <- -#' trial |> +#' Customizing the `tbl_summary` function: +#' ```{r, eval = getOption("gtsummary_update_examples", default = FALSE)} +#' ex2 <- trial |> #' select(age, grade, response, trt) |> #' tbl_summary( #' by = trt, @@ -142,16 +148,31 @@ #' statistic = list(all_continuous() ~ "{mean} ({sd})"), #' digits = list(age = c(0, 1)) #' ) +#' print(getOption("gtsummary_update_examples")) +#' ``` +#' \if{html}{\out{ +#' ```{r, echo = FALSE, results = 'asis'} +#' write_and_read_html_output(ex2, "tbl_summary") +#' ``` +#' }} #' -#' # Example 3 ---------------------------------- -#' tbl_summary_ex3 <- -#' trial |> +#' Multiple statistics for continuous variables: +#' ```{r, eval = getOption("gtsummary_update_examples", default = FALSE)} +#' ex3 <- trial |> #' select(age, marker) |> #' tbl_summary( #' type = all_continuous() ~ "continuous2", #' statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), #' missing = "no" #' ) +#' ``` +#' +#' \if{html}{\out{ +#' ```{r, echo = FALSE, results = 'asis', eval = TRUE} +#' write_and_read_html_output(ex3, "tbl_summary") +#' ``` +#' }} +#' @md tbl_summary <- function(data, by = NULL, label = NULL, diff --git a/R/utils_examples.R b/R/utils_examples.R new file mode 100644 index 0000000000..0f0ac76e34 --- /dev/null +++ b/R/utils_examples.R @@ -0,0 +1,73 @@ +#' Utilities to write and read tables in html for function documentation +#' +#' This is still experimental. We are planning to potentially expand this to other +#' html output. Principally based on [as_gt()] and [gt::as_raw_html()]. +#' +#' @param tbl +#' +#' +#' @keywords internal +#' @name utils_examples +write_html_output <- function(tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2]) { + folder_name <- system.file("html_example_outputs", package = "gtsummary") + if (isFALSE(method %in% c("txt", "rds"))) { + stop("Inserted method is not supported.") + } + + if (getOption("gtsummary_update_examples", default = FALSE)) { + if (is(tbl, "html")) { + html_output <- tbl + } else if (is(tbl, "gtsummary")) { + html_output <- tbl |> + as_gt() |> + gt::tab_options() |> + gt::as_raw_html() + } else { + stop("tbl needs a html or gtsummary table. Got something else.") + } + fl_nm <- paste0(folder_name, "/", example_name, "_", out_var_name) + if (method == "txt") { + writeLines(text = html_output, con = paste0(fl_nm, ".txt")) + } else if (method == "rds") { + saveRDS(html_output, file = paste0(fl_nm, ".rds")) + } + } +} +#' @keywords internal +#' @name utils_examples +read_html_output <- function(out_var_name, + example_name = "example", + method = c("txt", "rds")[2]) { + folder_name <- system.file("html_example_outputs", package = "gtsummary") + if (isFALSE(method %in% c("txt", "rds"))) { + stop("Inserted method is not supported.") + } + + fl_nm <- paste0( + folder_name, "/", # should we use system.file? + example_name, "_", out_var_name, ".", method + ) + + if (require("htmltools", quietly = TRUE) && file.exists(fl_nm)) { + if (method == "txt") { + out <- readLines(fl_nm) |> + paste0(collapse = "\n") |> + htmltools::HTML() + } else if (method == "rds") { + out <- readRDS(fl_nm) + } + return(out) + } +} +#' @keywords internal +#' @name utils_examples +write_and_read_html_output <- function(tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2]) { + write_html_output(tbl, example_name, out_var_name, method) + read_html_output(out_var_name, example_name, method) +} diff --git a/inst/html_example_outputs/example_html_tbl.rds b/inst/html_example_outputs/example_html_tbl.rds new file mode 100644 index 0000000000000000000000000000000000000000..77a5aacb101992a3744649d24935316a98113fda GIT binary patch literal 1401 zcmV-<1%~<`iwFP!000001MOSgZre5#R@>yFx!NNTDw4E-wOEPUWR`6p=+>t3Aq|We+y&@JF`fDvrFhK;tM*Ve*hXJUZt)AL-`!k3Gw>9$7n& z9$1fdp=s@2e0b%Yf$Rt9Jg}@kA6u6Dq!-XDM1#IPn`a+Gd>Mr^8*wp@NZ(Fz5YS}e zL}V4kv=L*1iwviW zQS+$IjEpX+aK`ZA39lj?MM$pCU!xnnSz&oskek0Kp5!A;mbe_RBEyQuc9ZoVjh85>&3XlDg zMJz+V#OxzIEU2lFyr0J-7D>??P+wZ;A#hL{VX#R#&qE`Y1tfEP7DYJaq>J*Fha#E~ z#{>c;EQ@jEp%`ZqnrJ8>6`owA!C+**+_a0HoTwk;4o*MA2JQ=hf)>nHlXdxNKpTxFO4PTFZ&k|mL`ZOuXNFl{ z+)K@p^Rhxxf}){Z2MNLLHH*JSz`lipS9I2LuzQPxH$;?s8={QkRfwuxk92n$Cw!LUk^lS$G=IyxRI zo}lQtRI_q~q8CM>Cg9RML%>Q_IBHQygMcK)UuIXiyejX}m6{+UC^xl{=_<$!dOFmD zG6;GG0fXL=2>%~4eUgCI|BB5wsE>}@?G;d}IiSFpbMR@(ga><#;n+@?AVWC6F1Z#P z{OZmuq=GoG)F<79&EU4+6%HsWz%{;CM5Y0zUcK0Qn#!iDtF$G}SUtn^9j6!HnpYMO^j`oioBE7*l6_h11s#M-r;fhqiFft%6U9${~ zE5Rb|o~8r0CvgkeEsZTCIkYl$PdHK+1$|{0v0%P>MITDx9li?`?m6o&Lp>27=?Id+ zvqyMDfTWh507_e)y=z=ig7jGxq|Y{hw7#25Mp$v%ZEkk!x%qC;MGVO-KkU>z74u}) z%T~_7^9cdK1KLaB<^qdhyCUBCiPl8?yNvjP(r<`)PT-wW^z`Jcg`S^2Q_;`4uVIDl z$4DJk`1>#Yx=1eJlua6j*qZ3qWeC@8h~b_=qYg3rnn8pcI@p?+*QJBrC>u0{aL>T8 z$xY#PLke3H_qwF;;tW1TboQH%5cdrr8xcdp4BHd$M|(RPFKXt3if9xn;EvY@CeI+1 zK!uW_pJXvuDOo#J$=a!(toB_jTtdH-fP&Fa-?}aI_T*U$LE9XhtMyFsaeyh0RQZx@ z1oUcPSvwEaS0;9>$MC)ria3JzJ^eKb`L8s-tGojZ`8|t=rA4~^*w4!-q4Uqbfefx~ Hs4)NlntPib literal 0 HcmV?d00001 diff --git a/inst/html_example_outputs/example_html_tbl.txt b/inst/html_example_outputs/example_html_tbl.txt new file mode 100644 index 0000000000..679287432b --- /dev/null +++ b/inst/html_example_outputs/example_html_tbl.txt @@ -0,0 +1,35 @@ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
+
diff --git a/inst/html_example_outputs/example_tbl_to_write.rds b/inst/html_example_outputs/example_tbl_to_write.rds new file mode 100644 index 0000000000000000000000000000000000000000..130f30a9fde65f79b4032d6b31ecdedf0d5ed5b2 GIT binary patch literal 1401 zcmV-<1%~<`iwFP!000001MOSgZre5#R-5Fax!NNTDw4E-wOEPsGs`v*bnDiO73fcZ z-5In*+iWCJ73nzc)gEQfvIiS>_#<0#6i41#pm7wZFnLHG9-Z@@k92eV$F5~rTh{j0 z6KiV+n%2(c$Jfp|$bNv%6U+MZnPs`pI|02$H0avFY>3BK(|~-k5f`(NbnOHO0gXpa zNQR=_Om4hPkkZk(C=o1ayLrKY3Be*QW7i}dhHUEGwDCl+MSrIIQyPe|ZjOmkt=e{P z7a{oV2s{W0@f0#50z024I2FtZD3?MfNtsVL2MfCP5Qlte+JG^^MT(R8 zsCiUpN(NU{I71c-het4N3_98f$AaRJVom}NIT8EfFn)7u)+og@?&FYnNDU2fM8jDd z@fjB+awfEa4nB|(Bk1zYK?A*K;2qXLzmf2o2=b-^h1ClyE3qzc6(neX!Lm`cc zV*-IAIsN#P^UtwK~Z0>gM{Grip5_eVBf;QOFAn#*uBTWYa+_M4^hVPDn#Y3N4h(SV&2ye z*w+f>fHcuYDVy>H$6edCWxCGW+-C`d3`Dj%5cWgi0avnkv_BHwt1(WoFMygjFqRxU zTnw&^_cA4{NbEdYG@E;Ou!SHu!T}PG`4A*+MB_1-CBE;_Avp6S)rSroC!@HHbaXtF zKS9xnRI_x1qSL%k6L4XkAz&rT9kpmogMh@wUuIXiye#k0wVEI!C^xl{=_<(dIy%(7 zA_zJL0lm(l82>+H`XmOe{}r2WQ5PLGn@gZnb3lPHXaDnr2@m!f!m%AQLHclhU2!co z_|={1m4GM&~+d zWAHpr9D~qB#^iu$-@@b^8M)A&o$TFqNAt%Pk=|gO3d&*`RVweRa7D^t7#R>3u2}}g zrC^bEPm-S7k+_BImd56i99pTmCmgDag1#~gSTI|@qW7in0pA63_ncLip^gZUbOcG^ z*+V=aKvD}&0HrO?-W9GWK>EB4(&uYHTHnnjBP_Y?J~zA7-25=;B7$U=A9gC9idi!2 zWlLw^#fSjl0quowbAd&_SrYH;M5`nIT}FIP>376DBks zb5nRzlfuTty(%f3p2Mez)?WP);;{i_En=vdVRHgsGeZrKugDBFHEd4gD^o)YsNtxl zhDQgGD%9|C60sD$Cp=*>um7K6bAn%)9o(879wk8Pze+sj=vSqOvjQ)`yDY_+*Hg=K zlalI_)peU|lq8wu#afJlyS`~z=6!XqYew_lLf<>;Xzyp^dCgo<5{+C1+|kOwWErFq zC|5G{lPm@+Bx|cISzFbU)qaSDOXznJP%!$%JGX(}9lvZKXq$s`xt>Wr4lw1RDqoU~ zfL`}3Yx}AC%EY$y4BofLA`0PsSAUH{{ws{{DDOZ+e$V1*VUcb>^RqHa==}39odIlu Hs4)NlIJ%b@ literal 0 HcmV?d00001 diff --git a/inst/html_example_outputs/example_tbl_to_write.txt b/inst/html_example_outputs/example_tbl_to_write.txt new file mode 100644 index 0000000000..46df6e489b --- /dev/null +++ b/inst/html_example_outputs/example_tbl_to_write.txt @@ -0,0 +1,35 @@ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
+
diff --git a/inst/html_example_outputs/tbl_summary_ex1.rds b/inst/html_example_outputs/tbl_summary_ex1.rds new file mode 100644 index 0000000000000000000000000000000000000000..dbe259548aa790fc64841cc085201d2215f45bdc GIT binary patch literal 1398 zcmV-+1&R6}iwFP!000001MOSgZre5#R@?NVz1kxXDw?!_wOIL| zoJWtL={!FF^u{{@*$>cp;5dIiaUB0yH=>t_MyKwO4EO~j@g;MSkh7Sax+#t#%0^yH zhO*O6uYz2V(b2dpkv#4AMZthe$rB^vmn0j;eCl0w@I>-Oe`fkq8p*L~j)_*S+iveE zLh##_cn}j5##o3`cO?6|@1h7x?0uf#OmZ)xLJ7Sz;~^0OEPyA%u~?cm;9Lrs;dDM~ zAJv&h{~QJxugeQ_^6 zOU=s)NePPjY8@nma91q;8Ugzj4qnn(%fbFF4qg*c{%we|j@Kcoc0DrPNy0?mJYe4_ zR0GOH7iD}ZQp`?W-&N^4Z;Ozp5Hb+C`asx@WdK~s*=TztgI8mm;ZOoK31BQWw!0Wy z8SiCESdrL8wrIDX-@q1=YU6xGKb948~zK_)r@DxRR| zP^nouLeWuCXb8A8&l0ef6^>dorcp$g^_SgMEw9RZbg3t(2&zq8WV;$Ny{-v$uMC2& zML@5+E64v2nIU1I^}k~C9XdsO?e-EV^&C)O&Ds7u;WB`|hHz{%E=eEGuM1(s7Qd!5 z9aBj>SQ?TJ<5RdT1cd{NN^ngW6p?9xX;#m-o}{Yj8>>vmw85q(Y3@?e7<8_aHWttG z#IXonWK02=?lnx#kx>Zk@!|99?r8sbK$JJQpptT?qDs|$6|P7H3?mET(lyJ%xDqVN z?n&D7y9&3E-OAWPl0z%g_k>-2Q7~7A0gq7I;hwYVGSrn3QjQ=QJbR1> z1W0P(381va*}K9OB}kuCLHcA3NSnL4VuU5P-R5S$o}2FmT_ljq>cdXWQ!!6wvux=M zJR1=JJfOW4ZXvPkw=3eEpJ+|QzsrcvDgB0+=LCLmj9%=Yw9w)4OC9~3`x;i*e2mm# zg}?tYuXA<*rz~q2Vq>CTmmz$=A%=SfjXK2eO9l~c=wM@FUY8EKgRIvO!aW1WIyZ&4 z4Jm9)-0PCU(FuHtIC$QCgt%`2S&JANX4ss-H_XrgIr??!;kd*L@UBWR=JnL7+@zxV zWOd!<8YM|~dASy&zdKLwb1v5I@;UWcwRFXRYapu0k^j@FnI>)1S*sa z{iKS)O38Xqm8=K#lhwV8g-hr+5>YVv#e2Vn-tWI`A!yr!bGe>LJq|GCt}b6vjfh_M z9B1pH{>sFb^90_v#xjZF{i*pHh5A<-f2_R&4fQ>XhowcP{UprGD53Muzl^R3t*9{o E0QItgU`fhhjerN+pb|4kBps1 z4~$2Tp=mt+_Vt5x3bLord0-fSJTZ*-PrEL?MAYq>Y|edud@;NDZXzz`KIxeec3m2J zmQTi_(}=E|R1i~dl9vb;b?mHQ$b?{lma$6`k9{_?t~z)s*s?#@{TX$|L^mfysa9>X zzl#w3>k2&d2^#sB^PcI6f$E#c#R6LwQydFsxs*$x6~$~sIENMV%rW-)%4I{w1Q#)m z7Ng0dS~D^{r@|VuP*^;G%O;?sgK#J)_9^DXb&wUX?-t`%*RJwnJm(|q69=iGF%GCd z?;t+sf&|u-9-tRrh{p)}_VL95`pm#O>;U~t{7WL}2p^!c7;bZbI1ahRNleEu<1C8c zvEMSE#pr#&ey1-oY6>J@=E0EpQuGPb=O#J`3>5ho)})N*pdpK05?dqY`#9pHgVL6R zd>Rrf0Rn|A4zTZ_0LLB;H5HJ8ClzTjB(jmbX$L)Psh`9goPLKJ*vCKxEtst+*H=j- zma-upoqI8xhOU(={h)pvr1_HEF?kRmV5)&LpSrn$WI|IeAR|uoo}J3qVn{vEaycPc z87a`F2U30STJp6R)UHsxx@4?CWioQZ8YK>eOH=~|>XdwCfhHPyO4KtG+bWmqiV4AP z>KV!W?7h@g^13+Vl%QxJ=Yd0TbIs)c1F#=q;1!*v3~b+G;0+mN-^QrK@Cu@0(<9xT z1|c8l2OMaHazHN8L@}H32!}n>Hl@2R+I++!fDA;YN(j$=;Xtfpq4(Sq&f5u&@kl^u z;t;Xq*x_<;E#9jkVU1&FqeY{!cSE!gVBRC-Gl-C?xC3cH)f7V2wMLwH{Zom51p-WQg(+iI#lgvcEkCEdg%43nh9!? zMLxfnGU31q#*oZICddG?+Bw(agw?t;n@~Y4m^vbzkj-EZ;bhVl6=1NDljUndS3Nsj z5uZk~Y3s%6j&8%6YFD~XuB17;i8CcEU$~Rz?b3~gaer5{w40%*d5xV5j$}YSIoi8! zn8vF%k#=F63d%x>FO~aQ*g|F4j1oHMwqXgO3uz;tU>f!9u4FKHzg+Cy2m)`)1OdCz ztfN331@2T7cym1p08Q_87=Tu+juVIKJfTk(L*~v`Px1pPyvIj|%yDSlnW-yWBn?4g zcy=ET352nwB_QZ6x9Dq3kz@C15xY+}V7ETP%iyqLw%g2XmoxMIh#UdA}vlNbK_Q@_52=djNT>)fz4=$DNTCv{G!9Omsh7gUTHWpcq! zF(6!LfUUv2Y&4J`?bJ!2y0F)IpgQE(fw6U@`hkc*H_p|9`^vfL}H`G*8if^L3pVDhRzw4DC8GRE{9^-x^gJ z{nFu~P6?I6JpZ>w@Gi?L7GI$tOGgSSN!FKYZ%}EJOwZR<9%pTWkAo zD4oAO11~D%+yXQ*^=_@Tz@#3e94J%%^IFz;<(#!$iF_`0&1~zcWSt=Eff@yFf#J asmjCLB;9^8N^7Q}^Y=gde!(M^MF0R6#O)FQ literal 0 HcmV?d00001 diff --git a/inst/html_example_outputs/tbl_summary_ex3.rds b/inst/html_example_outputs/tbl_summary_ex3.rds new file mode 100644 index 0000000000000000000000000000000000000000..a21792fdfeaf7fb776d7c553966b890740ddcf06 GIT binary patch literal 1157 zcmV;01bX`)iwFP!000001MOPfZre5#R-5D^x!NNfXj_v4QewwxVpz6;pj)v4O@Xc} zuseg2XqgKoswC~$z3QX%A@&4&uwnd>{5K_Wwhm|#SqVg*LmpD+eCIn7q~G=&$JuhW zx1Km#JF4mIy#Mu;-&V43ROgA~eA;!K@BZk0~PD#04Q|6!+X5#WBee zpW>nHH1cUs3OGqds}jlbPIFlhGAUVVWo&}^kg_X(+CgK<7X6v+Uy)djY;%N-Y14N5 zdjRUMD^W->L=*|pa}zl*eHUURk^f=UPDf{R%G5yD=grk{=5XAu))exnG&N?7w zLgLgP6A$*^;e=s$|MR{FzcA$;=D|;xPOu~q^5C4SWjqil6TZNl4AqSDJXe?fl2OLt z$CUj}_Lt05NZ!rTkWnpqqs*^N3_v+3r%3I|I4^*Z@fdSIVw9p>;0~0n04T|@Ujza& z##2NCND)s+W}yHkJf+Bjp^!y-(GGmuGQYwdf_zj9G*1;2tl(QsyM!vQ|7sAAddT!xclX6`-!YD2?qnN+EmKmkT z@uj3xh6Z|`N(kZJF!@Ua?Ei4^n$3+I+`PrXcSKb4HbfPUHzBHaJ=pFz&BVZ7;J_Nx z3cW=aIJ*)#%6e|o)#*BKi-_eaWJ=_kg7A#WKyf9@l4pqwUXBn)kyO+q6k}=K(L#A+ zyw@q=hQwZGi$>%7YuG~Ksq__zXJV)%9U$3AZA*ULp#xR(G}TjIm6IgvfQ?Q7%M}z} zXftai6i%0gmVj5r6$ET#OQjY@B#v=b_^Vh|Pp`^*n3w@Nf_hOGimri7ziUI?Uj;$8 zKtR8HBuD=ZnGw#E)qji4H_(IQMxzGhJq4wW{#{^M;AIZX0s$3>R4s0b+L5Vhw!Vcd zo~_?c4z%zd7p|qEd{gD_${4gGFjv=3QHWJWEj*#}Z&4_2aK#Ef+Ew^y-vJ-?MpCEO zn%i!3b8|B{-;dl&Rc7cr^9?Dy%nUnijj+!XtN^djz7lRBksLHC;$6~j9r3R+;&Xny zCgyWC40+##y(GPw4jw)@Hlc$*KilI1#{^|?@V4o}+t%}%A|4D1Hl>J@GdO6qJ$P~U zyk?3=hLJll1<5?PK+~Ec9!&T*rHE4x+O3)#9vM0|A%_dZFENMLc!DV$WXVzby1s{a zI1s2GGiq?uj~O)zz5qou4o^?upmBJ7>_PMJq**^~JT|1%4;zm<{F@U+qv1j8uzj|| z5bCU7#}pp`?WwMQMWe8B6q8BcakihDZ +\section{Examples}{ + +Basic \code{tbl_summary} function: + +\if{html}{\out{
}}\preformatted{ex1 <- trial |> select(age, grade, response) |> tbl_summary() +}\if{html}{\out{
}} + +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
+
+}} + +Customizing the `tbl_summary` function: -# Example 2 ---------------------------------- -tbl_summary_ex2 <- - trial |> +\if{html}{\out{
}}\preformatted{ex2 <- trial |> select(age, grade, response, trt) |> tbl_summary( by = trt, label = list(age = "Patient Age"), - statistic = list(all_continuous() ~ "{mean} ({sd})"), + statistic = list(all_continuous() ~ "\{mean\} (\{sd\})"), digits = list(age = c(0, 1)) ) + print(getOption("gtsummary_update_examples")) +}\if{html}{\out{
}} -# Example 3 ---------------------------------- -tbl_summary_ex3 <- - trial |> +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicDrug A
+N = 981		Drug B
+N = 1021
Patient Age47 (14.7)47 (14.0)
    Unknown74
Grade

    I35 (36%)33 (32%)
    II32 (33%)36 (35%)
    III31 (32%)33 (32%)
Tumor Response28 (29%)33 (34%)
    Unknown34
1 Mean (SD), n (%)
+
+}} + +Multiple statistics for continuous variables: + +\if{html}{\out{
}}\preformatted{ex3 <- trial |> select(age, marker) |> tbl_summary( type = all_continuous() ~ "continuous2", - statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min}, {max}"), + statistic = all_continuous() ~ c("\{median\} (\{p25\}, \{p75\})", "\{min\}, \{max\}"), missing = "no" ) +}\if{html}{\out{
}} + +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 200
Age
    Median (Q1, Q3)47 (38, 57)
    Min, Max6, 83
Marker Level (ng/mL)
    Median (Q1, Q3)0.64 (0.22, 1.41)
    Min, Max0.00, 3.87
+
+}} } + \seealso{ See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tbl_summary vignette} for detailed tutorial diff --git a/man/utils_examples.Rd b/man/utils_examples.Rd new file mode 100644 index 0000000000..da126e1361 --- /dev/null +++ b/man/utils_examples.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_examples.R +\name{utils_examples} +\alias{utils_examples} +\alias{write_html_output} +\alias{read_html_output} +\alias{write_and_read_html_output} +\title{Utilities to write and read tables in html for function documentation} +\usage{ +write_html_output( + tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2] +) + +read_html_output( + out_var_name, + example_name = "example", + method = c("txt", "rds")[2] +) + +write_and_read_html_output( + tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2] +) +} +\arguments{ +\item{tbl}{} +} +\description{ +This is still experimental. We are planning to potentially expand this to other +html output. Principally based on \code{\link[=as_gt]{as_gt()}} and \code{\link[gt:as_raw_html]{gt::as_raw_html()}}. +} +\keyword{internal} diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R new file mode 100644 index 0000000000..f4394a9a53 --- /dev/null +++ b/tests/testthat/test-utils_examples.R @@ -0,0 +1,43 @@ +test_that("writing and reading examples work", { + skip_if_not_installed("htmltools") + options(gtsummary_update_examples = TRUE) + tbl_to_write <- trial |> + select(age, grade, response) |> + tbl_summary() + + # Direct html + html_tbl <- tbl_to_write |> + as_gt() |> + gt::tab_options() |> + gt::as_raw_html() + write_html_output(html_tbl) + read_html_tbl <- read_html_output("html_tbl") + expect_equal(html_tbl, read_html_tbl) + + # txt + write_html_output(html_tbl, method = "txt") + read_html_tbl <- read_html_output("html_tbl", method = "txt") + expect_equal(html_tbl, read_html_tbl) + + # One function + html_output2 <- write_and_read_html_output(html_tbl) + expect_equal(html_tbl, html_output2) + expect_error(write_html_output(html_tbl, method = "sdads")) + expect_error(read_html_output("html_tbl", method = "sdads")) + + # Starting from tbl (common behavior) + write_html_output(tbl_to_write) + read_html_tbl <- read_html_output("tbl_to_write") + html_tbl2 <- strsplit(as.character(html_tbl), "\n")[[1]] + read_html_tbl2 <- strsplit(as.character(read_html_tbl), "\n")[[1]] + html_tbl2[1] <- paste0('
Date: Wed, 17 Apr 2024 16:06:50 +0200 Subject: [PATCH 43/74] cleaning --- .../html_example_outputs/example_html_tbl.rds | Bin 1401 -> 0 bytes .../html_example_outputs/example_html_tbl.txt | 35 ------------------ .../example_tbl_to_write.rds | Bin 1401 -> 0 bytes .../example_tbl_to_write.txt | 35 ------------------ 4 files changed, 70 deletions(-) delete mode 100644 inst/html_example_outputs/example_html_tbl.rds delete mode 100644 inst/html_example_outputs/example_html_tbl.txt delete mode 100644 inst/html_example_outputs/example_tbl_to_write.rds delete mode 100644 inst/html_example_outputs/example_tbl_to_write.txt diff --git a/inst/html_example_outputs/example_html_tbl.rds b/inst/html_example_outputs/example_html_tbl.rds deleted file mode 100644 index 77a5aacb101992a3744649d24935316a98113fda..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1401 zcmV-<1%~<`iwFP!000001MOSgZre5#R@>yFx!NNTDw4E-wOEPUWR`6p=+>t3Aq|We+y&@JF`fDvrFhK;tM*Ve*hXJUZt)AL-`!k3Gw>9$7n& z9$1fdp=s@2e0b%Yf$Rt9Jg}@kA6u6Dq!-XDM1#IPn`a+Gd>Mr^8*wp@NZ(Fz5YS}e zL}V4kv=L*1iwviW zQS+$IjEpX+aK`ZA39lj?MM$pCU!xnnSz&oskek0Kp5!A;mbe_RBEyQuc9ZoVjh85>&3XlDg zMJz+V#OxzIEU2lFyr0J-7D>??P+wZ;A#hL{VX#R#&qE`Y1tfEP7DYJaq>J*Fha#E~ z#{>c;EQ@jEp%`ZqnrJ8>6`owA!C+**+_a0HoTwk;4o*MA2JQ=hf)>nHlXdxNKpTxFO4PTFZ&k|mL`ZOuXNFl{ z+)K@p^Rhxxf}){Z2MNLLHH*JSz`lipS9I2LuzQPxH$;?s8={QkRfwuxk92n$Cw!LUk^lS$G=IyxRI zo}lQtRI_q~q8CM>Cg9RML%>Q_IBHQygMcK)UuIXiyejX}m6{+UC^xl{=_<$!dOFmD zG6;GG0fXL=2>%~4eUgCI|BB5wsE>}@?G;d}IiSFpbMR@(ga><#;n+@?AVWC6F1Z#P z{OZmuq=GoG)F<79&EU4+6%HsWz%{;CM5Y0zUcK0Qn#!iDtF$G}SUtn^9j6!HnpYMO^j`oioBE7*l6_h11s#M-r;fhqiFft%6U9${~ zE5Rb|o~8r0CvgkeEsZTCIkYl$PdHK+1$|{0v0%P>MITDx9li?`?m6o&Lp>27=?Id+ zvqyMDfTWh507_e)y=z=ig7jGxq|Y{hw7#25Mp$v%ZEkk!x%qC;MGVO-KkU>z74u}) z%T~_7^9cdK1KLaB<^qdhyCUBCiPl8?yNvjP(r<`)PT-wW^z`Jcg`S^2Q_;`4uVIDl z$4DJk`1>#Yx=1eJlua6j*qZ3qWeC@8h~b_=qYg3rnn8pcI@p?+*QJBrC>u0{aL>T8 z$xY#PLke3H_qwF;;tW1TboQH%5cdrr8xcdp4BHd$M|(RPFKXt3if9xn;EvY@CeI+1 zK!uW_pJXvuDOo#J$=a!(toB_jTtdH-fP&Fa-?}aI_T*U$LE9XhtMyFsaeyh0RQZx@ z1oUcPSvwEaS0;9>$MC)ria3JzJ^eKb`L8s-tGojZ`8|t=rA4~^*w4!-q4Uqbfefx~ Hs4)NlntPib diff --git a/inst/html_example_outputs/example_html_tbl.txt b/inst/html_example_outputs/example_html_tbl.txt deleted file mode 100644 index 679287432b..0000000000 --- a/inst/html_example_outputs/example_html_tbl.txt +++ /dev/null @@ -1,35 +0,0 @@ -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
-
diff --git a/inst/html_example_outputs/example_tbl_to_write.rds b/inst/html_example_outputs/example_tbl_to_write.rds deleted file mode 100644 index 130f30a9fde65f79b4032d6b31ecdedf0d5ed5b2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1401 zcmV-<1%~<`iwFP!000001MOSgZre5#R-5Fax!NNTDw4E-wOEPsGs`v*bnDiO73fcZ z-5In*+iWCJ73nzc)gEQfvIiS>_#<0#6i41#pm7wZFnLHG9-Z@@k92eV$F5~rTh{j0 z6KiV+n%2(c$Jfp|$bNv%6U+MZnPs`pI|02$H0avFY>3BK(|~-k5f`(NbnOHO0gXpa zNQR=_Om4hPkkZk(C=o1ayLrKY3Be*QW7i}dhHUEGwDCl+MSrIIQyPe|ZjOmkt=e{P z7a{oV2s{W0@f0#50z024I2FtZD3?MfNtsVL2MfCP5Qlte+JG^^MT(R8 zsCiUpN(NU{I71c-het4N3_98f$AaRJVom}NIT8EfFn)7u)+og@?&FYnNDU2fM8jDd z@fjB+awfEa4nB|(Bk1zYK?A*K;2qXLzmf2o2=b-^h1ClyE3qzc6(neX!Lm`cc zV*-IAIsN#P^UtwK~Z0>gM{Grip5_eVBf;QOFAn#*uBTWYa+_M4^hVPDn#Y3N4h(SV&2ye z*w+f>fHcuYDVy>H$6edCWxCGW+-C`d3`Dj%5cWgi0avnkv_BHwt1(WoFMygjFqRxU zTnw&^_cA4{NbEdYG@E;Ou!SHu!T}PG`4A*+MB_1-CBE;_Avp6S)rSroC!@HHbaXtF zKS9xnRI_x1qSL%k6L4XkAz&rT9kpmogMh@wUuIXiye#k0wVEI!C^xl{=_<(dIy%(7 zA_zJL0lm(l82>+H`XmOe{}r2WQ5PLGn@gZnb3lPHXaDnr2@m!f!m%AQLHclhU2!co z_|={1m4GM&~+d zWAHpr9D~qB#^iu$-@@b^8M)A&o$TFqNAt%Pk=|gO3d&*`RVweRa7D^t7#R>3u2}}g zrC^bEPm-S7k+_BImd56i99pTmCmgDag1#~gSTI|@qW7in0pA63_ncLip^gZUbOcG^ z*+V=aKvD}&0HrO?-W9GWK>EB4(&uYHTHnnjBP_Y?J~zA7-25=;B7$U=A9gC9idi!2 zWlLw^#fSjl0quowbAd&_SrYH;M5`nIT}FIP>376DBks zb5nRzlfuTty(%f3p2Mez)?WP);;{i_En=vdVRHgsGeZrKugDBFHEd4gD^o)YsNtxl zhDQgGD%9|C60sD$Cp=*>um7K6bAn%)9o(879wk8Pze+sj=vSqOvjQ)`yDY_+*Hg=K zlalI_)peU|lq8wu#afJlyS`~z=6!XqYew_lLf<>;Xzyp^dCgo<5{+C1+|kOwWErFq zC|5G{lPm@+Bx|cISzFbU)qaSDOXznJP%!$%JGX(}9lvZKXq$s`xt>Wr4lw1RDqoU~ zfL`}3Yx}AC%EY$y4BofLA`0PsSAUH{{ws{{DDOZ+e$V1*VUcb>^RqHa==}39odIlu Hs4)NlIJ%b@ diff --git a/inst/html_example_outputs/example_tbl_to_write.txt b/inst/html_example_outputs/example_tbl_to_write.txt deleted file mode 100644 index 46df6e489b..0000000000 --- a/inst/html_example_outputs/example_tbl_to_write.txt +++ /dev/null @@ -1,35 +0,0 @@ -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
-
From 51000fb39c597a7a2a89c594b11bae500d798ece Mon Sep 17 00:00:00 2001 From: Melkiades Date: Thu, 18 Apr 2024 12:45:51 +0200 Subject: [PATCH 44/74] rework paths --- R/tbl_summary.R | 6 +- R/utils_examples.R | 54 +++++---- inst/example_outputs/example_html_tbl.rds | Bin 0 -> 1399 bytes inst/example_outputs/example_html_tbl.txt | 35 ++++++ inst/example_outputs/example_tbl_to_write.rds | Bin 0 -> 1400 bytes inst/html_example_outputs/tbl_summary_ex1.rds | Bin 1398 -> 0 bytes inst/html_example_outputs/tbl_summary_ex2.rds | Bin 1524 -> 0 bytes inst/html_example_outputs/tbl_summary_ex3.rds | Bin 1157 -> 0 bytes man/tbl_summary.Rd | 113 +----------------- man/utils_examples.Rd | 24 ++-- tests/testthat/test-utils_examples.R | 20 ++-- 11 files changed, 103 insertions(+), 149 deletions(-) create mode 100644 inst/example_outputs/example_html_tbl.rds create mode 100644 inst/example_outputs/example_html_tbl.txt create mode 100644 inst/example_outputs/example_tbl_to_write.rds delete mode 100644 inst/html_example_outputs/tbl_summary_ex1.rds delete mode 100644 inst/html_example_outputs/tbl_summary_ex2.rds delete mode 100644 inst/html_example_outputs/tbl_summary_ex3.rds diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 93821ef6d4..7be558495e 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -134,7 +134,7 @@ #' ``` #' \if{html}{\out{ #' ```{r, echo = FALSE, results = 'asis'} -#' write_and_read_html_output(ex1, "tbl_summary") +#' write_read_example_output(ex1, "tbl_summary") #' ``` #' }} #' @@ -152,7 +152,7 @@ #' ``` #' \if{html}{\out{ #' ```{r, echo = FALSE, results = 'asis'} -#' write_and_read_html_output(ex2, "tbl_summary") +#' write_read_example_output(ex2, "tbl_summary") #' ``` #' }} #' @@ -169,7 +169,7 @@ #' #' \if{html}{\out{ #' ```{r, echo = FALSE, results = 'asis', eval = TRUE} -#' write_and_read_html_output(ex3, "tbl_summary") +#' write_read_example_output(ex3, "tbl_summary") #' ``` #' }} #' @md diff --git a/R/utils_examples.R b/R/utils_examples.R index 0f0ac76e34..b0fd8c631f 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -3,21 +3,31 @@ #' This is still experimental. We are planning to potentially expand this to other #' html output. Principally based on [as_gt()] and [gt::as_raw_html()]. #' -#' @param tbl -#' +#' @param tbl (`gtsummary` or `html`)\cr tables are converted to html. Any html code (table or not) +#' can be saved and retrieved for documentation purposes. +#' @param example_name (`string`)\cr usually the name of the function or file where the +#' table is used. +#' @param out_var_name (`string`)\cr the name of the variable that will be saved. It defaults +#' to the name of the variable passed to the function (`tbl`). +#' @param method (`string`)\cr saving method. Default is `"rds"` as it produces a smaller file, +#' but we are planning to extend this to other, non-html outputs like `"png"`. #' #' @keywords internal #' @name utils_examples -write_html_output <- function(tbl, - example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2]) { - folder_name <- system.file("html_example_outputs", package = "gtsummary") +write_example_output <- function(tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2]) { if (isFALSE(method %in% c("txt", "rds"))) { stop("Inserted method is not supported.") } if (getOption("gtsummary_update_examples", default = FALSE)) { + folder_name <- file.path( + sub("(^.*/gtsummary).*", "\\1", getwd()), + "inst", + "example_outputs" + ) if (is(tbl, "html")) { html_output <- tbl } else if (is(tbl, "gtsummary")) { @@ -38,17 +48,21 @@ write_html_output <- function(tbl, } #' @keywords internal #' @name utils_examples -read_html_output <- function(out_var_name, - example_name = "example", - method = c("txt", "rds")[2]) { - folder_name <- system.file("html_example_outputs", package = "gtsummary") +read_example_output <- function(out_var_name, + example_name = "example", + method = c("txt", "rds")[2]) { + folder_name <- file.path( + sub("(^.*/gtsummary).*", "\\1", getwd()), + "inst", + "example_outputs" + ) if (isFALSE(method %in% c("txt", "rds"))) { stop("Inserted method is not supported.") } - fl_nm <- paste0( - folder_name, "/", # should we use system.file? - example_name, "_", out_var_name, ".", method + fl_nm <- file.path( + folder_name, + paste0(example_name, "_", out_var_name, ".", method) ) if (require("htmltools", quietly = TRUE) && file.exists(fl_nm)) { @@ -64,10 +78,10 @@ read_html_output <- function(out_var_name, } #' @keywords internal #' @name utils_examples -write_and_read_html_output <- function(tbl, - example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2]) { - write_html_output(tbl, example_name, out_var_name, method) - read_html_output(out_var_name, example_name, method) +write_read_example_output <- function(tbl, + example_name = "example", + out_var_name = deparse(substitute(tbl)), + method = c("txt", "rds")[2]) { + write_example_output(tbl, example_name, out_var_name, method) + read_example_output(out_var_name, example_name, method) } diff --git a/inst/example_outputs/example_html_tbl.rds b/inst/example_outputs/example_html_tbl.rds new file mode 100644 index 0000000000000000000000000000000000000000..957e30b43c3b282d15974deb955ad62c987fd620 GIT binary patch literal 1399 zcmV--1&I0|iwFP!000001MOSgZre5#R-5Fax!NNTDw4E-wOIL|NzBr8E-J3N?@r3(0Bpy;jeH_tn(n5T~ z1&N#yZJ>jXWWWfzetXbB9~gLtHPEjlyd{GAxPh)x*rtIvj=950O8c;QqJ>GkEH=g9iN3EPB>|ytmUDQ#>6p! zKru@r9C|3i>43%>3P^<~6KOCQnJ+hOq36fy$GC&jFR+1o22jv~@tkr!OGaWQ>tX+9 zkg`!6IGNHn>c>MGFJ?#cAOOHj17{%(3Ik@rku)GD&h%bg$k%j8JxwaS*9Auec*5~(9 zv*f%qmz1EWE7w6naC^bxuMx0s;ov!)l^pCYaqxI9`RQ-1SIzM^VhX`T@II zp&XDV+9+jXp5XY>c5Rui(>C{60wDvDtqz3!P)gj@y>Fh3uBb=8_y*sk$c|s*8fYGW1w5nZKfUrSK8o1#rVxAHB$vJv)e9=Is=PyTb8MIQ)HSj_AHXIP)$S7rydW`~UgNc~rdO^$w5dN?oe0=&yojA=c!EH^2s zK3QD1xk5>jSzfHgD7fpJmSrxhdtEV_OACD;sH0uZ#?zX)pd=c(3b><%fypvRB~Y$p z=qFhWR!G*9vSdA}o~-s`EL=jrk${5HFW$Qi^#1r|13}vyob&Ze@^OGE4^{b+Yy|YS zV_Dlz)mJ9At!MDQJrq$0@4NbI6!KqTd`Ec)8uEJ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
+
diff --git a/inst/example_outputs/example_tbl_to_write.rds b/inst/example_outputs/example_tbl_to_write.rds new file mode 100644 index 0000000000000000000000000000000000000000..bba029ed77c85a2b0153c379c988c6206e146fc4 GIT binary patch literal 1400 zcmV-;1&8_{iwFP!000001MOSgZre5#R-5D^x!NNTDw4E-wOIL|Wg7_Eb?e0n^e4dX z3|gXXE|RE2Oq(2$rF>RpzPh`jlx_r0aKpz=+hc(czB)leq`nZ8EQrM<}IF7l)NlFK>;vz}lv0t;0 zrRe8~{XzG0YDy%Zrcs}TQuH3w7Z!R59F&9@Y*NniP@km%NgbbsAx=1Hp{(VhkjBI@ zfj}`!BOH1t!s(F48VX2-ClhHf7@03OZJ`%O>c_Z)(_7fUJq0Le!DKGcs6SMqj%|FaQm!pV1P57WnDzO+ z)GRqK%_Su$>dAGG5Zqp}_-h30TR3<@XC()_4>)*5M7a+k$~azysND5PcgIo8d-?%; zTA>_}CfX=v6Q1C>W4pFY*IAqUEP;@L$W{l!UMM`^N)`|IhQfP2!YTFzP!k8nl4A$+ z!KLwDq=Y4joo9O}XP%_`(1GJ*7`Kp)j)(Fm zC_0g97LHJKnipyUF3d9otYo>P7L8~Skl6Uk>?)U+lUB?oa9i+l2NV_H8sEz!(*RSio^3r&WYg7F>5guLO?A>drlis6TqSJ` zo@a?;5IWD895C%Wn4BRa7uvIv-Mj8+{&-BJHyEdavRFoy%KIu@k#ZPD2E>JHmVt38 zSft(Kr0cdNZXvs+vAHCNR;um^2kN4ruMB+_Oc$@{Jt=&|cY)kJXW3<_EdnGRK~i}3 z5cdg?)Z7z5Y4fvpi7N__J}-mx`3jKMcXP=I3vPSJ&2BX}KMuNxAerTdorWF`r5uZ`|Ju%M+{P+yLJUVZnle1SU`Wg4ttg!wV zslp0>|D|7-@fDo1am^5G6aA_T;kq?3JTYigA%o!*?NixfewHO6=ebchchw5HejOK%dzW3D8KFr3mnz^7P8o3I%!=-`AGDsy* zu4L#ZSqxT4*5k5dJ+7Xt_G2tuLcfuKg3&KOxDE8-=v4zj+Z>#W^-S_{fGH1D`I2k| z^tx+Vo6pr(CN`~Yc;6g}D1`SN{WS{tuQ0x)yaNsSJ&WgsMY_H1XJwSo`R8Ak8P&w7 GF#rItvX#I9 literal 0 HcmV?d00001 diff --git a/inst/html_example_outputs/tbl_summary_ex1.rds b/inst/html_example_outputs/tbl_summary_ex1.rds deleted file mode 100644 index dbe259548aa790fc64841cc085201d2215f45bdc..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1398 zcmV-+1&R6}iwFP!000001MOSgZre5#R@?NVz1kxXDw?!_wOIL| zoJWtL={!FF^u{{@*$>cp;5dIiaUB0yH=>t_MyKwO4EO~j@g;MSkh7Sax+#t#%0^yH zhO*O6uYz2V(b2dpkv#4AMZthe$rB^vmn0j;eCl0w@I>-Oe`fkq8p*L~j)_*S+iveE zLh##_cn}j5##o3`cO?6|@1h7x?0uf#OmZ)xLJ7Sz;~^0OEPyA%u~?cm;9Lrs;dDM~ zAJv&h{~QJxugeQ_^6 zOU=s)NePPjY8@nma91q;8Ugzj4qnn(%fbFF4qg*c{%we|j@Kcoc0DrPNy0?mJYe4_ zR0GOH7iD}ZQp`?W-&N^4Z;Ozp5Hb+C`asx@WdK~s*=TztgI8mm;ZOoK31BQWw!0Wy z8SiCESdrL8wrIDX-@q1=YU6xGKb948~zK_)r@DxRR| zP^nouLeWuCXb8A8&l0ef6^>dorcp$g^_SgMEw9RZbg3t(2&zq8WV;$Ny{-v$uMC2& zML@5+E64v2nIU1I^}k~C9XdsO?e-EV^&C)O&Ds7u;WB`|hHz{%E=eEGuM1(s7Qd!5 z9aBj>SQ?TJ<5RdT1cd{NN^ngW6p?9xX;#m-o}{Yj8>>vmw85q(Y3@?e7<8_aHWttG z#IXonWK02=?lnx#kx>Zk@!|99?r8sbK$JJQpptT?qDs|$6|P7H3?mET(lyJ%xDqVN z?n&D7y9&3E-OAWPl0z%g_k>-2Q7~7A0gq7I;hwYVGSrn3QjQ=QJbR1> z1W0P(381va*}K9OB}kuCLHcA3NSnL4VuU5P-R5S$o}2FmT_ljq>cdXWQ!!6wvux=M zJR1=JJfOW4ZXvPkw=3eEpJ+|QzsrcvDgB0+=LCLmj9%=Yw9w)4OC9~3`x;i*e2mm# zg}?tYuXA<*rz~q2Vq>CTmmz$=A%=SfjXK2eO9l~c=wM@FUY8EKgRIvO!aW1WIyZ&4 z4Jm9)-0PCU(FuHtIC$QCgt%`2S&JANX4ss-H_XrgIr??!;kd*L@UBWR=JnL7+@zxV zWOd!<8YM|~dASy&zdKLwb1v5I@;UWcwRFXRYapu0k^j@FnI>)1S*sa z{iKS)O38Xqm8=K#lhwV8g-hr+5>YVv#e2Vn-tWI`A!yr!bGe>LJq|GCt}b6vjfh_M z9B1pH{>sFb^90_v#xjZF{i*pHh5A<-f2_R&4fQ>XhowcP{UprGD53Muzl^R3t*9{o E0QItgU`fhhjerN+pb|4kBps1 z4~$2Tp=mt+_Vt5x3bLord0-fSJTZ*-PrEL?MAYq>Y|edud@;NDZXzz`KIxeec3m2J zmQTi_(}=E|R1i~dl9vb;b?mHQ$b?{lma$6`k9{_?t~z)s*s?#@{TX$|L^mfysa9>X zzl#w3>k2&d2^#sB^PcI6f$E#c#R6LwQydFsxs*$x6~$~sIENMV%rW-)%4I{w1Q#)m z7Ng0dS~D^{r@|VuP*^;G%O;?sgK#J)_9^DXb&wUX?-t`%*RJwnJm(|q69=iGF%GCd z?;t+sf&|u-9-tRrh{p)}_VL95`pm#O>;U~t{7WL}2p^!c7;bZbI1ahRNleEu<1C8c zvEMSE#pr#&ey1-oY6>J@=E0EpQuGPb=O#J`3>5ho)})N*pdpK05?dqY`#9pHgVL6R zd>Rrf0Rn|A4zTZ_0LLB;H5HJ8ClzTjB(jmbX$L)Psh`9goPLKJ*vCKxEtst+*H=j- zma-upoqI8xhOU(={h)pvr1_HEF?kRmV5)&LpSrn$WI|IeAR|uoo}J3qVn{vEaycPc z87a`F2U30STJp6R)UHsxx@4?CWioQZ8YK>eOH=~|>XdwCfhHPyO4KtG+bWmqiV4AP z>KV!W?7h@g^13+Vl%QxJ=Yd0TbIs)c1F#=q;1!*v3~b+G;0+mN-^QrK@Cu@0(<9xT z1|c8l2OMaHazHN8L@}H32!}n>Hl@2R+I++!fDA;YN(j$=;Xtfpq4(Sq&f5u&@kl^u z;t;Xq*x_<;E#9jkVU1&FqeY{!cSE!gVBRC-Gl-C?xC3cH)f7V2wMLwH{Zom51p-WQg(+iI#lgvcEkCEdg%43nh9!? zMLxfnGU31q#*oZICddG?+Bw(agw?t;n@~Y4m^vbzkj-EZ;bhVl6=1NDljUndS3Nsj z5uZk~Y3s%6j&8%6YFD~XuB17;i8CcEU$~Rz?b3~gaer5{w40%*d5xV5j$}YSIoi8! zn8vF%k#=F63d%x>FO~aQ*g|F4j1oHMwqXgO3uz;tU>f!9u4FKHzg+Cy2m)`)1OdCz ztfN331@2T7cym1p08Q_87=Tu+juVIKJfTk(L*~v`Px1pPyvIj|%yDSlnW-yWBn?4g zcy=ET352nwB_QZ6x9Dq3kz@C15xY+}V7ETP%iyqLw%g2XmoxMIh#UdA}vlNbK_Q@_52=djNT>)fz4=$DNTCv{G!9Omsh7gUTHWpcq! zF(6!LfUUv2Y&4J`?bJ!2y0F)IpgQE(fw6U@`hkc*H_p|9`^vfL}H`G*8if^L3pVDhRzw4DC8GRE{9^-x^gJ z{nFu~P6?I6JpZ>w@Gi?L7GI$tOGgSSN!FKYZ%}EJOwZR<9%pTWkAo zD4oAO11~D%+yXQ*^=_@Tz@#3e94J%%^IFz;<(#!$iF_`0&1~zcWSt=Eff@yFf#J asmjCLB;9^8N^7Q}^Y=gde!(M^MF0R6#O)FQ diff --git a/inst/html_example_outputs/tbl_summary_ex3.rds b/inst/html_example_outputs/tbl_summary_ex3.rds deleted file mode 100644 index a21792fdfeaf7fb776d7c553966b890740ddcf06..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1157 zcmV;01bX`)iwFP!000001MOPfZre5#R-5D^x!NNfXj_v4QewwxVpz6;pj)v4O@Xc} zuseg2XqgKoswC~$z3QX%A@&4&uwnd>{5K_Wwhm|#SqVg*LmpD+eCIn7q~G=&$JuhW zx1Km#JF4mIy#Mu;-&V43ROgA~eA;!K@BZk0~PD#04Q|6!+X5#WBee zpW>nHH1cUs3OGqds}jlbPIFlhGAUVVWo&}^kg_X(+CgK<7X6v+Uy)djY;%N-Y14N5 zdjRUMD^W->L=*|pa}zl*eHUURk^f=UPDf{R%G5yD=grk{=5XAu))exnG&N?7w zLgLgP6A$*^;e=s$|MR{FzcA$;=D|;xPOu~q^5C4SWjqil6TZNl4AqSDJXe?fl2OLt z$CUj}_Lt05NZ!rTkWnpqqs*^N3_v+3r%3I|I4^*Z@fdSIVw9p>;0~0n04T|@Ujza& z##2NCND)s+W}yHkJf+Bjp^!y-(GGmuGQYwdf_zj9G*1;2tl(QsyM!vQ|7sAAddT!xclX6`-!YD2?qnN+EmKmkT z@uj3xh6Z|`N(kZJF!@Ua?Ei4^n$3+I+`PrXcSKb4HbfPUHzBHaJ=pFz&BVZ7;J_Nx z3cW=aIJ*)#%6e|o)#*BKi-_eaWJ=_kg7A#WKyf9@l4pqwUXBn)kyO+q6k}=K(L#A+ zyw@q=hQwZGi$>%7YuG~Ksq__zXJV)%9U$3AZA*ULp#xR(G}TjIm6IgvfQ?Q7%M}z} zXftai6i%0gmVj5r6$ET#OQjY@B#v=b_^Vh|Pp`^*n3w@Nf_hOGimri7ziUI?Uj;$8 zKtR8HBuD=ZnGw#E)qji4H_(IQMxzGhJq4wW{#{^M;AIZX0s$3>R4s0b+L5Vhw!Vcd zo~_?c4z%zd7p|qEd{gD_${4gGFjv=3QHWJWEj*#}Z&4_2aK#Ef+Ew^y-vJ-?MpCEO zn%i!3b8|B{-;dl&Rc7cr^9?Dy%nUnijj+!XtN^djz7lRBksLHC;$6~j9r3R+;&Xny zCgyWC40+##y(GPw4jw)@Hlc$*KilI1#{^|?@V4o}+t%}%A|4D1Hl>J@GdO6qJ$P~U zyk?3=hLJll1<5?PK+~Ec9!&T*rHE4x+O3)#9vM0|A%_dZFENMLc!DV$WXVzby1s{a zI1s2GGiq?uj~O)zz5qou4o^?upmBJ7>_PMJq**^~JT|1%4;zm<{F@U+qv1j8uzj|| z5bCU7#}pp`?WwMQMWe8B6q8BcakihDZ}} -\if{html}{\out{
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
-
+\if{html}{\out{ }} -Customizing the `tbl_summary` function: +Customizing the \code{tbl_summary} function: \if{html}{\out{
}}\preformatted{ex2 <- trial |> select(age, grade, response, trt) |> @@ -215,52 +181,7 @@ Customizing the `tbl_summary` function: print(getOption("gtsummary_update_examples")) }\if{html}{\out{
}} -\if{html}{\out{
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicDrug A
-N = 981		Drug B
-N = 1021
Patient Age47 (14.7)47 (14.0)
    Unknown74
Grade

    I35 (36%)33 (32%)
    II32 (33%)36 (35%)
    III31 (32%)33 (32%)
Tumor Response28 (29%)33 (34%)
    Unknown34
1 Mean (SD), n (%)
-
+\if{html}{\out{ }} Multiple statistics for continuous variables: @@ -274,33 +195,7 @@ Multiple statistics for continuous variables: ) }\if{html}{\out{}} -\if{html}{\out{
- - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 200
Age
    Median (Q1, Q3)47 (38, 57)
    Min, Max6, 83
Marker Level (ng/mL)
    Median (Q1, Q3)0.64 (0.22, 1.41)
    Min, Max0.00, 3.87
-
+\if{html}{\out{ }} } diff --git a/man/utils_examples.Rd b/man/utils_examples.Rd index da126e1361..3b94388750 100644 --- a/man/utils_examples.Rd +++ b/man/utils_examples.Rd @@ -2,25 +2,25 @@ % Please edit documentation in R/utils_examples.R \name{utils_examples} \alias{utils_examples} -\alias{write_html_output} -\alias{read_html_output} -\alias{write_and_read_html_output} +\alias{write_example_output} +\alias{read_example_output} +\alias{write_read_example_output} \title{Utilities to write and read tables in html for function documentation} \usage{ -write_html_output( +write_example_output( tbl, example_name = "example", out_var_name = deparse(substitute(tbl)), method = c("txt", "rds")[2] ) -read_html_output( +read_example_output( out_var_name, example_name = "example", method = c("txt", "rds")[2] ) -write_and_read_html_output( +write_read_example_output( tbl, example_name = "example", out_var_name = deparse(substitute(tbl)), @@ -28,7 +28,17 @@ write_and_read_html_output( ) } \arguments{ -\item{tbl}{} +\item{tbl}{(\code{gtsummary} or \code{html})\cr tables are converted to html. Any html code (table or not) +can be saved and retrieved for documentation purposes.} + +\item{example_name}{(\code{string})\cr usually the name of the function or file where the +table is used.} + +\item{out_var_name}{(\code{string})\cr the name of the variable that will be saved. It defaults +to the name of the variable passed to the function (\code{tbl}).} + +\item{method}{(\code{string})\cr saving method. Default is \code{"rds"} as it produces a smaller file, +but we are planning to extend this to other, non-html outputs like \code{"png"}.} } \description{ This is still experimental. We are planning to potentially expand this to other diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R index f4394a9a53..e51b7ce73f 100644 --- a/tests/testthat/test-utils_examples.R +++ b/tests/testthat/test-utils_examples.R @@ -10,24 +10,24 @@ test_that("writing and reading examples work", { as_gt() |> gt::tab_options() |> gt::as_raw_html() - write_html_output(html_tbl) - read_html_tbl <- read_html_output("html_tbl") + write_example_output(html_tbl) + read_html_tbl <- read_example_output("html_tbl") expect_equal(html_tbl, read_html_tbl) # txt - write_html_output(html_tbl, method = "txt") - read_html_tbl <- read_html_output("html_tbl", method = "txt") + write_example_output(html_tbl, method = "txt") + read_html_tbl <- read_example_output("html_tbl", method = "txt") expect_equal(html_tbl, read_html_tbl) # One function - html_output2 <- write_and_read_html_output(html_tbl) + html_output2 <- write_read_example_output(html_tbl) expect_equal(html_tbl, html_output2) - expect_error(write_html_output(html_tbl, method = "sdads")) - expect_error(read_html_output("html_tbl", method = "sdads")) + expect_error(write_example_output(html_tbl, method = "sdads")) + expect_error(read_example_output("html_tbl", method = "sdads")) # Starting from tbl (common behavior) - write_html_output(tbl_to_write) - read_html_tbl <- read_html_output("tbl_to_write") + write_example_output(tbl_to_write) + read_html_tbl <- read_example_output("tbl_to_write") html_tbl2 <- strsplit(as.character(html_tbl), "\n")[[1]] read_html_tbl2 <- strsplit(as.character(read_html_tbl), "\n")[[1]] html_tbl2[1] <- paste0('
Date: Thu, 18 Apr 2024 12:52:11 +0200 Subject: [PATCH 45/74] cleaning tests --- inst/example_outputs/example_html_tbl.rds | Bin 1399 -> 0 bytes inst/example_outputs/example_html_tbl.txt | 35 ------------------ inst/example_outputs/example_tbl_to_write.rds | Bin 1400 -> 0 bytes tests/testthat/test-utils_examples.R | 12 ++++++ 4 files changed, 12 insertions(+), 35 deletions(-) delete mode 100644 inst/example_outputs/example_html_tbl.rds delete mode 100644 inst/example_outputs/example_html_tbl.txt delete mode 100644 inst/example_outputs/example_tbl_to_write.rds diff --git a/inst/example_outputs/example_html_tbl.rds b/inst/example_outputs/example_html_tbl.rds deleted file mode 100644 index 957e30b43c3b282d15974deb955ad62c987fd620..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1399 zcmV--1&I0|iwFP!000001MOSgZre5#R-5Fax!NNTDw4E-wOIL|NzBr8E-J3N?@r3(0Bpy;jeH_tn(n5T~ z1&N#yZJ>jXWWWfzetXbB9~gLtHPEjlyd{GAxPh)x*rtIvj=950O8c;QqJ>GkEH=g9iN3EPB>|ytmUDQ#>6p! zKru@r9C|3i>43%>3P^<~6KOCQnJ+hOq36fy$GC&jFR+1o22jv~@tkr!OGaWQ>tX+9 zkg`!6IGNHn>c>MGFJ?#cAOOHj17{%(3Ik@rku)GD&h%bg$k%j8JxwaS*9Auec*5~(9 zv*f%qmz1EWE7w6naC^bxuMx0s;ov!)l^pCYaqxI9`RQ-1SIzM^VhX`T@II zp&XDV+9+jXp5XY>c5Rui(>C{60wDvDtqz3!P)gj@y>Fh3uBb=8_y*sk$c|s*8fYGW1w5nZKfUrSK8o1#rVxAHB$vJv)e9=Is=PyTb8MIQ)HSj_AHXIP)$S7rydW`~UgNc~rdO^$w5dN?oe0=&yojA=c!EH^2s zK3QD1xk5>jSzfHgD7fpJmSrxhdtEV_OACD;sH0uZ#?zX)pd=c(3b><%fypvRB~Y$p z=qFhWR!G*9vSdA}o~-s`EL=jrk${5HFW$Qi^#1r|13}vyob&Ze@^OGE4^{b+Yy|YS zV_Dlz)mJ9At!MDQJrq$0@4NbI6!KqTd`Ec)8uEJ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
-
diff --git a/inst/example_outputs/example_tbl_to_write.rds b/inst/example_outputs/example_tbl_to_write.rds deleted file mode 100644 index bba029ed77c85a2b0153c379c988c6206e146fc4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1400 zcmV-;1&8_{iwFP!000001MOSgZre5#R-5D^x!NNTDw4E-wOIL|Wg7_Eb?e0n^e4dX z3|gXXE|RE2Oq(2$rF>RpzPh`jlx_r0aKpz=+hc(czB)leq`nZ8EQrM<}IF7l)NlFK>;vz}lv0t;0 zrRe8~{XzG0YDy%Zrcs}TQuH3w7Z!R59F&9@Y*NniP@km%NgbbsAx=1Hp{(VhkjBI@ zfj}`!BOH1t!s(F48VX2-ClhHf7@03OZJ`%O>c_Z)(_7fUJq0Le!DKGcs6SMqj%|FaQm!pV1P57WnDzO+ z)GRqK%_Su$>dAGG5Zqp}_-h30TR3<@XC()_4>)*5M7a+k$~azysND5PcgIo8d-?%; zTA>_}CfX=v6Q1C>W4pFY*IAqUEP;@L$W{l!UMM`^N)`|IhQfP2!YTFzP!k8nl4A$+ z!KLwDq=Y4joo9O}XP%_`(1GJ*7`Kp)j)(Fm zC_0g97LHJKnipyUF3d9otYo>P7L8~Skl6Uk>?)U+lUB?oa9i+l2NV_H8sEz!(*RSio^3r&WYg7F>5guLO?A>drlis6TqSJ` zo@a?;5IWD895C%Wn4BRa7uvIv-Mj8+{&-BJHyEdavRFoy%KIu@k#ZPD2E>JHmVt38 zSft(Kr0cdNZXvs+vAHCNR;um^2kN4ruMB+_Oc$@{Jt=&|cY)kJXW3<_EdnGRK~i}3 z5cdg?)Z7z5Y4fvpi7N__J}-mx`3jKMcXP=I3vPSJ&2BX}KMuNxAerTdorWF`r5uZ`|Ju%M+{P+yLJUVZnle1SU`Wg4ttg!wV zslp0>|D|7-@fDo1am^5G6aA_T;kq?3JTYigA%o!*?NixfewHO6=ebchchw5HejOK%dzW3D8KFr3mnz^7P8o3I%!=-`AGDsy* zu4L#ZSqxT4*5k5dJ+7Xt_G2tuLcfuKg3&KOxDE8-=v4zj+Z>#W^-S_{fGH1D`I2k| z^tx+Vo6pr(CN`~Yc;6g}D1`SN{WS{tuQ0x)yaNsSJ&WgsMY_H1XJwSo`R8Ak8P&w7 GF#rItvX#I9 diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R index e51b7ce73f..b03bd4fc2e 100644 --- a/tests/testthat/test-utils_examples.R +++ b/tests/testthat/test-utils_examples.R @@ -39,5 +39,17 @@ test_that("writing and reading examples work", { write_example_output("not_a_tbl_or_html"), "tbl needs a html or gtsummary table. Got something else." ) + + # Cleaning up options(gtsummary_update_examples = NULL) + folder_name <- file.path( + sub("(^.*/gtsummary).*", "\\1", getwd()), + "inst", + "example_outputs" + ) + files <- file.path( + folder_name, + c("example_html_tbl.txt", "example_html_tbl.rds", "example_tbl_to_write.rds") + ) + file.remove(files[file.exists(files)]) }) From 0d58d5f9cb308ea64c70159a1f953c1445078846 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Thu, 18 Apr 2024 13:00:00 +0200 Subject: [PATCH 46/74] path fixes --- R/utils_examples.R | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/R/utils_examples.R b/R/utils_examples.R index b0fd8c631f..576d3c33b7 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -23,11 +23,6 @@ write_example_output <- function(tbl, } if (getOption("gtsummary_update_examples", default = FALSE)) { - folder_name <- file.path( - sub("(^.*/gtsummary).*", "\\1", getwd()), - "inst", - "example_outputs" - ) if (is(tbl, "html")) { html_output <- tbl } else if (is(tbl, "gtsummary")) { @@ -38,11 +33,16 @@ write_example_output <- function(tbl, } else { stop("tbl needs a html or gtsummary table. Got something else.") } - fl_nm <- paste0(folder_name, "/", example_name, "_", out_var_name) + fl_nm <- file.path( + sub("(^.*/gtsummary).*", "\\1", getwd()), + "inst", + "example_outputs", + paste0(example_name, "_", out_var_name, ".", method) + ) if (method == "txt") { - writeLines(text = html_output, con = paste0(fl_nm, ".txt")) + writeLines(text = html_output, con = fl_nm) } else if (method == "rds") { - saveRDS(html_output, file = paste0(fl_nm, ".rds")) + saveRDS(html_output, file = fl_nm) } } } @@ -51,20 +51,16 @@ write_example_output <- function(tbl, read_example_output <- function(out_var_name, example_name = "example", method = c("txt", "rds")[2]) { - folder_name <- file.path( + fl_nm <- file.path( sub("(^.*/gtsummary).*", "\\1", getwd()), "inst", - "example_outputs" + "example_outputs", + paste0(example_name, "_", out_var_name, ".", method) ) if (isFALSE(method %in% c("txt", "rds"))) { stop("Inserted method is not supported.") } - fl_nm <- file.path( - folder_name, - paste0(example_name, "_", out_var_name, ".", method) - ) - if (require("htmltools", quietly = TRUE) && file.exists(fl_nm)) { if (method == "txt") { out <- readLines(fl_nm) |> From 8785ec73c277d5a8156e963681f964738b8603d4 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Thu, 18 Apr 2024 13:01:28 +0200 Subject: [PATCH 47/74] documenting --- inst/example_outputs/tbl_summary_ex1.rds | Bin 0 -> 1400 bytes inst/example_outputs/tbl_summary_ex2.rds | Bin 0 -> 1523 bytes inst/example_outputs/tbl_summary_ex3.rds | Bin 0 -> 1158 bytes man/tbl_summary.Rd | 114 ++++++++++++++++++++++- 4 files changed, 110 insertions(+), 4 deletions(-) create mode 100644 inst/example_outputs/tbl_summary_ex1.rds create mode 100644 inst/example_outputs/tbl_summary_ex2.rds create mode 100644 inst/example_outputs/tbl_summary_ex3.rds diff --git a/inst/example_outputs/tbl_summary_ex1.rds b/inst/example_outputs/tbl_summary_ex1.rds new file mode 100644 index 0000000000000000000000000000000000000000..272d6d0340ca4e30e043aeb76616c8a3aab6be7b GIT binary patch literal 1400 zcmV-;1&8_{iwFP!000001MOSgZre5#R-5Fax!NNTDw4E-wOEPsGs`g$wCmQ373fcZ z-5In*+gv1373nzc)gEQfvIiS>_#<0#6kFa}pm7wZFnLHG9-Z@@k92eV`>thKTh{j0 z6KiV+n%2(Mr#H?y$bNv%6U+MZnPs`pI|02xG`O&b0ZIG_-|)ajTuei9VJA2UXgqX6 zG7#-%a_eP+lnzHliC{_F%?tWW2o`A>yCLZyWE1DMjmLt``%~SY&_IlIb3~MC)wa94 z2*Gbh;C@JuA7akIPSI0+8wFTk=kpk+f;j=@Qs^Wp^9ko*!G%4*Azzr*XH0OB;$${z z9@UwU{xucOfW^Y$5lkC_jyA%vpg5$MlfXkx#J)I;-`<%uO!1WaI3ylYLjxSqaN0(E z$_0s>F>RoOk7URQx_W!iKpz-*hc(czB)lPl`nZ8EQ`n|~IF7l)NlFK>;xb9#v0t%} zrRe8~{Xq|MYDy#@r%|7UQuGeg7Z!R59F&9@Y*NniP@km%NgbbsAx=1HqpanjkjBI@ zfj}`!BOH1t!s(F48VX2-ClhHf7@03OZKLPM>c_Z)(=V`rdkRp{g2{q%JxfMnF6(3e zdYH0t95|WMH|obj8ZTx?^B@4gOao^j4GIHh!I3l|C(iU_}CfX=v6Q1Ds!gg($uCq4xSpp#gk*yAd{ZM$ol`J0a4~6$?gj4Jbpe7ECCC3iu zgG=MRNC`_4JI@x)=H5MQA;_(8fW%`y07)Cscm!sN?>lq|&OAx=p##UsFm59q9S`MC zP;?^IEF7WeG%wTyT$pDFSjlonEgI1vAhGe6*;Ott%X@UACddfNO>Jbl3Nqb}4t2K( zf{sBzw{s{){|}iyi9zds#pXM7fsUHZ1yHIvpum{3|9Q-W2YU_R*p8VXJvhIvxfUDz z>ds_D1#w`hPuek?z-__H9Z*z&YkV({Oan~4dbagAkxf@yr8~L}Hq}YYdN!RU2+(LFsV{=IktyJ9;4%J0LUm5x=m@Zz?ds6s-?*h4d&a%r;M+8VZf~4^5 zA?_0(sktYB(&lIH5?2%;eO?CX^EDu?@8*&b7TmVV&2BX}KMcBvAerTdorWF`r5uZ`|Ju%M+ymf|N9G^GP$=OR4{fzr+R@i)u zRAGg`|I)9k_!>^xxMqlriGEdvaNU|19vL*M5W_DiM7XAdjfr_xI_UJ%ZcPY}3>@p+ z6yDaPurYD3N(!gv@F}9TSAT?fYyeq{7;0wNoWR%2Py^&EGDA%bn-lrU)X)NIII5}P z(E+3iHGCRJEJYs(Pgu9 zr21re-R2r4NoIMm7Ng*yFx#}YjD$=Gv)L6FjQ_C@s{%yTjF*Gf( zJA;;Jn~NkWA|1!Q+N11Q_F%&fNy(NR#gVraNG!z-Odg6y)cL-14(aCjw;jVUo)}wC z9vM%zp=oS?`})y30ogO?JTiX2LvH@d)ix@}q z(d1FBDH&W)VGUU*EFQpRW6;q-I20876m#M^$O_nZi}C9lSB+vk<1Y4zgVfLv2h^W+ z5T9{D0&7C|(aUo(Vg!Br^l~44VPGA$kA5cp6%o|M`{*o&+w3EbLvC>r(;>__iz0aJ zcg$xo`Vg?+>C23o0?GL-7%*RoK7;z)L5_7Nl|*78 z8({Zh6thX_S*g;G>c>HvFUcK~2LS@68aVT*mm5eXH01&^;#BY1iG0n6)B`P+6OyHo z0&RLA)%U(7U-Loj3dO5S#tKv>Be$$k;!wCmHBg{V$(I&rqQOXsPR+!&%H_IZOt6=F zMlwHpFLjl?F3vb5DC*03;1JwgG5P-h>_-@QNoOeo+jkgvO-9*wF)A^RIgJ?L0Wr_O@9fF)EL%nZ7IvIr> zq|tFuHiM!=sb(pKqNA)(2jJXwNdQ)|OsYj=>Uktg?3LVAPA~F%bfqqk2+Et9DCsK7 z^tu}AUY-QqgaN(off)ZcX1XKCp)zbn37vD>u!PWsw2@CRiF$TdG8nvHF7|!|fwyIXfZb@; zQJ{_j_bLj!y%`07rVly{Kr2?qi34?>&?k!l^JdE@`MwlB;3GrkIJD}_)D<3*h9EIK zyN?G1!q~zR5cC#X^cAMavHPTm-6w0XTOZ+Na9A?iU1qk+nfYNvjsW~xekM|K^PKv% zp0>1A{uK)f4vx-71c(o;&%w?G7Ja(__cZs_$lpuk=TZI^?9-UuK1O?X`}Ogw+pure z*l#%Y4UK)8{p!51`3xzO7ykNFzrKYRu+IwX+^{j|myHj{bxx=p=IuHcRE!yAa=}kA zAY5mFjlsNZG>{+d)JdSau-AE@I^5H-TH%~3PRrk=$pIs z=R{Q_$XYp}P70d?eCf#0gvijUlR_1tKLY3v>!eUQf~=Pm>a4Ii$d?Wcc4og=XN5{Z zUmq2!NsuyG;p-$|G5SJy#6n*Gf5PT~Up6{4PtacTO`RAj2)#-S?K&}3jv)2l8dVwn z(&3>_36;Y<|F=f)F3T$BU!fpNM+z!QR+nn8QE8M+&(~Gt%=JSnvF|E%UlYwcYx{30 zoxeK+&nx7-0yHx9ZmpHTq#mRkC{zCPM%H-coV8u#tnKp7DvNv`ToDrbg}{>c&fmY< zNARBRke8~GeOzdduDZ~o}UYz!>!xzQwv(+hT?au=kUa@uoq62~k{ zd`^d|)5x!aN>H$5v@B5~?=%+$p-@VsRwl-@7;-W3uR7#XiFto&`x6$ck!_BsF>Tsz ze-{A%x{8FHLd1!bJvUJU({~{ziufNdNuh)vGpU7sUWkZFi96`IL&D|CuuupkRYCHZ zw!Bn-Lc?`a|^eE4zCgP#O?M|ki9UkNS> z_&ycCvb_Z}Yb5WdX(+fBy+!j&69Yg8<(%N2jPn8rMG@1&j|Ar=m$U;_D*(X(6l zOcW{M0i>izSZ1LBCOnnMf}xZ}deIJi-7>$@9g=;*1)3)a1uK}W7`LNzB<8Y^L>EaR zF0H;4EHJloO8h1{TDX-LtknW-4<*^X+7GMYG15RaExA zYw2UAw5hOuccpHP$x?I89(5enZqX>#m^1Q~4Z08}M$~gl-;(?2 zL9NhRbfFLvnUk#NHeH>rv$l*xjv+&lYYM`1t^(vrktNR)6}%def;fBOsWQ#`Q+iTcD(JSR6iDz<%k`AzJgxgYIcIW_Wo~C;4V>wB(4%p}fuvkIi zr8cutLg8dlXbE^}TuH!2woqze#NwD{rN7Em_4IXl4`VYxM^G>7LfJKt>340Y`^zBc zmI&x~57p?uAv2;GTK%`!d<#7|YBXw4-cwN8=-&mFC0=I0ED^8}D};TPPy{@peJR{h5jAM6iFZZ6b;Q5Oh|l=( znwZbnFf95e>=o(Nbnx)Ou?Zdg`MW*NY0O9l`|p|_ylcIvDdNGPU{i`XK85{O+k=;< zFKVWEWEi;c@;41)qT;8V4uGu-`a1I`W`-aNMjPHXa*N>W7U-9sbRUqS5f6bV>K)cx0uV@e(hcO%X9cTNg`G#rRd4}ihkxDt9ckOpg`hQ8kW59zA{o&Ko YrAfB^EUMmXV&|{F0j)2y-Z>=z08rO2X8-^I literal 0 HcmV?d00001 diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index eff016ceea..d3b1538aad 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -165,10 +165,44 @@ Basic \code{tbl_summary} function: tbl_summary() }\if{html}{\out{}} -\if{html}{\out{ +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 2001
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)
+
}} -Customizing the \code{tbl_summary} function: +Customizing the `tbl_summary` function: \if{html}{\out{
}}\preformatted{ex2 <- trial |> select(age, grade, response, trt) |> @@ -179,9 +213,55 @@ Customizing the \code{tbl_summary} function: digits = list(age = c(0, 1)) ) print(getOption("gtsummary_update_examples")) +#> [1] TRUE }\if{html}{\out{
}} -\if{html}{\out{ +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicDrug A
+N = 981		Drug B
+N = 1021
Patient Age47 (14.7)47 (14.0)
    Unknown74
Grade

    I35 (36%)33 (32%)
    II32 (33%)36 (35%)
    III31 (32%)33 (32%)
Tumor Response28 (29%)33 (34%)
    Unknown34
1 Mean (SD), n (%)
+
}} Multiple statistics for continuous variables: @@ -195,7 +275,33 @@ Multiple statistics for continuous variables: ) }\if{html}{\out{}} -\if{html}{\out{ +\if{html}{\out{
+ + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 200
Age
    Median (Q1, Q3)47 (38, 57)
    Min, Max6, 83
Marker Level (ng/mL)
    Median (Q1, Q3)0.64 (0.22, 1.41)
    Min, Max0.00, 3.87
+
}} } From 2dc603feb56f0b550a2510b1e1a0e6e7ea38e9b0 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Thu, 18 Apr 2024 13:08:43 +0200 Subject: [PATCH 48/74] htmltools to desc --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index e110fa23d8..51d6b00704 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,6 +57,7 @@ Imports: tidyr (>= 1.3.0) Suggests: cardx (>= 0.0.0.9049), + htmltools, knitr, testthat (>= 3.2.0) VignetteBuilder: From 7b55338fd51d56bb55cb991e17eafbc70ca60ead Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 23 Apr 2024 15:35:45 +0200 Subject: [PATCH 49/74] general --- R/utils_examples.R | 14 ++++++++------ tests/testthat/test-utils_examples.R | 2 +- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/R/utils_examples.R b/R/utils_examples.R index 576d3c33b7..d35d74742a 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -23,15 +23,17 @@ write_example_output <- function(tbl, } if (getOption("gtsummary_update_examples", default = FALSE)) { - if (is(tbl, "html")) { - html_output <- tbl - } else if (is(tbl, "gtsummary")) { + if (is(tbl, "gtsummary")) { + tbl <- tbl |> + as_gt() + } + if (is(tbl, "gt_tbl")) { html_output <- tbl |> - as_gt() |> gt::tab_options() |> gt::as_raw_html() - } else { - stop("tbl needs a html or gtsummary table. Got something else.") + } + if (!is(tbl, "html")) { + stop("tbl needs to be a html, gtsummary or gt table. Got something else.") } fl_nm <- file.path( sub("(^.*/gtsummary).*", "\\1", getwd()), diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R index b03bd4fc2e..30f2094d5a 100644 --- a/tests/testthat/test-utils_examples.R +++ b/tests/testthat/test-utils_examples.R @@ -37,7 +37,7 @@ test_that("writing and reading examples work", { # Impossible error expect_error( write_example_output("not_a_tbl_or_html"), - "tbl needs a html or gtsummary table. Got something else." + "tbl needs to be a html, gtsummary or gt table. Got something else." ) # Cleaning up From b21918f777579036019b3f70ac41d69ad81da1ab Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 3 May 2024 18:43:00 -0700 Subject: [PATCH 50/74] Adding v2 `add_p.tbl_summary()` (#1615) * in progress * in progress * Update style_sigfig.R * in progress * progress * progress * progress * progress * progress * updates * progress * progress * Update test-add_p.tbl_summary.R * updates * Update R-CMD-check.yaml * Update R-CMD-check.yaml * Update R-CMD-check.yaml * Update R-CMD-check.yaml * more updates * Update test-coverage.yaml * more updates * progress * Update R-CMD-check-as-cran.yaml * Update R-CMD-check-as-cran.yaml * progress * updates * Update R-CMD-check.yaml * more updates * Update add_p.R * more updates --- .github/workflows/R-CMD-check-as-cran.yaml | 49 ++ .github/workflows/R-CMD-check.yaml | 11 +- .github/workflows/pkgdown.yaml | 2 +- .github/workflows/test-coverage.yaml | 96 ++-- DESCRIPTION | 9 +- NAMESPACE | 8 +- NEWS.md | 12 +- R/add_p.R | 408 ++++++++++++++++ R/as_gt.R | 11 +- R/as_tibble.R | 12 +- R/assign_summary_digits.R | 34 +- R/assign_summary_type.R | 4 +- R/assign_tests.R | 193 ++++++++ R/bridge_summary.R | 6 + R/gtsummary-package.R | 2 +- R/import-standalone-check_pkg_installed.R | 203 ++++++++ R/import-standalone-checks.R | 280 ++++++++--- R/import-standalone-cli_call_env.R | 53 +++ R/import-standalone-stringr.R | 48 ++ R/modify_column_hide.R | 2 + R/modify_fmt_fun.R | 1 + R/modify_table_body.R | 58 +++ R/modify_table_styling.R | 17 +- R/reexport.R | 1 + R/select_helpers.R | 64 ++- R/styfn.R | 2 +- R/style_number.R | 2 + R/style_percent.R | 1 + R/style_pvalue.R | 1 + R/style_ratio.R | 1 + R/style_sigfig.R | 5 +- R/sysdata.rda | Bin 0 -> 3030 bytes R/tbl_summary.R | 42 +- R/tests.R | 167 +++++++ R/utils-add_p_tests.R | 498 ++++++++++++++++++++ R/utils-as.R | 1 + data-raw/gtsummary_tests.csv | 52 ++ data-raw/internal_data.R | 28 ++ man/add_p.Rd | 26 + man/add_p.tbl_summary.Rd | 127 +++++ man/assign_tests.Rd | 58 +++ man/modify_column_hide.Rd | 1 + man/modify_fmt_fun.Rd | 1 + man/modify_table_body.Rd | 36 ++ man/modify_table_styling.Rd | 3 +- man/select_helpers.Rd | 28 +- man/tbl_summary.Rd | 6 +- man/tests.Rd | 166 +++++++ man/vec_to_df.Rd | 20 + tests/testthat/_snaps/add_p.tbl_summary.md | 255 ++++++++++ tests/testthat/_snaps/tbl_summary.md | 6 +- tests/testthat/test-add_p.tbl_summary.R | 521 +++++++++++++++++++++ 52 files changed, 3414 insertions(+), 224 deletions(-) create mode 100644 .github/workflows/R-CMD-check-as-cran.yaml create mode 100644 R/add_p.R create mode 100644 R/assign_tests.R create mode 100644 R/import-standalone-check_pkg_installed.R create mode 100644 R/import-standalone-cli_call_env.R create mode 100644 R/import-standalone-stringr.R create mode 100644 R/modify_table_body.R create mode 100644 R/sysdata.rda create mode 100644 R/tests.R create mode 100644 R/utils-add_p_tests.R create mode 100644 data-raw/gtsummary_tests.csv create mode 100644 data-raw/internal_data.R create mode 100644 man/add_p.Rd create mode 100644 man/add_p.tbl_summary.Rd create mode 100644 man/assign_tests.Rd create mode 100644 man/modify_table_body.Rd create mode 100644 man/tests.Rd create mode 100644 man/vec_to_df.Rd create mode 100644 tests/testthat/_snaps/add_p.tbl_summary.md create mode 100644 tests/testthat/test-add_p.tbl_summary.R diff --git a/.github/workflows/R-CMD-check-as-cran.yaml b/.github/workflows/R-CMD-check-as-cran.yaml new file mode 100644 index 0000000000..5257285351 --- /dev/null +++ b/.github/workflows/R-CMD-check-as-cran.yaml @@ -0,0 +1,49 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help + +on: + push: + branches: [main, master] + pull_request: + # branches: [main, master] + +name: R-CMD-check-as-cran + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 1fe123e906..3b2523dbf4 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -32,7 +32,7 @@ jobs: - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'oldrel-1'} - {os: ubuntu-latest, r: 'oldrel-2'} - # - {os: ubuntu-latest, r: 'oldrel-3'} + - {os: ubuntu-latest, r: 'oldrel-3'} # - {os: ubuntu-latest, r: 'oldrel-4'} env: @@ -55,6 +55,15 @@ jobs: extra-packages: any::rcmdcheck needs: check + # this is hopefully a transitory issue and we can delete in the future (2024-05-02) + # https://github.com/lme4/lme4/issues/763 + - name: Install Matrix and lme4 from CRAN + run: utils::install.packages(c("Matrix", "lme4"), repos = c(CRAN = "https://cloud.r-project.org")) + shell: Rscript {0} + + + # not using the default '--as-cran' arg, because it sets up private libs (see https://github.com/r-lib/devtools/issues/2044#issuecomment-526209877) - uses: r-lib/actions/check-r-package@v2 with: upload-snapshots: true + args: 'c("--no-manual")' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index d629ecbda7..3dabb62c5f 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -33,7 +33,7 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: any::pkgdown, local::. - needs: website + needs: check - name: Build site run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 6a1bcbbeee..8bee3758d8 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,50 +1,50 @@ # # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -# on: -# push: -# branches: [main, master] -# pull_request: -# branches: [main, master] -# -# name: test-coverage -# -# jobs: -# test-coverage: -# runs-on: ubuntu-latest -# env: -# GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} -# -# steps: -# - uses: actions/checkout@v3 -# -# - uses: r-lib/actions/setup-r@v2 -# with: -# use-public-rspm: true -# -# - uses: r-lib/actions/setup-r-dependencies@v2 -# with: -# extra-packages: any::covr -# needs: coverage -# -# - name: Test coverage -# run: | -# covr::codecov( -# quiet = FALSE, -# clean = FALSE, -# install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") -# ) -# shell: Rscript {0} -# -# - name: Show testthat output -# if: always() -# run: | -# ## -------------------------------------------------------------------- -# find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true -# shell: bash -# -# - name: Upload test results -# if: failure() -# uses: actions/upload-artifact@v3 -# with: -# name: coverage-test-failures -# path: ${{ runner.temp }}/package +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: check + + - name: Test coverage + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index e110fa23d8..2bba9b650e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,8 +45,7 @@ BugReports: https://github.com/ddsjoberg/gtsummary/issues Depends: R (>= 4.1) Imports: - broom.helpers, - cards (>= 0.1.0.9003), + cards (>= 0.1.0.9020), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), @@ -56,9 +55,10 @@ Imports: tibble (>= 3.2.1), tidyr (>= 1.3.0) Suggests: - cardx (>= 0.0.0.9049), + cardx (>= 0.1.0.9033), knitr, - testthat (>= 3.2.0) + testthat (>= 3.2.0), + withr VignetteBuilder: knitr RdMacros: @@ -68,6 +68,7 @@ Remotes: insightsengineering/cardx Config/testthat/edition: 3 Config/testthat/parallel: true +Config/Needs/check: broom, broom.helpers, lme4 Encoding: UTF-8 Language: en-US LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 1682182aaf..3254432478 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,21 +1,26 @@ # Generated by roxygen2: do not edit by hand +S3method(add_p,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) +S3method(assign_tests,tbl_summary) S3method(print,gtsummary) export("%>%") export(.table_styling_expr_to_row_number) +export(add_p) export(all_categorical) export(all_continuous) export(all_continuous2) export(all_dichotomous) export(all_of) export(all_stat_cols) +export(all_tests) export(any_of) export(as_gt) export(as_tibble) export(assign_summary_digits) export(assign_summary_type) +export(assign_tests) export(brdg_summary) export(contains) export(default_stat_labels) @@ -26,6 +31,7 @@ export(matches) export(modify_column_hide) export(modify_column_unhide) export(modify_fmt_fun) +export(modify_table_body) export(modify_table_styling) export(mutate) export(num_range) @@ -51,7 +57,6 @@ export(tbl_summary) export(vars) export(where) import(rlang) -importFrom(broom.helpers,.select_to_varnames) importFrom(dplyr,"%>%") importFrom(dplyr,across) importFrom(dplyr,all_of) @@ -69,3 +74,4 @@ importFrom(dplyr,select) importFrom(dplyr,starts_with) importFrom(dplyr,vars) importFrom(dplyr,where) +importFrom(glue,glue) diff --git a/NEWS.md b/NEWS.md index 73a77385b2..00442c4664 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,13 +4,15 @@ #### User-facing Updates +* Argument `add_p.tbl_summary(adj.vars)` was added to more easily add p-values that are adjusted/stratified by other columns in a data frame. + * The counts in the header of `tbl_summary(by)` tables now appear on a new line. * If a column is all `NA_character_` in `tbl_summary()`, the default summary type is now `"continuous"`, where previously it was `"dichotomous"`. * Added a family of function `styfn_*()` that are similar to the `style_*()` except they return a styling _function_, rather than a styled value. -* Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be either explicitly defined in a factor or be a logical vector. This means that a vector of all `"yes"` values will default to a categorical summary. +* Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be either explicitly defined in a factor or be a logical vector. This means that a character vector of all `"yes"` or all `"no"` values will default to a categorical summary instead of dichotomous. * Previously, indentation was handled with `modify_table_styling(text_format = c("indent", "indent2"))`, which would indent a cell 4 and 8 spaces, respectively. Handling of indentation has been migrated to `modify_table_styling(indentation = integer())`, and by default, the label column is indented to zero spaces. This makes it easier to indent a group of rows. @@ -22,7 +24,7 @@ * The values passed in `tbl_summary(value)` are now only checked for columns that are summary type `"dichotomous"`. -* Previously, the gtsummary selecting functions, e.g. `all_categorical()`, `all_continuous()`, etc., would error if used out of context. Now they won't select the columns silently. +* Previously, the gtsummary selecting functions, e.g. `all_categorical()`, `all_continuous()`, etc., would error if used out of context. They will now select no columns when used out-of-context. #### Internal Updates @@ -38,6 +40,12 @@ * The `modify_header(stat_by)` argument was deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the package. +* Use of the `vars()` selector was first removed in v1.2.5 (2020-02-11), and the messaging about the deprecation was kicked up in June 2022. This use is now defunct and the function will soon no longer be exported. + +* The `add_p(test = ~'aov')` test is now deprecated as identical results can be obtained with `add_p(test = ~'oneway.test', test.args = ~list(var.equal = TRUE))`. + +* Previously, `add_p.tbl_summary()` would coerce various data types to classes compatible with some base R tests. One example, is that we would convert `difftime` classes to general numeric before passing to `wilcox.test()`. We have eliminated type- and class-specific handling in these functions and it is now left to the the user pass data compatible with the functions that calculate the p-values or to create a custom test that wraps `wilcox.test()` and performs the conversion. This change is effective immediately. + # gtsummary 1.7.2 * Removed messaging about the former auto-removal of the `tbl_summary(group)` variable from the table: a change that occurred 3+ years ago in gtsummary v1.3.1 diff --git a/R/add_p.R b/R/add_p.R new file mode 100644 index 0000000000..67b3bd33af --- /dev/null +++ b/R/add_p.R @@ -0,0 +1,408 @@ +#' Adds P-value +#' +#' - [`add_p.tbl_summary()`] +#' +#' @param x (`gtsummary`)\cr +#' Object with class 'gtsummary' +#' @param ... Passed to other methods. +#' @keywords internal +#' @author Daniel D. Sjoberg +#' @export +#' +#' @seealso [`add_p.tbl_summary()`] +add_p <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_p") +} + +#' Add p-values to summary table +#' +#' Adds p-values to tables created by [`tbl_summary()`] by comparing values across groups. +#' +#' @param x (`tbl_summary`)\cr +#' table created with `tbl_summary()` +#' @param test ([`formula-list-selector`][syntax])\cr +#' Specifies the statistical tests to perform for each variable, e.g. +#' `list(all_continuous() ~ "t.test", all_categorical() ~ "fisher.test")`. +#' +#' See below for details on default tests and [tests] for details on available +#' tests and creating custom tests. +#' +#' Common tests include `"t.test"`, `"aov"`, `"wilcox.test"`, `"kruskal.test"`, +#' `"chisq.test"`, `"fisher.test"`, and `"lme4"` (for clustered data). +#' See [tests] for details, more tests, and instruction for implementing a custom test. +#' +#' Default tests when `group` argument not specified are `"kruskal.test"` +#' for continuous variables (`"wilcox.test"` when "by" variable has two levels), +#' `"chisq.test.no.correct"` for categorical variables with all expected cell +#' counts >=5, and `"fisher.test"` for categorical variables with any expected cell count <5. +#' @param pvalue_fun (`function`)\cr +#' Function to round and format p-values. Default is `styfn_pvalue()`. +#' The function must have a numeric vector input, and return a string that is +#' the rounded/formatted p-value (e.g. `pvalue_fun = styfn_pvalue(digits = 2)`). +#' @param group ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variable name of an ID or grouping variable. The column can be used to +#' calculate p-values with correlated data. +#' Default is `NULL`. See [tests] for methods that utilize the `group` argument. +#' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variables to include in output. Default is `everything()`. +#' @param test.args ([`formula-list-selector`][syntax])\cr +#' Containing additional arguments to pass to tests that accept arguments. +#' For example, add an argument for all t-tests, use +#' `test.args = all_tests("t.test") ~ list(var.equal = TRUE)`. +#' @param adj.vars ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variables to include in adjusted calculations (e.g. in ANCOVA models). +#' Default is `NULL`. +#' @param ... Not used +#' +#' @return a gtsummary table of class `"tbl_summary"` +#' @export +#' +#' @section test argument: +#' +#' See the [tests] help file for details on available tests and creating custom tests. +#' The [tests] help file also includes psuedo-code for each test to be clear +#' precisely how the calculation is performed. +#' +#' The default test used in `add_p()` primarily depends on these factors: +#' - whether the variable is categorical/dichotomous vs continuous +#' - number of levels in the `tbl_summary(by)` variable +#' - whether the `add_p(group)` argument is specified +#' - whether the `add_p(adj.vars)` argument is specified +#' +#' #### Specified neither `add_p(group)` nor `add_p(adj.vars)` +#' +#' - `"wilcox.test"` when `by` variable has two levels and variable is continuous. +#' - `"krustkal.test"` when `by` variable has more than two levels and variable is continuous. +#' - `"chisq.test.no.correct"` for categorical variables with all expected cell counts >=5, +#' and `"fisher.test"` for categorical variables with any expected cell count <5. +#' +#' #### Specified `add_p(group)` and not `add_p(adj.vars)` +#' +#' - `"lme4"` when `by` variable has two levels for all summary types. +#' +#' *There is no default for grouped data when `by` variable has more than two levels.* +#' *Users must create custom tests for this scenario.* +#' +#' #### Specified `add_p(adj.vars)` and not `add_p(group)` +#' +#' - `"ancova"` when variable is continuous and `by` variable has two levels. +#' +#' @examplesIf gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx") +#' # Example 1 ---------------------------------- +#' add_p_ex1 <- +#' trial |> +#' tbl_summary(by = trt, include = c(age, grade)) |> +#' add_p() +#' +#' # Example 2 ---------------------------------- +#' add_p_ex2 <- +#' trial %>% +#' select(trt, age, marker) |> +#' tbl_summary(by = trt, missing = "no") |> +#' add_p( +#' # perform t-test for all variables +#' test = everything() ~ "t.test", +#' # assume equal variance in the t-test +#' test.args = all_tests("t.test") ~ list(var.equal = TRUE) +#' ) +add_p.tbl_summary <- function(x, + test = NULL, + pvalue_fun = styfn_pvalue(), + group = NULL, + include = everything(), + test.args = NULL, + adj.vars = NULL, + ...) { + set_cli_abort_call() + # check/process inputs ------------------------------------------------------- + check_dots_empty() + updated_call_list <- c(x$call_list, list(add_p = match.call())) + + # checking that input x has a by var + if (is_empty(x$inputs$by)) { + "Cannot run {.fun add_p} when {.code tbl_summary(by)} argument not included." |> + cli::cli_abort(call = get_cli_abort_call()) + } + + cards::process_selectors( + select_prep(x$table_body, x$inputs$data[x$inputs$include]), + include = {{ include }} + ) + cards::process_selectors(x$inputs$data, group = {{ group }}, adj.vars = {{ adj.vars }}) + check_scalar(group, allow_empty = TRUE) + + cards::process_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + test = test, + include_env = TRUE + ) + # add the calling env to the test + test <- .add_env_to_list_elements(test, env = caller_env()) + + + cards::check_list_elements( + test, + predicate = \(x) is.character(x) || is.function(x), + error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", + i = "Value must be {.cls character} or {.cls function}.") + ) + + # if `pvalue_fun` not modified, check if we need to use a theme p-value + if (missing(pvalue_fun)) { + pvalue_fun <- + get_theme_element("add_p.tbl_summary-arg:pvalue_fun") %||% + get_theme_element("pkgwide-fn:pvalue_fun") %||% + pvalue_fun + } + pvalue_fun <- as_function(pvalue_fun) + + # select test ---------------------------------------------------------------- + test <- + assign_tests( + x = x, + test = test, + group = group, + adj.vars = adj.vars, + include = include, + calling_fun = "add_p" + ) + + # add all available test meta data to a data frame --------------------------- + df_test_meta_data <- + imap( + test, + ~dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) + ) |> + dplyr::bind_rows() + + # add test names to `.$table_body` so it can be used in selectors ------------ + if (!"test_name" %in% names(x$table_body)) { + x$table_body <- + dplyr::left_join( + x$table_body, + df_test_meta_data[c("variable", "test_name")], + by = "variable" + ) |> + dplyr::relocate("test_name", .after = "variable") + } + else { + x$table_body <- + dplyr::rows_update( + x$table_body, + df_test_meta_data[c("variable", "test_name")], + by = "variable", + unmatched = "ignore" + ) |> + dplyr::relocate("test_name", .after = "variable") + } + + + # now process the `test.args` argument --------------------------------------- + cards::process_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + test.args = test.args + ) + cards::check_list_elements( + test.args, + predicate = \(x) is.list(x) && is_named(x), + error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", + i = "Value must be a named list.") + ) + + # calculate p-values --------------------------------------------------------- + x <- + calculate_and_add_test_results( + x = x, include = include, group = group, test.args = test.args, adj.vars = adj.vars, + df_test_meta_data = df_test_meta_data, calling_fun = "add_p" + ) + + # update call list + x$call_list <- updated_call_list + + x +} + +calculate_and_add_test_results <- function(x, include, group, test.args, adj.vars, + df_test_meta_data, estimate_fun = NULL, + calling_fun) { + # list of ARDs or broom::tidy-like results + lst_results <- + lapply( + include, + \(variable) { + # evaluate the test + lst_captured_results <- + cards::eval_capture_conditions( + do.call( + what = + df_test_meta_data |> + dplyr::filter(.data$variable %in% .env$variable) |> + dplyr::pull("fun_to_run") %>% + getElement(1), + args = list( + data = x$inputs$data, + variable = variable, + by = x$inputs$by, + group = group, + type = x$inputs$type[[variable]], + test.args = test.args[[variable]] + ) + ) + ) + + # if there was a warning captured, print it now + if (!is.null(lst_captured_results[["warning"]])) { + cli::cli_inform(c( + "The following warning was returned in {.fun {calling_fun}} for variable {.val {variable}}", + "!" = lst_captured_results[["warning"]] + )) + } + + # if test evaluated without error, return the result + if (!is.null(lst_captured_results[["result"]])) return(lst_captured_results[["result"]]) # styler: off + # otherwise, construct a {cards}-like object with error + dplyr::tibble( + group1 = x$inputs$by, + variable = variable, + stat_name = switch(calling_fun, "add_p" = "p.value", "add_difference" = "estimate"), + stat = list(NULL), + warning = lst_captured_results["warning"], + error = lst_captured_results["error"] + ) %>% + structure(., class = c("card", class(.))) + } + ) |> + stats::setNames(include) + + # print any errors or warnings + lst_results |> + map(\(x) if (inherits(x, "card")) x else NULL) |> + dplyr::bind_rows() %>% + {switch( + !is_empty(.), + dplyr::filter(., .data$stat_name %in% c("estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value")) |> + cards::print_ard_conditions() + )} + + + # combine results into a single data frame + df_results <- + lst_results |> + imap( + function(x, variable) { + # if results are an ARD, reshape into broom::tidy-like format + if (inherits(x, "card")) { + res <- + dplyr::filter(x, .data$stat_name %in% c("estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value")) |> + cards::replace_null_statistic() |> + tidyr::pivot_wider( + id_cols = "variable", + names_from = "stat_name", + values_from = "stat" + ) |> + dplyr::mutate(across(-"variable", unlist)) + } + else { + if (!is.data.frame(x)) { + cli::cli_abort( + c("Expecting the test result object for variable {.val {variable}} to be a {.cls {c('data.frame', 'tibble')}}.", + i = "Review {.help gtsummary::tests} for details on constructing a custom function."), + call = get_cli_abort_call() + ) + } + + res <- + dplyr::select(x, any_of(c("estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value"))) |> + dplyr::mutate(variable = .env$variable, .before = 1L) + # check the result structure + if (identical(names(res), "variable") || nrow(res) != 1L) { + cli::cli_abort( + c("The test result object for variable {.val {variable}} is not the expected structure.", + i = "Review {.help gtsummary::tests} for details on constructing a custom function."), + call = get_cli_abort_call() + ) + } + } + res + } + ) |> + dplyr::bind_rows() + + # remove new columns that already exist in gtsummary table + new_columns <- names(df_results) |> setdiff(names(x$table_body)) + if (is_empty(new_columns)) { + cli::cli_abort( + c("Columns {.val {names(df_results) |> setdiff('variable')}} are already present in table (although, some may be hidden), and no new columns were added.", + i = "Use {.code tbl |> modify_table_body(\\(x) dplyr::select(x, -p.value))} to remove columns and they will be replaced by the new columns from the current call."), + call = get_cli_abort_call() + ) + } + + # create default footnote text + footnote <- map( + lst_results, + function(x) { + if (inherits(x, "card")) { + ft <- x |> + dplyr::filter(.data$stat_name %in% "method") |> + dplyr::pull("stat") |> + unlist() + } + else { + ft <- x[["method"]] + } + ft + } + ) |> + unlist() |> + unique() |> + paste(collapse = "; ") + if (footnote == "" || is_empty(footnote)) footnote <- NULL + + # add results to `.$table_body` ---------------------------------------------- + x <- x |> + modify_table_body( + ~dplyr::left_join( + .x, + df_results |> dplyr::mutate(row_type = "header"), + by = c("variable", "row_type") + ) + ) + + x <- + modify_table_styling( + x, + columns = intersect("p.value", new_columns), + label = "**p-value**", + hide = FALSE, + fmt_fun = styfn_pvalue(), + footnote = footnote + ) |> + modify_table_styling( + columns = + intersect( + c("estimate", "std.error", "parameter", "statistic", "conf.low", "conf.high"), + new_columns + ), + hide = TRUE, + fmt_fun = styfn_sigfig(), + footnote = footnote + ) + + # adding labels for hidden columns + x$table_styling$header <- x$table_styling$header |> + dplyr::mutate( + label = ifelse(.data$column %in% "statistic", "**Statistic**", .data$label) + ) |> + tidyr::fill("modify_stat_N", .direction = "downup") # fill missing N for new cols + + # add raw results to `.$card` + x$cards[[calling_fun]] <- lst_results + + x +} diff --git a/R/as_gt.R b/R/as_gt.R index fd0b22108b..55232d2192 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -25,6 +25,7 @@ #' # tbl_summary(by = trt) %>% #' # as_gt() as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { + set_cli_abort_call() check_class(x, "gtsummary") # running pre-conversion function, if present -------------------------------- @@ -57,12 +58,10 @@ as_gt <- function(x, include = everything(), return_calls = FALSE, ...) { ) # converting to character vector --------------------------------------------- - include <- - .select_to_varnames( - select = {{ include }}, - var_info = names(gt_calls), - arg_name = "include" - ) + cards::process_selectors( + data = vec_to_df(names(gt_calls)), + include = {{ include }} + ) # user cannot omit the first 'gt' command include <- "gt" %>% union(include) diff --git a/R/as_tibble.R b/R/as_tibble.R index d7966b659f..66fae3ec12 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -29,6 +29,7 @@ NULL #' @rdname as_tibble.gtsummary as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, return_calls = FALSE, fmt_missing = FALSE, ...) { + set_cli_abort_call() # running pre-conversion function, if present -------------------------------- x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x)) @@ -44,12 +45,10 @@ as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, ) # converting to character vector --------------------------------------------- - include <- - .select_to_varnames( - select = {{ include }}, - var_info = names(tibble_calls), - arg_name = "include" - ) + cards::process_selectors( + data = vec_to_df(names(tibble_calls)), + include = {{ include }} + ) # making list of commands to include ----------------------------------------- # this ensures list is in the same order as names(x$kable_calls) @@ -69,6 +68,7 @@ as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE, #' @export #' @rdname as_tibble.gtsummary as.data.frame.gtsummary <- function(...) { + set_cli_abort_call() res <- as_tibble(...) if (inherits(res, "data.frame")) { diff --git a/R/assign_summary_digits.R b/R/assign_summary_digits.R index 4bed328374..fbe116cbf6 100644 --- a/R/assign_summary_digits.R +++ b/R/assign_summary_digits.R @@ -23,6 +23,7 @@ #' type = list(mpg = "continuous") #' ) assign_summary_digits <- function(data, statistic, type, digits = NULL) { + set_cli_abort_call() # stats returned for all variables lst_cat_summary_fns <- .categorical_summary_functions(c("n", "p")) lst_all_fmt_fns <- @@ -115,24 +116,25 @@ assign_summary_digits <- function(data, statistic, type, digits = NULL) { # otherwise guess the number of digits to use based on the spread # calculate the spread of the variable - tryCatch({ - var_spread <- - stats::quantile(x, probs = c(0.95), na.rm = TRUE) - - stats::quantile(x, probs = c(0.05), na.rm = TRUE) - - styfn_number( - digits = - dplyr::case_when( - var_spread < 0.01 ~ 4L, - var_spread >= 0.01 & var_spread < 0.1 ~ 3L, - var_spread >= 0.1 & var_spread < 10 ~ 2L, - var_spread >= 10 & var_spread < 20 ~ 1L, - var_spread >= 20 ~ 0L - ) - )}, + tryCatch( + { + var_spread <- + stats::quantile(x, probs = c(0.95), na.rm = TRUE) - + stats::quantile(x, probs = c(0.05), na.rm = TRUE) + + styfn_number( + digits = + dplyr::case_when( + var_spread < 0.01 ~ 4L, + var_spread >= 0.01 & var_spread < 0.1 ~ 3L, + var_spread >= 0.1 & var_spread < 10 ~ 2L, + var_spread >= 10 & var_spread < 20 ~ 1L, + var_spread >= 20 ~ 0L + ) + ) + }, error = function(e) 0L ) - } .categorical_summary_functions <- diff --git a/R/assign_summary_type.R b/R/assign_summary_type.R index 59ead89017..bdaeeaf52d 100644 --- a/R/assign_summary_type.R +++ b/R/assign_summary_type.R @@ -26,6 +26,7 @@ #' value = NULL #' ) assign_summary_type <- function(data, variables, value, type = NULL, cat_threshold = 10L) { + set_cli_abort_call() # base classes that can be summarized as continuous base_numeric_classes <- c("numeric", "integer", "difftime", "Date", "POSIXt", "double") @@ -93,7 +94,7 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # numeric variables that are 0 and 1 only, will be dichotomous if (inherits(x, c("integer", "numeric")) && - setequal(unique(stats::na.omit(x)), c(0, 1))) { + setequal(unique(stats::na.omit(x)), c(0, 1))) { return(stats::na.omit(x) |> unique() |> sort() |> dplyr::last()) } @@ -114,4 +115,3 @@ assign_summary_type <- function(data, variables, value, type = NULL, cat_thresho # otherwise, return NULL NULL } - diff --git a/R/assign_tests.R b/R/assign_tests.R new file mode 100644 index 0000000000..d9765adbe5 --- /dev/null +++ b/R/assign_tests.R @@ -0,0 +1,193 @@ +#' Assign Test +#' +#' This function is used to assign default tests for `add_p()` +#' and `add_difference()`. +#' +#' @param x (`gtsummary`)\cr +#' a table of class `'gtsummary'` +#' @param test (named `list`)\cr +#' a named list of tests. +#' @param group (`string`)\cr +#' a variable name indicating the grouping column for correlated data. +#' Default is `NULL`. +#' @param adj.vars (`character`)\cr +#' Variables to include in adjusted calculations (e.g. in ANCOVA models). +#' @param include (`character`)\cr +#' Character vector of column names to assign a default tests. +#' @param calling_fun (`string`)\cr +#' Must be one of `'add_p'` and `'add_difference'`. Depending on the context, +#' different defaults are set. +#' @inheritParams cli::cli_abort +#' +#' @return A table of class `'gtsummary'` +#' @name assign_tests +#' +#' @examples +#' trial |> +#' tbl_summary( +#' by = trt, +#' include = c(age, stage) +#' ) |> +#' assign_tests(include = c("age", "stage"), calling_fun = "add_p") +NULL + +#' @rdname assign_tests +#' @export +assign_tests <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("assign_tests") +} + +#' @rdname assign_tests +#' @export +assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NULL, include, + calling_fun = c("add_p", "add_difference"), ...) { + set_cli_abort_call() + # processing inputs ---------------------------------------------------------- + calling_fun <- arg_match(calling_fun) + data <- x$inputs$data + by <- x$inputs$by + summary_type <- x$inputs$type + + # loop over the variables and assign default test if not provided by user + lapply( + include, + function(variable) { + if (is.null(test[[variable]]) && calling_fun %in% "add_p") { + test[[variable]] <- + .add_p_tbl_summary_default_test(data, variable = variable, + by = by, group = group, adj.vars = adj.vars, + summary_type = summary_type[[variable]]) + } + + if (is.null(test[[variable]])) { + cli::cli_abort(c( + "There is no default test set for column {.val {variable}}.", + i = "Set a value in the {.arg test} argument for column {.val {variable}} or exclude with {.code include = -{variable}}."), + call = get_cli_abort_call() + ) + } + + test[[variable]] <- + .process_test_argument_value( + test = test[[variable]], + class = "tbl_summary", + calling_fun = calling_fun + ) + } + ) |> + stats::setNames(include) +} + + +.process_test_argument_value <- function(test, class, calling_fun) { + # subset the data frame + df_tests <- + df_add_p_tests |> + dplyr::filter(.data$class %in% .env$class, .data[[calling_fun]]) + + # if the test is character and it's an internal test + if (is.character(test) && test %in% df_tests$test_name) { + test_to_return <- df_tests$fun_to_run[df_tests$test_name %in% test][[1]] |> eval() + attr(test_to_return, "test_name") <- df_tests$test_name[df_tests$test_name %in% test] + return(test_to_return) + } + + # if the test is character and it's NOT an internal test + if (is.character(test)) { + return(eval(parse_expr(test), envir = attr(test, ".Environment"))) + } + + # if passed test is a function and it's an internal test + internal_test_index <- df_tests$test_fun |> + map_lgl(~identical_no_attr(eval(.x), test)) |> + which() + if (is.function(test) && !is_empty(internal_test_index)) { + test_to_return <- df_add_p_tests$fun_to_run[[internal_test_index]] |> eval() + attr(test_to_return, "test_name") <- df_add_p_tests$test_name[internal_test_index] + return(test_to_return) + } + + # otherwise, if it's a function, return it + return(eval(test, envir = attr(test, ".Environment"))) + +} + +# compare after removing attributes +identical_no_attr <- function(x, y) { + tryCatch({ + attributes(x) <- NULL + attributes(y) <- NULL + identical(x, y)}, + error = \(x) FALSE + ) +} + +.add_p_tbl_summary_default_test <- function(data, variable, by, group, adj.vars, summary_type) { + # for continuous data, default to non-parametric tests + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% c("continuous", "continuous2") && length(unique(data[[by]])) == 2) { + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.continuous_by2", default = "wilcox.test") + return(test_func) + } + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% c("continuous", "continuous2")) { + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.continuous", default = "kruskal.test") + return(test_func) + } + # now assign categorical default tests + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% c("categorical", "dichotomous")) { + # calculate expected counts to select between chi-square and fisher + min_exp <- + tryCatch( + suppressWarnings( + table(data[[by]], data[[variable]]) |> + proportions() %>% + {expand.grid(rowSums(.), colSums(.))} |> #styler: off + dplyr::mutate( + exp = .data$Var1 * .data$Var2 * + sum(!is.na(data[[variable]]) & !is.na(data[[by]])) + ) %>% + dplyr::pull(exp) |> + min() + ), + error = \(e) Inf # if there is an error for whatever reason, return Inf + ) + # if expected counts are greater than 5, then chisq test + if (isTRUE(min_exp >= 5 || is.nan(min_exp))) { + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.categorical", default = "chisq.test.no.correct") + return(test_func) + } + # otherwise fishers test + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.categorical.low_count", default = "fisher.test") + return(test_func) + } + + # now setting default tests for grouped data + # if group variable supplied, fit a random effects model + if (!is_empty(group) && is_empty(adj.vars) && length(unique(data[[by]])) == 2) { + if (summary_type %in% c("continuous", "continuous2")) { + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.continuous.group_by2", default = "lme4") + return(test_func) + } + if (summary_type %in% c("categorical", "dichotomous")) { + test_func <- + get_theme_element("add_p.tbl_summary-attr:test.categorical.group_by2", default = "lme4") + return(test_func) + } + } + + # now setting default tests for adjusted comparisons + if (is_empty(group) && !is_empty(adj.vars) && length(unique(data[[by]])) == 2) { + if (summary_type %in% c("continuous", "continuous2")) { + return("ancova") + } + } + + + return(NULL) +} diff --git a/R/bridge_summary.R b/R/bridge_summary.R index fd8ba3f960..bbeef8592f 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -65,6 +65,7 @@ NULL #' @rdname bridge_summary #' @export brdg_summary <- function(x, calling_function = "tbl_summary") { + set_cli_abort_call() # add gts info to the cards table -------------------------------------------- # adding the name of the column the stats will populate if (is_empty(x$inputs$by)) { @@ -136,6 +137,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { #' @export pier_summary_dichotomous <- function(x, variables, value = x$inputs$value, calling_function = "tbl_summary") { + set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } @@ -154,6 +156,7 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value, #' @export pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat, calling_function = "tbl_summary") { + set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } @@ -269,6 +272,7 @@ pier_summary_categorical <- function(x, variables, missing, missing_text, missin #' @export pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat, calling_function = "tbl_summary") { + set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } @@ -373,6 +377,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @export pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat, calling_function = "tbl_summary") { + set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } @@ -436,6 +441,7 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing #' @export pier_summary_missing_row <- function(x, variables = x$inputs$include, calling_function = "tbl_summary") { + set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } diff --git a/R/gtsummary-package.R b/R/gtsummary-package.R index 287f922e54..963ebe9795 100644 --- a/R/gtsummary-package.R +++ b/R/gtsummary-package.R @@ -1,7 +1,7 @@ #' @keywords internal #' @import rlang -#' @importFrom broom.helpers .select_to_varnames #' @importFrom dplyr across +#' @importFrom glue glue "_PACKAGE" ## usethis namespace: start diff --git a/R/import-standalone-check_pkg_installed.R b/R/import-standalone-check_pkg_installed.R new file mode 100644 index 0000000000..7f1cd7a890 --- /dev/null +++ b/R/import-standalone-check_pkg_installed.R @@ -0,0 +1,203 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: ddsjoberg/standalone +# file: standalone-check_pkg_installed.R +# last-updated: 2024-04-15 +# license: https://unlicense.org +# dependencies: standalone-cli_call_env.R +# imports: [rlang, dplyr, tidyr] +# --- +# +# This file provides functions to check package installation. +# +# ## Changelog +# nocov start +# styler: off + +#' Check Package Installation +#' +#' @description +#' - `check_pkg_installed()`: checks whether a package is installed and +#' returns an error if not available, or interactively asks user to install +#' missing dependency. If a package search is provided, +#' the function will check whether a minimum version of a package is required and installed. +#' +#' - `is_pkg_installed()`: checks whether a package is installed and +#' returns `TRUE` or `FALSE` depending on availability. If a package search is provided, +#' the function will check whether a minimum version of a package is required and installed. +#' +#' - `get_pkg_dependencies()` returns a tibble with all +#' dependencies of a specific package. +#' +#' - `get_min_version_required()` will return, if any, the minimum version +#' of `pkg` required by `reference_pkg`. +#' +#' @param pkg (`character`)\cr +#' vector of package names to check. +#' @param call (`environment`)\cr +#' frame for error messaging. Default is [get_cli_abort_call()]. +#' @param reference_pkg (`string`)\cr +#' name of the package the function will search for a minimum required version from. +#' @param lib.loc (`path`)\cr +#' location of `R` library trees to search through, see [utils::packageDescription()]. +#' +#' @return `is_pkg_installed()` and `check_pkg_installed()` returns a logical or error, +#' `get_min_version_required()` returns a data frame with the minimum version required, +#' `get_pkg_dependencies()` returns a tibble. +#' +#' @examples +#' check_pkg_installed("dplyr") +#' +#' is_pkg_installed("dplyr") +#' +#' get_pkg_dependencies() +#' +#' get_min_version_required("dplyr") +#' +#' @name check_pkg_installed +#' @noRd +NULL + +#' @inheritParams check_pkg_installed +#' @keywords internal +#' @noRd +check_pkg_installed <- function(pkg, + reference_pkg = "cards", + call = get_cli_abort_call()) { + # check inputs --------------------------------------------------------------- + check_not_missing(pkg) + check_class(pkg, cls = "character") + check_string(reference_pkg, allow_empty = TRUE) + + # get min version data ------------------------------------------------------- + df_pkg_min_version <- + get_min_version_required(pkg = pkg, reference_pkg = reference_pkg, call = call) + + # prompt user to install package --------------------------------------------- + rlang::check_installed( + pkg = df_pkg_min_version$pkg, + version = df_pkg_min_version$version, + compare = df_pkg_min_version$compare, + call = call + ) |> + # this can be removed after this issue is resolved https://github.com/r-lib/rlang/issues/1694 + suppressWarnings() +} + +#' @inheritParams check_pkg_installed +#' @keywords internal +#' @noRd +is_pkg_installed <- function(pkg, + reference_pkg = "cards", + call = get_cli_abort_call()) { + # check inputs --------------------------------------------------------------- + check_not_missing(pkg) + check_class(pkg, cls = "character") + check_string(reference_pkg, allow_empty = TRUE) + + # get min version data ------------------------------------------------------- + df_pkg_min_version <- + get_min_version_required(pkg = pkg, reference_pkg = reference_pkg, call = call) + + # check installation TRUE/FALSE ---------------------------------------------- + rlang::is_installed( + pkg = df_pkg_min_version$pkg, + version = df_pkg_min_version$version, + compare = df_pkg_min_version$compare + ) |> + # this can be removed after this issue is resolved https://github.com/r-lib/rlang/issues/1694 + suppressWarnings() +} + +#' @inheritParams check_pkg_installed +#' @keywords internal +#' @noRd +get_pkg_dependencies <- function(reference_pkg = "cards", lib.loc = NULL, call = get_cli_abort_call()) { + check_string(reference_pkg, allow_empty = TRUE, call = call) + + if (rlang::is_empty(reference_pkg)) { + return(.empty_pkg_deps_df()) + } + + description <- utils::packageDescription(reference_pkg, lib.loc = lib.loc) |> suppressWarnings() + if (identical(description, NA)) { + return(.empty_pkg_deps_df()) + } + description |> + unclass() |> + dplyr::as_tibble() |> + dplyr::select( + dplyr::any_of(c( + "Package", "Version", "Imports", "Depends", + "Suggests", "Enhances", "LinkingTo" + )) + ) |> + dplyr::rename( + reference_pkg = "Package", + reference_pkg_version = "Version" + ) |> + tidyr::pivot_longer( + -dplyr::all_of(c("reference_pkg", "reference_pkg_version")), + values_to = "pkg", + names_to = "dependency_type", + ) |> + tidyr::separate_rows("pkg", sep = ",") |> + dplyr::mutate(pkg = str_squish(.data$pkg)) |> + dplyr::filter(!is.na(.data$pkg)) |> + tidyr::separate( + .data$pkg, + into = c("pkg", "version"), + sep = " ", extra = "merge", fill = "right" + ) |> + dplyr::mutate( + compare = .data$version |> str_extract(pattern = "[>=<]+"), + version = .data$version |> str_remove_all(pattern = "[\\(\\) >=<]") + ) +} + +.empty_pkg_deps_df <- function() { + dplyr::tibble( + reference_pkg = character(0L), reference_pkg_version = character(0L), + dependency_type = character(0L), pkg = character(0L), + version = character(0L), compare = character(0L) + ) +} + +#' @inheritParams check_pkg_installed +#' @keywords internal +#' @noRd +get_min_version_required <- function(pkg, reference_pkg = "cards", + lib.loc = NULL, call = get_cli_abort_call()) { + check_not_missing(pkg, call = call) + check_class(pkg, cls = "character", call = call) + check_string(reference_pkg, allow_empty = TRUE, call = call) + + # if no package reference, return a df with just the pkg names + if (rlang::is_empty(reference_pkg)) { + return( + .empty_pkg_deps_df() |> + dplyr::full_join( + dplyr::tibble(pkg = pkg), + by = "pkg" + ) + ) + } + + # get the package_ref deps and subset on requested pkgs, also supplement df with pkgs + # that may not be proper deps of the reference package (these pkgs don't have min versions) + res <- + get_pkg_dependencies(reference_pkg, lib.loc = lib.loc) |> + dplyr::filter(.data$pkg %in% .env$pkg) |> + dplyr::full_join( + dplyr::tibble(pkg = pkg), + by = "pkg" + ) + + res +} + +# nocov end +# styler: on diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index 497acc6836..5d13798221 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -5,8 +5,9 @@ # --- # repo: ddsjoberg/standalone # file: standalone-checks.R -# last-updated: 2024-01-24 +# last-updated: 2024-04-10 # license: https://unlicense.org +# dependencies: standalone-cli_call_env.R # imports: [rlang, cli] # --- # @@ -19,11 +20,13 @@ #' Check Class #' -#' @param class (`character`)\cr +#' @param cls (`character`)\cr #' character vector or string indicating accepted classes. -#' Passed to `inherits(what=class)` +#' Passed to `inherits(what=cls)` #' @param x `(object)`\cr #' object to check +#' @param message (`character`)\cr +#' string passed to `cli::cli_abort(message)` #' @param allow_empty (`logical(1)`)\cr #' Logical indicating whether an empty value will pass the test. #' Default is `FALSE` @@ -31,22 +34,32 @@ #' string indicating the label/symbol of the object being checked. #' Default is `rlang::caller_arg(x)` #' @inheritParams cli::cli_abort +#' @inheritParams rlang::abort #' @keywords internal #' @noRd -check_class <- function(x, class, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be class - {.cls {class}}, not {.obj_type_friendly {x}}.", +check_class <- function(x, + cls, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), arg_name = rlang::caller_arg(x), - call = parent.frame()) { + class = "check_class", + call = get_cli_abort_call()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { - return(invisible()) + return(invisible(x)) } - if (!inherits(x, class)) { - cli::cli_abort(message, call = call) + if (!inherits(x, cls)) { + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) } #' Check Class Data Frame @@ -54,13 +67,22 @@ check_class <- function(x, class, allow_empty = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_data_frame <- function(x, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be class - {.cls {class}}, not {.obj_type_friendly {x}}.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_data_frame <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_data_frame", + call = get_cli_abort_call()) { check_class( - x = x, class = "data.frame", allow_empty = allow_empty, - message = message, arg_name = arg_name, call = call + x = x, cls = "data.frame", allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call ) } @@ -69,13 +91,22 @@ check_data_frame <- function(x, allow_empty = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_logical <- function(x, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be class - {.cls {class}}, not {.obj_type_friendly {x}}.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_logical <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_logical", + call = get_cli_abort_call()) { check_class( - x = x, class = "logical", allow_empty = allow_empty, - message = message, arg_name = arg_name, call = call + x = x, cls = "logical", allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call ) } @@ -84,14 +115,23 @@ check_logical <- function(x, allow_empty = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_scalar_logical <- function(x, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be a scalar with class - {.cls {class}}, not {.obj_type_friendly {x}}.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_scalar_logical <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a scalar with class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be a scalar with class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_scalar_logical", + call = get_cli_abort_call()) { check_logical( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, - call = call + class = class, call = call ) check_scalar( @@ -106,20 +146,29 @@ check_scalar_logical <- function(x, allow_empty = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_string <- function(x, allow_empty = FALSE, - message = "The {.arg {arg_name}} argument must be a string, - not {.obj_type_friendly {x}}.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_string <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a string or empty, + not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be a string, + not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_string", + call = get_cli_abort_call()) { check_class( - x = x, class = "character", allow_empty = allow_empty, + x = x, cls = "character", allow_empty = allow_empty, message = message, arg_name = arg_name, - call = call + class = class, call = call ) check_scalar( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, - call = call + class = class, call = call ) } @@ -130,17 +179,19 @@ check_string <- function(x, allow_empty = FALSE, #' @noRd check_not_missing <- function(x, message = "The {.arg {arg_name}} argument cannot be missing.", - arg_name = rlang::caller_arg(x), call = parent.frame()) { + arg_name = rlang::caller_arg(x), + class = "check_not_missing", + call = get_cli_abort_call()) { if (missing(x)) { - cli::cli_abort(message, call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } + + # can't return 'x' because it may be an unevaluable obj, eg a bare tidyselect invisible() } #' Check Length #' -#' @param msg (`string`)\cr -#' string passed to `cli::cli_abort(message=)` #' @param length (`integer(1)`)\cr #' integer specifying the required length #' @inheritParams check_class @@ -154,39 +205,42 @@ check_length <- function(x, length, "The {.arg {arg_name}} argument must be length {.val {length}}." ), allow_empty = FALSE, - arg_name = rlang::caller_arg(x), call = parent.frame()) { + arg_name = rlang::caller_arg(x), + class = "check_length", + call = get_cli_abort_call()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { - return(invisible()) + return(invisible(x)) } # check length if (length(x) != length) { - cli::cli_abort(message, call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) } #' Check is Scalar #' -#' @param msg (`string`)\cr -#' string passed to `cli::cli_abort(message=)` #' @inheritParams check_class #' @keywords internal #' @noRd check_scalar <- function(x, + allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", "The {.arg {arg_name}} argument must be length {.val {length}}." ), - allow_empty = FALSE, - arg_name = rlang::caller_arg(x), call = parent.frame()) { + arg_name = rlang::caller_arg(x), + class = "check_scalar", + call = get_cli_abort_call()) { check_length( x = x, length = 1L, message = message, - allow_empty = allow_empty, arg_name = arg_name, call = call + allow_empty = allow_empty, arg_name = arg_name, + class = class, call = call ) } @@ -196,8 +250,7 @@ check_scalar <- function(x, #' @param range numeric vector of length two #' @param include_bounds logical of length two indicating whether to allow #' the lower and upper bounds -#' @param scalar logical indicating whether `x` must be a scalar -#' @param msg string passed to `cli::cli_abort(message=)` +#' @inheritParams check_class #' #' @return invisible #' @keywords internal @@ -206,23 +259,16 @@ check_range <- function(x, range, include_bounds = c(FALSE, FALSE), message = - paste0( - "The {.arg {arg_name}} argument must be in the interval + "The {.arg {arg_name}} argument must be in the interval {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, - {range[2]}{ifelse(include_bounds[2], ']', ')')}}", - ifelse(scalar, " and length {.val {1}}", ""), - "."), - scalar = FALSE, + {range[2]}{ifelse(include_bounds[2], ']', ')')}}.", allow_empty = FALSE, arg_name = rlang::caller_arg(x), - call = parent.frame()) { + class = "check_range", + call = get_cli_abort_call()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { - return(invisible()) - } - - if (isTRUE(scalar)) { - check_scalar(x, message = message, arg_name = arg_name, call = call) + return(invisible(x)) } print_error <- FALSE @@ -249,12 +295,42 @@ check_range <- function(x, # print error if (print_error) { - cli::cli_abort(message, call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) } +#' Check Scalar Range +#' +#' @param x numeric scalar to check +#' @param range numeric vector of length two +#' @param include_bounds logical of length two indicating whether to allow +#' the lower and upper bounds +#' @inheritParams check_class +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_scalar_range <- function(x, + range, + include_bounds = c(FALSE, FALSE), + allow_empty = FALSE, + message = + "The {.arg {arg_name}} argument must be in the interval + {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, + {range[2]}{ifelse(include_bounds[2], ']', ')')}} + and length {.val {1}}.", + arg_name = rlang::caller_arg(x), + class = "check_scalar_range", + call = get_cli_abort_call()) { + check_scalar(x, message = message, arg_name = arg_name, + allow_empty = allow_empty, class = class, call = call) + + check_range(x = x, range = range, include_bounds = include_bounds, + message = message, allow_empty = allow_empty, + arg_name = arg_name, class = class, call = call) +} #' Check Binary #' @@ -263,32 +339,88 @@ check_range <- function(x, #' `` and coded as `c(0, 1)` #' #' @param x a vector -#' @param call call environment +#' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd check_binary <- function(x, - message = - "Expecting {.arg {arg_name}} to be either {.cls logical} - or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}.", allow_empty = FALSE, - arg_name = rlang::caller_arg(x), call = parent.frame()) { + message = + ifelse( + allow_empty, + "Expecting {.arg {arg_name}} to be either {.cls logical}, + {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}, or empty.", + "Expecting {.arg {arg_name}} to be either {.cls logical} + or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_binary", + call = get_cli_abort_call()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { - return(invisible()) + return(invisible(x)) } # first check x is either logical or numeric - check_class(x, class = c("logical", "numeric", "integer"), - arg_name = arg_name, message = message, call = call) + check_class(x, cls = c("logical", "numeric", "integer"), + arg_name = arg_name, message = message, class = class, call = call) # if "numeric" or "integer", it must be coded as 0, 1 if (!is.logical(x) && !(rlang::is_integerish(x) && rlang::is_empty(setdiff(x, c(0, 1, NA))))) { - cli::cli_abort(message, call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) +} + + +#' Check Formula-List Selector +#' +#' Checks the structure of the formula-list selector used throughout the +#' cards, cardx, and gtsummary packages. +#' +#' @param x formula-list selecting object +#' @inheritParams check_class +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_formula_list_selector <- function(x, + allow_empty = FALSE, + message = + c( + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a named list, list of formulas, a single formula, or empty.", + "The {.arg {arg_name}} argument must be a named list, list of formulas, or a single formula." + ), + "i" = "Review {.help [?syntax](cards::syntax)} for examples and details." + ), + arg_name = rlang::caller_arg(x), + class = "check_formula_list_selector", + call = get_cli_abort_call()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) + } + + # first check the general structure; must be a list or formula + check_class( + x = x, cls = c("list", "formula"), allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call + ) + + # if it's a list, then check each element is either named or a formula + if (inherits(x, "list")) { + for (i in seq_along(x)) { + if (!rlang::is_named(x[i]) && !inherits(x[[i]], "formula")) { + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + } + } + } + + invisible(x) } # nocov end diff --git a/R/import-standalone-cli_call_env.R b/R/import-standalone-cli_call_env.R new file mode 100644 index 0000000000..88ccd69348 --- /dev/null +++ b/R/import-standalone-cli_call_env.R @@ -0,0 +1,53 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: ddsjoberg/standalone +# file: standalone-cli_call_env.R +# last-updated: 2024-04-10 +# license: https://unlicense.org +# imports: [rlang, cli] +# --- +# +# This file provides functions to set and access the call environment to use in cli::cli_abort() in check functions. +# +# ## Changelog +# nocov start +# styler: off + +#' Set Call Environment for [cli::cli_abort()] +#' +#' Set a call environment to be used as the `call` parameter in [cli::cli_abort()] for package checks. This function +#' is used to ensure that the correct user-facing function is reported for errors generated by internal checks that +#' use [cli::cli_abort()]. +#' +#' @param env (`enviroment`)\cr +#' call environment used as the `call` parameter in [cli::cli_abort()] for package checks +#' +#' @seealso [get_cli_abort_call()] +#' +#' @keywords internal +#' @noRd +set_cli_abort_call <- function(env = rlang::caller_env()) { + if (getOption("cli_abort_call") |> is.null()) { + options(cli_abort_call = env) + set_call <- as.call(list(function() options(cli_abort_call = NULL))) + do.call(on.exit, list(expr = set_call, after = FALSE), envir = env) + } + invisible() +} + +#' Get Call Environment for [cli::cli_abort()] +#' +#' @inheritParams set_cli_abort_call +#' @seealso [set_cli_abort_call()] +#' +#' @keywords internal +#' @noRd +get_cli_abort_call <- function() { + getOption("cli_abort_call", default = parent.frame()) +} + +# nocov end +# styler: on diff --git a/R/import-standalone-stringr.R b/R/import-standalone-stringr.R new file mode 100644 index 0000000000..263bde5bcf --- /dev/null +++ b/R/import-standalone-stringr.R @@ -0,0 +1,48 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# file: standalone-stringr.R +# last-updated: 2024-01-24 +# license: https://unlicense.org +# imports: rlang +# --- +# +# This file provides a minimal shim to provide a stringr-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# nocov start +# styler: off + +str_trim <- function(string, side = c("both", "left", "right")) { + side <- rlang::arg_match(side) + trimws(x = string, which = side, whitespace = "[ \t\r\n]") +} + +str_squish <- function(string) { + gsub(x = string, pattern = "\\s+", replacement = " ") |> + str_trim(side = "both") +} + +str_remove_all <- function(string, pattern) { + gsub(x = string, pattern = pattern, replacement = "") +} + +str_extract <- function(string, pattern) { + ifelse( + str_detect(string, pattern), + regmatches(x = string, m = regexpr(pattern = pattern, text = string)), + NA_character_ + ) +} + +str_detect <- function(string, pattern) { + grepl(pattern = pattern, x = string) +} + +# nocov end +# styler: on diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index 37d568a0ee..d3200abcd5 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -23,6 +23,7 @@ NULL #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @export modify_column_hide <- function(x, columns) { + set_cli_abort_call() check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) x <- @@ -39,6 +40,7 @@ modify_column_hide <- function(x, columns) { #' @rdname modify_column_hide #' @export modify_column_unhide <- function(x, columns) { + set_cli_abort_call() check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) x <- diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R index 04ba7e36e0..8ba71f0a40 100644 --- a/R/modify_fmt_fun.R +++ b/R/modify_fmt_fun.R @@ -29,6 +29,7 @@ # #' ) # #' } modify_fmt_fun <- function(x, update, rows = NULL) { + set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) check_class(x, "gtsummary") diff --git a/R/modify_table_body.R b/R/modify_table_body.R new file mode 100644 index 0000000000..3a42a47ba7 --- /dev/null +++ b/R/modify_table_body.R @@ -0,0 +1,58 @@ +#' Modify Table Body +#' +#' @description +#' Function is for advanced manipulation of gtsummary tables. +#' It allow users to modify the `.$table_body` data frame included +#' in each gtsummary object. +#' +#' If a new column is added to the table, default printing instructions will then +#' be added to `.$table_styling`. By default, columns are hidden. +#' To show a column, add a column header with `modify_header()`. +#' +#' @param x gtsummary object +#' @param fun A function or formula. If a _function_, it is used as is. +#' If a _formula_, e.g. `fun = ~ .x %>% arrange(variable)`, +#' it is converted to a function. The argument passed to `fun=` is `x$table_body`. +#' @param ... Additional arguments passed on to the mapped function +#' +#' @export +#' +#' @examples +#' # Example 1 -------------------------------- +# #' # Add number of cases and controls to regression table +# #' modify_table_body_ex1 <- +# #' trial %>% +# #' select(response, age, marker) %>% +# #' tbl_uvregression( +# #' y = response, +# #' method = glm, +# #' method.args = list(family = binomial), +# #' exponentiate = TRUE, +# #' hide_n = TRUE +# #' ) %>% +# #' # adding number of non-events to table +# #' modify_table_body( +# #' ~ .x %>% +# #' dplyr::mutate(N_nonevent = N_obs - N_event) %>% +# #' dplyr::relocate(c(N_event, N_nonevent), .before = estimate) +# #' ) %>% +# #' # assigning header labels +# #' modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") %>% +# #' modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) +#' @export +#' @family Advanced modifiers +modify_table_body <- function(x, fun, ...) { + set_cli_abort_call() + check_class(x, "gtsummary") + updated_call_list <- c(x$call_list, list(modify_table_body = match.call())) + + # execute function on x$table_body ------------------------------------------- + x$table_body <- map(.x = list(x$table_body), .f = fun, ...)[[1]] + + # update table_styling ------------------------------------------------------- + x <- .update_table_styling(x) + + # return gtsummary object ---------------------------------------------------- + x$call_list <- updated_call_list + x +} diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index ff05b6e2b4..dde78c3c3f 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -90,6 +90,7 @@ modify_table_styling <- function(x, indentation = NULL, text_interpret = c("md", "html"), cols_merge_pattern = NULL) { + set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) # checking inputs ------------------------------------------------------------ check_class(x, "gtsummary") @@ -168,12 +169,16 @@ modify_table_styling <- function(x, x <- .update_table_styling(x) # convert column input to string --------------------------------------------- - columns <- - .select_to_varnames( - select = {{ columns }}, - data = x$table_body, - arg_name = "columns" - ) + cards::process_selectors( + data = x$table_body, + columns = {{ columns }} + ) + # columns <- + # broom.helpers::.select_to_varnames( + # select = {{ columns }}, + # data = x$table_body, + # arg_name = "columns" + # ) # if no columns selected, returning unaltered if (is.null(columns)) { diff --git a/R/reexport.R b/R/reexport.R index d0b9e13c77..9c1c271be2 100644 --- a/R/reexport.R +++ b/R/reexport.R @@ -59,6 +59,7 @@ dplyr::where #' @export dplyr::one_of +# Remove after Jan 1, 2025 #' @importFrom dplyr vars #' @export dplyr::vars diff --git a/R/select_helpers.R b/R/select_helpers.R index 3f1e26abcf..86eef01d48 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -1,6 +1,6 @@ #' Select helper functions #' -#' @description Set of functions to supplement the {tidyselect} set of +#' @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"` @@ -11,26 +11,29 @@ #' - `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 -# #' @param tests string indicating the test type of the variables to select, e.g. -# #' select all variables being compared with `"t.test"` -#' @param stat_0 When `FALSE`, will not select the `"stat_0"` column. Default is `TRUE` -#' @param continuous2 Logical indicating whether to include continuous2 variables. Default is `TRUE` -#' @param dichotomous Logical indicating whether to include dichotomous variables. -#' Default is `TRUE` -# #' @param contrasts_type type of contrast to select. When `NULL`, all variables with a -# #' contrast will be selected. Default is `NULL`. Select among contrast types -# #' `c("treatment", "sum", "poly", "helmert", "other")` +#' +#' @param stat_0 (scalar `logical`)\cr +#' When `FALSE`, will not select the `"stat_0"` column. Default is `TRUE` +#' @param continuous2 (scalar `logical`)\cr +#' Logical indicating whether to include continuous2 variables. Default is `TRUE` +#' @param dichotomous (scalar `logical`)\cr +#' Logical indicating whether to include dichotomous variables. Default is `TRUE` +#' @param tests (`character`)\cr +#' character vector indicating the test type of the variables to select, e.g. +#' select all variables being compared with `"t.test"`. +#' #' @name select_helpers #' @return A character vector of column names selected +#' #' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary -# #' @examples -# #' select_ex1 <- -# #' trial %>% -# #' select(age, response, grade) %>% -# #' tbl_summary( -# #' statistic = all_continuous() ~ "{mean} ({sd})", -# #' type = all_dichotomous() ~ "categorical" -# #' ) +#' @examples +#' select_ex1 <- +#' trial |> +#' select(age, response, grade) |> +#' tbl_summary( +#' statistic = all_continuous() ~ "{mean} ({sd})", +#' type = all_dichotomous() ~ "categorical" +#' ) NULL #' @rdname select_helpers @@ -61,6 +64,12 @@ all_dichotomous <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "dichotomous")) } +#' @rdname select_helpers +#' @export +all_tests <- function(tests) { + where(function(x) isTRUE(attr(x, "gtsummary.test_name") %in% tests)) +} + # #' @rdname select_helpers # #' @export # all_tests <- function(tests = NULL) { @@ -131,7 +140,7 @@ all_stat_cols <- function(stat_0 = TRUE) { select_prep <- function(table_body, data = NULL) { # if data not passed, use table_body to construct one if (is.null(data)) { - data <- dplyr::tibble(!!!rep_named(table_body$variable, character(0L))) + data <- dplyr::tibble(!!!rep_named(unique(table_body$variable), logical(0L))) } # only keeping rows that have corresponding column names in data @@ -152,6 +161,23 @@ select_prep <- function(table_body, data = NULL) { } +#' Convert character vector to data frame +#' +#' This is used in some of the selecting we allow for, for example in +#' `as_gt(include=)` you can use tidyselect to select among the call +#' names to include. +#' +#' @param x character vector +#' +#' @return data frame +#' @keywords internal +vec_to_df <- function(x) { + matrix(ncol = length(x), nrow = 0) |> + data.frame() |> + stats::setNames(x) +} + + # converts a named list to a table_body format. # the result of this fn will often be passed to `select_prep()` #' Convert Named List to Table Body diff --git a/R/styfn.R b/R/styfn.R index 3067c99941..b4409a5c68 100644 --- a/R/styfn.R +++ b/R/styfn.R @@ -30,7 +30,7 @@ styfn_sigfig <- function(digits = 2, scale = 1, big.mark = NULL, decimal.mark = #' @rdname styfn #' @export styfn_pvalue <- function(digits = 1, prepend_p = FALSE, big.mark = NULL, decimal.mark = NULL, ...) { - function(x) styfn_pvalue(x, digits = digits, prepend_p = prepend_p, big.mark = big.mark, decimal.mark = decimal.mark, ...) + function(x) style_pvalue(x, digits = digits, prepend_p = prepend_p, big.mark = big.mark, decimal.mark = decimal.mark, ...) } #' @rdname styfn diff --git a/R/style_number.R b/R/style_number.R index 825dcf6cf7..2e9b74f9cf 100644 --- a/R/style_number.R +++ b/R/style_number.R @@ -20,6 +20,8 @@ #' c(0.111, 12.3) %>% style_number(digits = c(1, 0)) style_number <- function(x, digits = 0, big.mark = NULL, decimal.mark = NULL, scale = 1, ...) { + set_cli_abort_call() + # setting defaults ----------------------------------------------------------- decimal.mark <- decimal.mark %||% diff --git a/R/style_percent.R b/R/style_percent.R index b0c1cb075d..ba6686f8d1 100644 --- a/R/style_percent.R +++ b/R/style_percent.R @@ -17,6 +17,7 @@ #' style_percent(percent_vals) #' style_percent(percent_vals, symbol = TRUE, digits = 1) style_percent <- function(x, symbol = FALSE, digits = 0, big.mark = NULL, decimal.mark = NULL, ...) { + set_cli_abort_call() y <- dplyr::case_when( x * 100 >= 10 ~ style_number(x * 100, digits = digits, big.mark = big.mark, decimal.mark = decimal.mark, ...), x * 100 >= 10^(-(digits + 1)) ~ style_number(x * 100, digits = digits + 1, big.mark = big.mark, decimal.mark = decimal.mark, ...), diff --git a/R/style_pvalue.R b/R/style_pvalue.R index 1a634737d8..30f1b69267 100644 --- a/R/style_pvalue.R +++ b/R/style_pvalue.R @@ -20,6 +20,7 @@ #' style_pvalue(pvals, digits = 2, prepend_p = TRUE) style_pvalue <- function(x, digits = 1, prepend_p = FALSE, big.mark = NULL, decimal.mark = NULL, ...) { + set_cli_abort_call() # rounding large p-values to 1 digits if (digits == 1) { p_fmt <- diff --git a/R/style_ratio.R b/R/style_ratio.R index 7d472b8464..05dff7310c 100644 --- a/R/style_ratio.R +++ b/R/style_ratio.R @@ -23,6 +23,7 @@ #' ) %>% #' style_ratio() style_ratio <- function(x, digits = 2, big.mark = NULL, decimal.mark = NULL, ...) { + set_cli_abort_call() x_fmt <- dplyr::case_when( round2(abs(x), digits = digits) < 1 ~ diff --git a/R/style_sigfig.R b/R/style_sigfig.R index 3d7a4808d5..70212f2222 100644 --- a/R/style_sigfig.R +++ b/R/style_sigfig.R @@ -32,6 +32,7 @@ #' c(0.123, 0.9, 1.1234, 12.345, -0.123, -0.9, -1.1234, -132.345, NA, -0.001) %>% #' style_sigfig() style_sigfig <- function(x, digits = 2, scale = 1, big.mark = NULL, decimal.mark = NULL, ...) { + set_cli_abort_call() # calculating the number of digits to round number d <- paste0( @@ -39,9 +40,7 @@ style_sigfig <- function(x, digits = 2, scale = 1, big.mark = NULL, decimal.mark "< 10^(", 1:digits - 1, ") - 0.5 * 10^(", -(digits:1), ") ~ ", digits:1, collapse = ", " ) %>% - { - paste0("dplyr::case_when(", ., ", TRUE ~ 0)") - } %>% + {paste0("dplyr::case_when(", ., ", TRUE ~ 0)")} %>% # styler: off # converting strings into expressions to run parse(text = .) %>% eval() diff --git a/R/sysdata.rda b/R/sysdata.rda new file mode 100644 index 0000000000000000000000000000000000000000..0fcf7b2ea6d142b6557dfd7ec712caa5c81a10bd GIT binary patch literal 3030 zcmV;{3n}zMT4*^jL0KkKS$f83$p8=m|Nj5~|Nr;z|G&TQ|IYva|M@@wfB`@d0Duqz z0ssI3;0_*qKKlr(q0)j!Cv)4IuFiJBT>uuqPz3Uu*%(i%NYGynhq00000 z000000z{J_iIGpyJtk4KjP*98WO@)7N2p-{WO|!TH9bJ|^)&-SOoJcD%()E=N@ zXvv@frh$+e8UWBVXfzrP10c`U@1u4soDjcSYZ;Fu!0lo@IKrVxk6%BOm`gDYi5K+!0K+6inMdjH*UI0AX z4C60MhsU0m?93h)rA!C_NFfM3j>BTv0K61wUO}5nH+Ko0+>ZVfL_{_Y(5?wvD6`0k zTV%K$w>u9}N7;3gHHa5xooF)3&I6FeJ1U<_gYUJXCIcUrok0`Lu7k@E(kYPtpZ;G% z2_PRe0p<`Qu4u#+kVz2$kW`UHkOn{`0E|Kr0ze87Wgsy`l0aC5A`%3M!F!^DtWBh) z{JY~)0u!1?31IDtLubfs5^yjWReTuXhf1;qXR>aJ3eM>Zh=Vhf4Gu3?s`!!^Oc5eW ziaKglS@bBVR3>kJ^D_wsK!PrJCk*K!cMke*m0D_y%}C#0MkhxVvVQk1IgpUcfnv~{ zRMkR)^+=+20tGUtNHnIg$dV2rIudZ4A_R(jO1yxPkR(HFN|FVl!49a3FLDZ`6%jfd zN^9o!a;s1(kz|pv8qorzM3EITgn$u%NJxOlfG~p=A)G_m0kjcRJRpiM`AlK0iOoS{VpG$ru}VtcuT(7Xugwa&j0x5@QyWfFfeRfm;^HrHaCO>(+GToEmH28!svDmdaY{NtviXa+1nm1e0Fi zfU+I9AT|u(0@rG^j7RG}Eh4q8_SU4xt#_H5Oo6wFBlZBe8oeM4UKC>^2thGFTl9mD zA7Xq9WGiCTtQK3Aw3w0;?7^~$GazAl&oLT+#Ue1j*D3&?V=HO^bdq6^30K!E(WpYC zB?5L8E#%57(fmyY;5&%47o2WebtfHv*qf`B@~#X8-F?0(>2iPHhj(}~0f{mO2uxkH z34WUL22Jq=)JeV@lKtzOZZ>>%ki2HpO3k7#5{rbpjH46P4{7K!<(Ida*g>3G7-eEq zxj$#5&)RIm7$BH+_fYz@N zcx+6zr_JUM4qWoAEm{0}@NnnQGlFokzQ3B)a$K3U8x#T57Zphgz`l@P2_X9Nl>!*R z!dlA~!)O@oG$lfb0-C_z3jz1d%c67kr0|m!__+<`_y>%#xEIha3?k?+Tj)mdWLXFr zv8c8S4^VZETrlY|GO*G@g07vRfCdG;3=0||t{ls9%Zeg|? z1BlXhi31gFTam;)B(Rte1GEo7kVDhgI<^Ctny~Wf+hoA8MY=eP5q0n|Ja$ia$e%7) zo7ZSL`15;4G!xa;dB=L!+r^Si4NF#Q_#0d;3@Zs zmnPhW+>^6n>V7T9iRXI9jMiLx`NIV7)PanWFgdn}U}}-#KNmP~P|bH7_XiZq&aaU+ zp^Askf#?IO=>B8e=c0F*rz#yDKxknIK}tn*JiwL)$Qxjxuqg^O6M+KAew`b`B-nEj zPe&Y#WTSpYt_%oFYqHyQEMO&iEfWzX;==;U7$~BFW|?~i&02^tE9nJ2*2X7rvkVDi z#zui!2xf3O2A0UC@p1L>PCP`(4;UGdEN2ntwMDT~qo;k#Nsl?K;_WLg zXbV5$_bn(~kh(dPI_!nuxh)q`C{clA3!a(a(I(T*dF&T7U40t_;r@_5d4l=^CZvwB zh^xeUjauMS_f>|Eyo+ui7{wa?9H6!Fe>RSeZ0_QV8)Bxqg z9)O_|rr@80_})hRC!5F09$>E(^|*j?(W;P8D=X2nDXpQa#k5&>Yv}cDP{swQ$7w_) z0zy#|l0=IbQ6VF}D!aBHzE7NasWMLEt3)+w0zsO?a26mLr>w*S9YqxQ#ML+1g8(9H~f=~bd`_cRpqBQyvfSl%DF4bbFA0B{19yl2#&+x(tZ z-qZEo!{)i(zy`w#kfj=$+QM9hBsPd=g{!P!k_gwDiA5#^0=;#9x>V^pd-J(-i_&Le zQI}bW8#AG(goJ>|>q*2a`F~)r?Ac1bp3B9*I;EJgERF_Y179Z?@uA5OeUKjVa*!mD zBq1u0kq?{e({K!N3U;B@2ii}a5GwR^CSkzq-n}sDNbf-9<>vKF;_0Z4!Wg5LW|u7PsP)j0K1 z)j!o0Rw{=g|1v%vO)={(^b literal 0 HcmV?d00001 diff --git a/R/tbl_summary.R b/R/tbl_summary.R index dd5467e6a9..ca1f1b84d6 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -46,9 +46,11 @@ #' Specifies sorting to perform for categorical variables. #' Values must be one of `c("alphanumeric", "frequency")`. #' Default is `all_categorical(FALSE) ~ "alphanumeric"` -#' @param percent Indicates the type of percentage to return. +#' @param percent (`string`)\cr +#' Indicates the type of percentage to return. #' Must be one of `c("column", "row", "cell")`. Default is `"column"`. -#' @param include Variables to include in the summary table. Default is `everything()` +#' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variables to include in the summary table. Default is `everything()` #' #' @return a gtsummary table of class `"tbl_summary"` #' @export @@ -168,6 +170,7 @@ tbl_summary <- function(data, sort = all_categorical(FALSE) ~ "alphanumeric", percent = c("column", "row", "cell"), include = everything()) { + set_cli_abort_call() # data argument checks ------------------------------------------------------- check_not_missing(data) check_data_frame(data) @@ -265,9 +268,9 @@ tbl_summary <- function(data, } # check inputs --------------------------------------------------------------- - check_class(missing_text, class = "character") + check_class(missing_text, cls = "character") check_scalar(missing_text) - check_class(missing_stat, class = "character") + check_class(missing_stat, cls = "character") check_scalar(missing_stat) .check_haven_labelled(data[c(include, by)]) .check_tbl_summary_args( @@ -380,7 +383,7 @@ tbl_summary <- function(data, data[!obs_to_drop, ] } -.check_stats_available <- function(x, call = parent.frame()) { +.check_stats_available <- function(x) { # TODO: this could be made more accurate by grouping the cards data frame by the group##_level columns x$inputs$statistic |> imap( @@ -396,7 +399,7 @@ tbl_summary <- function(data, cli::cli_abort( c("Statistic {.val {missing_stats}} is not available for variable {.val {variable}}.", i = "Select among {.val {rev(unique(available_stats))}}."), - call = call + call = get_cli_abort_call() ) } } @@ -456,7 +459,7 @@ tbl_summary <- function(data, unique() %>% { switch(!is.null(.), - paste(., collapse = ", ") + paste(., collapse = "; ") ) } } @@ -495,10 +498,10 @@ tbl_summary <- function(data, } -.data_dim_checks <- function(data, call = rlang::caller_env()) { +.data_dim_checks <- function(data) { # cannot be empty data frame if (nrow(data) == 0L || ncol(data) == 0L) { - cli::cli_abort("Expecting {.arg data} argument to have at least 1 row and 1 column.", call = call) + cli::cli_abort("Expecting {.arg data} argument to have at least 1 row and 1 column.", call = get_cli_abort_call()) } invisible() } @@ -531,7 +534,7 @@ tbl_summary <- function(data, invisible() } -.continuous_statistics_chr_to_fun <- function(statistics, call = parent.frame()) { +.continuous_statistics_chr_to_fun <- function(statistics) { # vector of all the categorical summary function names # these are defined internally, and we don't need to convert them to true fns chr_protected_cat_names <- .categorical_summary_functions() |> @@ -566,7 +569,7 @@ tbl_summary <- function(data, "Problem with the {.arg statistic} argument.", "Error converting string {.val {chr_fun_name}} to a function.", i = "Is the name spelled correctly and available?" - ), call = call) + ), call = get_cli_abort_call()) } ) @@ -584,43 +587,38 @@ tbl_summary <- function(data, } -.check_tbl_summary_args <- function(data, label, statistic, digits, type, value, sort, env = parent.frame()) { +.check_tbl_summary_args <- function(data, label, statistic, digits, type, value, sort) { # first check the structure of each of the inputs ---------------------------- type_accepted <- c("continuous", "continuous2", "categorical", "dichotomous") cards::check_list_elements( x = label, predicate = function(x) is_string(x), - error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a string.", - env = env + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a string." ) cards::check_list_elements( x = statistic, predicate = function(x) is.character(x), - error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a character vector.", - env = env + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be a character vector." ) cards::check_list_elements( x = type, predicate = function(x) is_string(x) && x %in% c("continuous", "continuous2", "categorical", "dichotomous"), error_msg = - "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('continuous', 'continuous2', 'categorical', 'dichotomous')}}.", - env = env + "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('continuous', 'continuous2', 'categorical', 'dichotomous')}}." ) cards::check_list_elements( x = value, predicate = function(x) is.null(x) || length(x) == 1L, - error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be either {.val {NULL}} or a scalar.", - env = env + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be either {.val {NULL}} or a scalar." ) cards::check_list_elements( x = sort, predicate = function(x) is.null(x) || (is_string(x) && x %in% c("alphanumeric", "frequency")), - error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('alphanumeric', 'frequency')}}.", - env = env + error_msg = "Error in argument {.arg {arg_name}} for column {.val {variable}}: value must be one of {.val {c('alphanumeric', 'frequency')}}." ) } diff --git a/R/tests.R b/R/tests.R new file mode 100644 index 0000000000..d2cdef75d1 --- /dev/null +++ b/R/tests.R @@ -0,0 +1,167 @@ +#' Tests/methods available in `add_p()` and `add_difference()` +#' +#' @description Below is a listing of tests available internally within gtsummary. +#' +#' Tests listed with `...` may have additional arguments +#' passed to them using `add_p(test.args=)`. For example, to +#' calculate a p-value from `t.test()` assuming equal variance, use +#' `tbl_summary(trial, by = trt) %>% add_p(age ~ "t.test", test.args = age ~ list(var.equal = TRUE))` +#' +#' @name tests +#' @keywords internal +#' @section `tbl_summary() %>% add_p()`: +#' +#' ```{r, echo = FALSE} +#' options(knitr.kable.NA = '') +#' remove_na_details_column <- function(data) { +#' if (all(is.na(data[["**details**"]]))) return(dplyr::select(data, -`**details**`)) +#' data +#' } +#' +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_summary", add_p == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section `tbl_svysummary() %>% add_p()`: +#' +#' ```{r, echo = FALSE} +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_svysummary", add_p == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section `tbl_survfit() %>% add_p()`: +#' +#' ```{r, echo = FALSE} +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_survfit", add_p == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section `tbl_continuous() %>% add_p()`: +#' +#' ```{r, echo = FALSE} +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_continuous", add_p == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section tbl_summary() %>% add_difference(): +#' +#' ```{r, echo = FALSE} +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_summary", add_difference == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**difference statistic**` = diff_statistic, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section tbl_svysummary() %>% add_difference(): +#' +#' ```{r, echo = FALSE} +#' gtsummary:::df_add_p_tests %>% +#' dplyr::filter(class == "tbl_svysummary", add_difference == TRUE) %>% +#' dplyr::mutate(test_name = shQuote(test_name) %>% {glue::glue('`{.}`')}) %>% +#' select(`**alias**` = test_name, +#' `**description**` = description, +#' `**difference statistic**` = diff_statistic, +#' `**pseudo-code**` = pseudo_code, +#' `**details**` = details) %>% +#' remove_na_details_column() %>% +#' knitr::kable() +#' ``` +#' +#' @section Custom Functions: +#' +#' To report a p-value (or difference) for a test not available in gtsummary, you can create a +#' custom function. The output is a data frame that is one line long. The +#' structure is similar to the output of `broom::tidy()` of a typical +#' statistical test. The `add_p()` and `add_difference()` functions will look for columns called +#' `"p.value"`, `"estimate"`, `"statistic"`, `"std.error"`, `"parameter"`, +#' `"conf.low"`, `"conf.high"`, and `"method"`. +#' +#' You can also pass an Analysis Results Dataset (ARD) object with the results +#' for your custom result. These objects follow the structures outlined +#' by the \{cards\} and \{cardx\} packages. +#' +#' Example calculating a p-value from a t-test assuming a common variance +#' between groups. +#' +#' ```r +#' ttest_common_variance <- function(data, variable, by, ...) { +#' data <- data[c(variable, by)] %>% dplyr::filter(complete.cases(.)) +#' t.test(data[[variable]] ~ factor(data[[by]]), var.equal = TRUE) %>% +#' broom::tidy() +#' } +#' +#' trial[c("age", "trt")] %>% +#' tbl_summary(by = trt) %>% +#' add_p(test = age ~ "ttest_common_variance") +#' ``` +#' +#' A custom `add_difference()` is similar, and accepts arguments `conf.level=` +#' and `adj.vars=` as well. +#' +#' ```r +#' ttest_common_variance <- function(data, variable, by, conf.level, ...) { +#' data <- data[c(variable, by)] %>% dplyr::filter(complete.cases(.)) +#' t.test(data[[variable]] ~ factor(data[[by]]), conf.level = conf.level, var.equal = TRUE) %>% +#' broom::tidy() +#' } +#' ``` +#' +#' ### Function Arguments +#' +#' For `tbl_summary()` objects, the custom function will be passed the +#' following arguments: `custom_pvalue_fun(data=, variable=, by=, group=, type=, conf.level=, adj.vars=)`. +#' While your function may not utilize each of these arguments, these arguments +#' are passed and the function must accept them. We recommend including `...` +#' to future-proof against updates where additional arguments are added. +#' +#' The following table describes the argument inputs for each gtsummary table type. +#' +#' ```{r, echo = FALSE} +#' tibble::tribble( +#' ~`**argument**`, ~`**tbl_summary**`, ~`**tbl_svysummary**`, ~`**tbl_survfit**`, ~`**tbl_continuous**`, +#' "`data=`", "A data frame", "A survey object", "A `survfit()` object", "A data frame", +#' "`variable=`", "String variable name", "String variable name", "`NA`", "String variable name", +#' "`by=`", "String variable name", "String variable name", "`NA`", "String variable name", +#' "`group=`", "String variable name", "`NA`", "`NA`", "String variable name", +#' "`type=`", "Summary type", "Summary type", "`NA`", "`NA`", +#' "`conf.level=`", "Confidence interval level", "`NA`", "`NA`", "`NA`", +#' "`adj.vars=`", "Character vector of adjustment variable names (e.g. used in ANCOVA)", "`NA`", "`NA`", "Character vector of adjustment variable names (e.g. used in ANCOVA)", +#' "`continuous_variable=`", "`NA`", "`NA`", "`NA`", "String of the continuous variable name" +#' ) %>% +#' knitr::kable() +#' ``` +NULL diff --git a/R/utils-add_p_tests.R b/R/utils-add_p_tests.R new file mode 100644 index 0000000000..b67651e545 --- /dev/null +++ b/R/utils-add_p_tests.R @@ -0,0 +1,498 @@ +# add_p.tbl_summary ------------------------------------------------------------ +# TODO: how to handle wilcox test with CIs? add them by default? separate test that includes CIs? + +add_p_test_t.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_t_test( + data = data, + variable = all_of(variable), + by = all_of(by), + conf.level = conf.level, + !!!test.args + ) + ) +} + +add_p_test_wilcox.test <- function(data, variable, by, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_wilcox_test( + data = data, + variable = all_of(variable), + by = all_of(by), + !!!test.args + ) + ) |> + dplyr::mutate( + stat = dplyr::case_when( + .data$stat_name %in% "method" & + .data$stat %in% "Wilcoxon rank sum test with continuity correction" ~ list("Wilcoxon rank sum test"), + .default = .data$stat + ) + ) +} + +add_p_test_mcnemar.test <- function(data, variable, by, group, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("adj.vars"), ...) + check_length(group, 1L) + warn_unbalanced_pairs(data, by, variable, group) + + rlang::inject( + cardx::ard_stats_mcnemar_test_long( + data = data, + variable = all_of(variable), + by = all_of(by), + id = all_of(group), + !!!test.args + ) + ) +} + +add_p_test_mcnemar.test_wide <- function(data, variable, by, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_mcnemar_test( + data = data, + variable = all_of(variable), + by = all_of(by), + !!!test.args + ) + ) +} + +add_p_test_chisq.test <- function(data, variable, by, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_chisq_test( + data = data, + variable = all_of(variable), + by = all_of(by), + !!!test.args + ) + ) |> + dplyr::mutate( + stat = dplyr::case_when( + .data$stat_name %in% "method" & + .data$stat %in% "Pearson's Chi-squared test with Yates' continuity correction" ~ list("Pearson's Chi-squared test"), + .default = .data$stat + ) + ) +} + +add_p_test_chisq.test.no.correct <- function(data, variable, by, test.args, ...) { + add_p_test_chisq.test(data = data, variable = variable, by = by, + test.args = c(list(correct = FALSE), test.args), ...) +} + +add_p_test_mood.test <- function(data, variable, by, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_mood_test( + data = data, + variable = all_of(variable), + by = all_of(by), + !!!test.args + ) + ) +} + + +add_p_test_kruskal.test <- function(data, variable, by, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars", "test.args"), ...) + + cardx::ard_stats_kruskal_test( + data = data, + variable = all_of(variable), + by = all_of(by) + ) +} + +add_p_test_fisher.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_fisher_test( + data = data, + variable = all_of(variable), + by = all_of(by), + conf.level = conf.level, + !!!test.args + ) + ) |> + dplyr::mutate( + stat = dplyr::case_when( + .data$stat_name %in% "method" & + .data$stat %in% "Fisher's Exact Test for Count Data" ~ list("Fisher's exact test"), + .default = .data$stat + ) + ) +} + +add_p_test_aov <- function(data, variable, by, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + cli::cli_warn(c( + "The test {.val aov} in {.code add_p(test)} was deprecated in {.pkg gtsummary} 2.0.0.", + i = "The same functionality is covered with {.val oneway.test}. Use the following code instead:", + i = "{.code add_p(test = list({variable} = 'oneway.test'), test.args = list({variable} = list(var.equal = TRUE)))}." + )) + + add_p_test_oneway.test(data = data, variable = variable, by = by, test.args = list(var.equal = TRUE)) +} + +add_p_test_oneway.test <- function(data, variable, by, test.args, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_oneway_test( + formula = cardx::reformulate2(termlabels = by, response = variable), + data = data, + !!!test.args + ) + ) +} + +add_p_test_mood.test <- function(data, variable, by, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars", "test.args"), ...) + + rlang::inject( + cardx::ard_stats_mood_test( + data = data, + variable = all_of(variable), + by = all_of(by) + ) + ) +} + +add_p_test_lme4 <- function(data, variable, by, group, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_pkg_installed("lme4", reference_pkg = "cardx") + check_null(c("test.args", "adj.vars"), ...) + + if (is_empty(group)) { + cli::cli_abort("The {.arg group} argument cannot be missing for {.val lme4} tests.") + } + check_length(group, 1L) + + cardx::ard_stats_anova( + x = data |> tidyr::drop_na(any_of(c(variable, by, group))), + formulas = list( + glue::glue("as.factor({cardx::bt(by)}) ~ 1 + (1 | {cardx::bt(group)})") |> stats::as.formula(), + glue::glue("as.factor({cardx::bt(by)}) ~ {cardx::bt(variable)} + (1 | {cardx::bt(group)})") |> stats::as.formula() + ), + method = "glmer", + method.args = list(family = stats::binomial), + package = "lme4", + method_text = "random intercept logistic regression" + ) |> + # keep results associated with 2nd model + dplyr::filter(.data$variable %in% dplyr::last(.data$variable)) |> + dplyr::mutate( + variable = .env$variable, + warning = list(NULL) + ) +} + + +add_p_tbl_summary_paired.t.test <- function(data, variable, by, group, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_length(group, 1L) + warn_unbalanced_pairs(data, by, variable, group) + check_null(c("adj.vars"), ...) + + rlang::inject( + cardx::ard_stats_paired_t_test( + data = data, + variable = all_of(variable), + by = all_of(by), + id = all_of(group), + conf.level = conf.level, + !!!test.args + ) + ) +} + +add_p_tbl_summary_paired.wilcox.test <- function(data, variable, by, group, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("adj.vars"), ...) + check_length(group, 1L) + warn_unbalanced_pairs(data, by, variable, group) + + rlang::inject( + cardx::ard_stats_paired_wilcox_test( + data = data, + variable = all_of(variable), + by = all_of(by), + id = all_of(group), + conf.level = conf.level, + !!!test.args + ) + ) +} + +add_p_test_prop.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("adj.vars", "group"), ...) + + rlang::inject( + cardx::ard_stats_prop_test( + data = data, + variable = all_of(variable), + by = all_of(by), + conf.level = conf.level, + !!!test.args + ) + ) +} + +add_p_test_ancova <- function(data, variable, by, adj.vars, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "test.args"), ...) + + if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) { + cli::cli_abort( + c("Error in {.val ancova} model for variable {.val {variable}}.", + i = "This inplementation requires the {.val by} variable to have {.val {2}} levels, + but it has {.val {dplyr::n_distinct(data[[by]], na.rm = TRUE)}}"), + call = get_cli_abort_call() + ) + } + + cardx::ard_regression_basic( + x = + cardx::construct_model( + data = data, + formula = cardx::reformulate2(c(by, adj.vars), response = variable), + method = "lm" + ) + ) |> + dplyr::filter( + .data$variable %in% .env$by, + .data$stat_name %in% c("estimate", "p.value", "statistic", "std.error", "conf.low", "conf.high") + ) %>% + dplyr::bind_rows( + ., + dplyr::filter(., dplyr::row_number() == 1L) |> + dplyr::mutate( + stat = "method", + stat_name = "method", + stat = + dplyr::case_when( + is.null(adj.vars) ~ "One-way ANOVA", + TRUE ~ "ANCOVA" + ), + fmt_fun = list(NULL) + ) + ) +} + + +add_p_test_cohens_d <- function(data, variable, by, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_effectsize_cohens_d( + data = data, + variable = all_of(variable), + by = all_of(by), + ci = conf.level, + !!!test.args + ) + ) +} + +add_p_test_paired_cohens_d <- function(data, variable, by, test.args, group, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("adj.vars"), ...) + check_length(group, 1L) + warn_unbalanced_pairs(data, by, variable, group) + + rlang::inject( + cardx::ard_effectsize_paired_cohens_d( + data = data, + variable = all_of(variable), + by = all_of(by), + id = all_of(group), + ci = conf.level, + !!!test.args + ) + ) +} + +add_p_test_hedges_g <- function(data, variable, by, test.args, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars"), ...) + + rlang::inject( + cardx::ard_effectsize_hedges_g( + data = data, + variable = all_of(variable), + by = all_of(by), + ci = conf.level, + !!!test.args + ) + ) +} + +add_p_test_paired_hedges_g <- function(data, variable, by, test.args, group, conf.level = 0.95, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("adj.vars"), ...) + check_length(group, 1L) + warn_unbalanced_pairs(data, by, variable, group) + + rlang::inject( + cardx::ard_effectsize_paired_hedges_g( + data = data, + variable = all_of(variable), + by = all_of(by), + id = all_of(group), + ci = conf.level, + !!!test.args + ) + ) +} + +add_p_test_smd <- function(data, variable, by, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("group", "adj.vars", "test.args"), ...) + + cardx::ard_smd_smd( + data = data, + variable = all_of(variable), + by = all_of(by) + ) +} + +add_p_test_emmeans <- function(data, variable, by, adj.vars, conf.level = 0.95, + type, group = NULL, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_null(c("test.args"), ...) + + if (!is.null(group)) check_pkg_installed("lme4", reference_pkg = "cardx") + if (inherits(data, "survey.design")) check_pkg_installed("survey", reference_pkg = "cardx") + + # checking inputs + if (!type %in% c("continuous", "dichotomous")) { + cli::cli_abort("Variable {.val {variable}} must be summary type 'continuous' or 'dichotomous'", call = get_cli_abort_call()) + } + if (dplyr::n_distinct(.extract_data_frame(data)[[by]], na.rm = TRUE) != 2) { + cli::cli_abort("The {.arg by} argument must have exactly 2 levels.", call = get_cli_abort_call()) + } + if (type %in% "dichotomous" && dplyr::n_distinct(.extract_data_frame(data)[[by]], na.rm = TRUE) != 2) { + cli::cli_abort("Variable {.val {variable}} must have exactly 2 levels.", call = get_cli_abort_call()) + } + if (inherits(data, "survey.design") && !is.null(group)) { + cli::cli_abort("Cannot use {.arg group} argument with {.val emmeans} and survey data.", call = get_cli_abort_call()) + } + + # assembling formula + # styler: off + termlabels <- + if (is.null(group)) cardx::bt(c(by, adj.vars)) + else c(cardx::bt(by), cardx::bt(adj.vars), glue::glue("(1 | {cardx::bt(group)})")) + response <- + if (type == "dichotomous") glue::glue("as.factor({cardx::bt(variable)})") + else cardx::bt(variable) + formula <- stats::reformulate(termlabels, response) + # styler: on + + # set regression function and any additional arguments + # styler: off + method.args <- list() + package <- "base" + if (is.data.frame(data) && is.null(group) && type %in% "continuous") { + method <- "lm" + } + else if (is.data.frame(data) && is.null(group) && type %in% "dichotomous") { + method <- "lm" + method.args <- list(family = stats::binomial()) + } + else if (inherits(data, "survey.design")) { + package <- "survey" + method <- "svyglm" + if (type %in% "dichotomous") method.args <- list(family = stats::binomial()) + } + else if (is.data.frame(data) && !is.null(group)) { + package <- "lme4" + method <- "glmer" + if (type %in% "dichotomous") method.args <- list(family = stats::binomial()) + } + # styler: on + + cardx::ard_emmeans_mean_difference( + data = data, + formula = formula, + method = method, + method.args = method.args, + package = package, + response_type = type, + conf.level = conf.level, + primary_covariate = by + ) +} + +# UTILITY FUNCTIONS ------------------------------------------------------------ +.extract_data_frame <- function(x) { + if (is.data.frame(x)) { + return(x) + } + x$variables # return survey object data frame +} + +warn_unbalanced_pairs <- function(data, by, variable, group) { + balanced_pairs <- + data[c(group, by, variable)] |> + tidyr::drop_na() |> + tidyr::pivot_wider( + id_cols = all_of(group), + names_from = all_of(by), + values_from = all_of(variable) + ) |> + dplyr::select(-all_of(group)) |> + dplyr::mutate(across(everything(), is.na)) |> + apply(MARGIN = 1, FUN = sum) |> + keep(~ . == 1L) |> + is_empty() + + if (!balanced_pairs) { + cli::cli_warn( + "Some observations included in the stratified summary statistics were omitted + from the comparison due to unbalanced missingness within group." + ) + } + invisible() +} + +check_null <- function(x, variable = get("variable", envir = caller_env()), + call = get_cli_abort_call(), ...) { + dots <- dots_list(...) + walk( + x, + \(.x) { + if (!is_empty(dots[[.x]])) { + cli::cli_abort( + message = "The {.arg {.x}} argument is not used for the test selected for of variable {.val {variable}}.", + call = call + ) + } + } + ) + + invisible() +} diff --git a/R/utils-as.R b/R/utils-as.R index ca37b2b6bd..127fa2c7c6 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -42,6 +42,7 @@ #' tbl_summary(include = c(age, grade)) %>% #' .table_styling_expr_to_row_number() .table_styling_expr_to_row_number <- function(x) { + set_cli_abort_call() # text_format ---------------------------------------------------------------- x$table_styling$text_format <- x$table_styling$text_format %>% diff --git a/data-raw/gtsummary_tests.csv b/data-raw/gtsummary_tests.csv new file mode 100644 index 0000000000..9af1a00566 --- /dev/null +++ b/data-raw/gtsummary_tests.csv @@ -0,0 +1,52 @@ +class,add_p,add_difference,diff_statistic,test_package,test_name,test_fun,fun_to_run,accept_dots,pseudo_code,description,details +tbl_summary,TRUE,TRUE,mean difference,stats,t.test,stats::t.test,gtsummary:::add_p_test_t.test,TRUE,"t.test(variable ~ as.factor(by), data = data, conf.level = 0.95, ...)",t-test, +tbl_summary,TRUE,FALSE,,stats,aov,stats::aov,gtsummary:::add_p_test_aov,FALSE,"aov(variable ~ as.factor(by), data = data) %>% summary()",One-way ANOVA, +tbl_summary,TRUE,FALSE,,stats,mood.test,stats::mood.test,gtsummary:::add_p_test_mood.test,TRUE,"mood.test(variable ~ as.factor(by), data = data, ...) ",Mood two-sample test of scale,Not to be confused with the Brown-Mood test of medians +tbl_summary,TRUE,FALSE,,stats,oneway.test,stats::oneway.test,gtsummary:::add_p_test_oneway.test,TRUE,"oneway.test(variable ~ as.factor(by), data = data, ...) ",One-way ANOVA, +tbl_summary,TRUE,FALSE,,stats,kruskal.test,stats::kruskal.test,gtsummary:::add_p_test_kruskal.test,FALSE,"kruskal.test(data[[variable]], as.factor(data[[by]]))",Kruskal-Wallis test, +tbl_summary,TRUE,FALSE,,stats,wilcox.test,stats::wilcox.test,gtsummary:::add_p_test_wilcox.test,TRUE,"wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, ...)",Wilcoxon rank-sum test, +tbl_summary,TRUE,FALSE,,stats,chisq.test,stats::chisq.test,gtsummary:::add_p_test_chisq.test,TRUE,"chisq.test(x = data[[variable]], y = as.factor(data[[by]]), ...)",chi-square test of independence, +tbl_summary,TRUE,FALSE,,stats,chisq.test.no.correct,,gtsummary:::add_p_test_chisq.test.no.correct,FALSE,"chisq.test(x = data[[variable]], y = as.factor(data[[by]]), correct = FALSE)",chi-square test of independence, +tbl_summary,TRUE,FALSE,,stats,fisher.test,stats::fisher.test,gtsummary:::add_p_test_fisher.test,TRUE,"fisher.test(data[[variable]], as.factor(data[[by]]), conf.level = 0.95, ...)",Fisher's exact test, +tbl_summary,TRUE,FALSE,,stats,mcnemar.test,stats::mcnemar.test,gtsummary:::add_p_test_mcnemar.test,TRUE,"tidyr::pivot_wider(id_cols = group, ...); mcnemar.test(by_1, by_2, conf.level = 0.95, ...)",McNemar's test, +tbl_summary,TRUE,FALSE,,stats,mcnemar.test.wide,,gtsummary:::add_p_test_mcnemar.test_wide,TRUE,"mcnemar.test(data[[variable]], data[[by]], conf.level = 0.95, ...)",McNemar's test, +tbl_summary,TRUE,FALSE,,lme4,lme4,lme4::glmer,gtsummary:::add_p_test_lme4,FALSE,"lme4::glmer(by ~ (1 \UFF5C group), data, family = binomial) %>% anova(lme4::glmer(by ~ variable + (1 \UFF5C group), data, family = binomial))",random intercept logistic regression, +tbl_summary,TRUE,TRUE,mean difference,stats,paired.t.test,,gtsummary:::add_p_tbl_summary_paired.t.test,TRUE,"tidyr::pivot_wider(id_cols = group, ...); t.test(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)",Paired t-test, +tbl_summary,TRUE,FALSE,,stats,paired.wilcox.test,,gtsummary:::add_p_tbl_summary_paired.wilcox.test,TRUE,"tidyr::pivot_wider(id_cols = group, ...); wilcox.test(by_1, by_2, paired = TRUE, conf.int = TRUE, conf.level = 0.95, ...)",Paired Wilcoxon rank-sum test, +tbl_summary,TRUE,TRUE,rate difference,stats,prop.test,stats::prop.test,gtsummary:::add_p_test_prop.test,TRUE,"prop.test(x, n, conf.level = 0.95, ...)",Test for equality of proportions, +tbl_summary,TRUE,TRUE,mean difference,stats,ancova,,gtsummary:::add_p_test_ancova,FALSE,lm(variable ~ by + adj.vars),ANCOVA, +tbl_summary,FALSE,TRUE,mean difference,stats,ancova_lme4,,gtsummary:::add_p_test_ancova_lme4,FALSE,"lme4::lmer(variable ~ by + adj.vars + (1 \UFF5C group), data)",ANCOVA with random intercept, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,cohens_d,effectsize::cohens_d,gtsummary:::add_p_test_cohens_d,TRUE,"effectsize::cohens_d(variable ~ by, data, ci = conf.level, ...)",Cohen's D, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,hedges_g,effectsize::hedges_g,gsummary:::add_p_test_hedges_g,TRUE,"effectsize::hedges_g(variable ~ by, data, ci = conf.level, ...)",Hedge's G, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_cohens_d,,gtsummary:::add_p_test_paired_cohens_d,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::cohens_d(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)",Paired Cohen's D, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_hedges_g,,gtsummary:::add_p_test_paired_hedges_g,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::hedges_g(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)",Paired Hedge's G, +tbl_summary,FALSE,TRUE,standardized mean difference,smd,smd,,gtsummary:::add_p_test_smd,FALSE,"smd::smd(x = data[[variable]], g = data[[by]], std.error = TRUE)",Standardized Mean Difference, +tbl_summary,TRUE,TRUE,adjusted mean difference,emmeans,emmeans,emmeans::emmeans,gtsummary:::add_p_test_emmeans,FALSE,"lm(variable ~ by + adj.vars, data) %>% emmeans::emmeans(specs =~by) %>% emmeans::contrast(method = ""pairwise"") %>% summary(infer = TRUE, level = conf.level)",Estimated Marginal Means or LS-means,"When variable is binary, `glm(family = binomial)` and `emmeans(regrid = ""response"")` arguments are used. When `group` is specified, `lme4::lmer()` and `lme4::glmer()` are used with the group as a random intercept." +tbl_svysummary,FALSE,TRUE,standardized mean difference,smd,smd,,gtsummary:::add_p_test_smd,FALSE,"smd::smd(x = data$variables[[variable]], g = data$variables[[by]], w = weights(data), std.error = TRUE)",Standardized Mean Difference, +tbl_svysummary,TRUE,FALSE,,survey,svy.t.test,survey::svyttest,gtsummary:::add_p_test_svy.t.test,FALSE,"survey::svyttest(~variable + by, data)",t-test adapted to complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.wilcox.test,survey::svyranktest,gtsummary:::add_p_test_svy.wilcox.test,FALSE,"survey::svyranktest(~variable + by, data, test = 'wilcoxon')",Wilcoxon rank-sum test for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.kruskal.test,,gtsummary:::add_p_test_svy.kruskal.test,FALSE,"survey::svyranktest(~variable + by, data, test = 'KruskalWallis')",Kruskal-Wallis rank-sum test for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.vanderwaerden.test,,gtsummary:::add_p_test_svy.vanderwaerden.test,FALSE,"survey::svyranktest(~variable + by, data, test = 'vanderWaerden')",van der Waerden's normal-scores test for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.median.test,,gtsummary:::add_p_test_svy.median.test,FALSE,"survey::svyranktest(~variable + by, data, test = 'median')",Mood's test for the median for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.chisq.test,survey::svychisq,gtsummary:::add_p_test_svy.chisq.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'F')",chi-squared test with Rao & Scott's second-order correction, +tbl_svysummary,TRUE,FALSE,,survey,svy.adj.chisq.test,,gtsummary:::add_p_test_svy.adj.chisq.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'Chisq')",chi-squared test adjusted by a design effect estimate, +tbl_svysummary,TRUE,FALSE,,survey,svy.wald.test,,gtsummary:::add_p_test_svy.wald.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'Wald')",Wald test of independence for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.adj.wald.test,,gtsummary:::add_p_test_svy.adj.wald.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'adjWald')",adjusted Wald test of independence for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.lincom.test,,gtsummary:::add_p_test_svy.lincom.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'lincom')",test of independence using the exact asymptotic distribution for complex survey samples, +tbl_svysummary,TRUE,FALSE,,survey,svy.saddlepoint.test,,gtsummary:::add_p_test_svy.saddlepoint.test,FALSE,"survey::svychisq(~variable + by, data, statistic = 'saddlepoint')",test of independence using a saddlepoint approximation for complex survey samples, +tbl_svysummary,TRUE,TRUE,adjusted mean difference,emmeans,emmeans,emmeans::emmeans,gtsummary:::add_p_test_emmeans,FALSE,"survey::svyglm(variable ~ by + adj.vars, data) %>% emmeans::emmeans(specs =~by) %>% emmeans::contrast(method = ""pairwise"") %>% summary(infer = TRUE, level = conf.level)",Estimated Marginal Means or LS-means,"When variable is binary, `survey::svyglm(family = binomial)` and `emmeans(regrid = ""response"")` arguments are used." +tbl_survfit,TRUE,FALSE,,survival,logrank,,gtsummary:::add_p_tbl_survfit_logrank,FALSE,"survival::survdiff(Surv(.) ~ variable, data, rho = 0)",Log-rank test, +tbl_survfit,TRUE,FALSE,,survival,tarone,,gtsummary:::add_p_tbl_survfit_tarone,FALSE,"survival::survdiff(Surv(.) ~ variable, data, rho = 1.5)",Tarone-Ware test, +tbl_survfit,TRUE,FALSE,,survival,petopeto_gehanwilcoxon,,gtsummary:::add_p_tbl_survfit_petopeto_gehanwilcoxon,FALSE,"survival::survdiff(Surv(.) ~ variable, data, rho = 1)",Peto & Peto modification of Gehan-Wilcoxon test, +tbl_survfit,TRUE,FALSE,,survival,survdiff,survival::survdiff,gtsummary:::add_p_tbl_survfit_survdiff,TRUE,"survival::survdiff(Surv(.) ~ variable, data, ...)",G-rho family test, +tbl_survfit,TRUE,FALSE,,survival,coxph_lrt,survival::coxph,"purrr::partial(gtsummary:::add_p_tbl_survfit_coxph, test_type = ""log"")",TRUE,"survival::coxph(Surv(.) ~ variable, data, ...)",Cox regression (LRT), +tbl_survfit,TRUE,FALSE,,survival,coxph_wald,,"purrr::partial(gtsummary:::add_p_tbl_survfit_coxph, test_type = ""wald"")",TRUE,"survival::coxph(Surv(.) ~ variable, data, ...)",Cox regression (Wald), +tbl_survfit,TRUE,FALSE,,survival,coxph_score,,"purrr::partial(gtsummary:::add_p_tbl_survfit_coxph, test_type = ""sc"")",TRUE,"survival::coxph(Surv(.) ~ variable, data, ...)",Cox regression (Score), +tbl_continuous,TRUE,FALSE,,stats,anova_2way,,gtsummary:::add_p_test_anova_2way,FALSE,lm(continuous_variable ~ by + variable),Two-way ANOVA, +tbl_continuous,TRUE,TRUE,,stats,t.test,stats::t.test,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""t.test"")",TRUE,"t.test(continuous_variable ~ as.factor(variable), data = data, conf.level = 0.95, ...)",t-test, +tbl_continuous,TRUE,FALSE,,stats,aov,stats::aov,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""aov"")",FALSE,"aov(continuous_variable ~ as.factor(variable), data = data) %>% summary()",One-way ANOVA, +tbl_continuous,TRUE,FALSE,,stats,kruskal.test,stats::kruskal.test,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""kruskal.test"")",FALSE,"kruskal.test(data[[continuous_variable]], as.factor(data[[variable]]))",Kruskal-Wallis test, +tbl_continuous,TRUE,FALSE,,stats,wilcox.test,stats::wilcox.test,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""wilcox.test"")",TRUE,"wilcox.test(as.numeric(continuous_variable) ~ as.factor(variable), data = data, ...)",Wilcoxon rank-sum test, +tbl_continuous,TRUE,FALSE,,lme4,lme4,lme4::glmer,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""lme4"")",FALSE,"lme4::glmer(by ~ (1 \UFF5C group), data, family = binomial) %>% anova(lme4::glmer(variable ~ continuous_variable + (1 \UFF5C group), data, family = binomial))",random intercept logistic regression, +tbl_continuous,TRUE,FALSE,,stats,ancova,,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""ancova"")",FALSE,lm(continuous_variable ~ variable + adj.vars),ANCOVA, +tbl_continuous,FALSE,FALSE,,stats,ancova_lme4,,"purrr::partial(gtsummary:::add_p_test_tbl_summary_to_tbl_continuous, test_name = ""ancova_lme4"")",FALSE,"lme4::lmer(continuous_variable ~ variable + adj.vars + (1 \UFF5C group), data)",ANCOVA with random intercept, \ No newline at end of file diff --git a/data-raw/internal_data.R b/data-raw/internal_data.R new file mode 100644 index 0000000000..35504e0d8e --- /dev/null +++ b/data-raw/internal_data.R @@ -0,0 +1,28 @@ +# internal data ---------------------------------------------------------------- +# df_theme_elements <- readr::read_csv("data-raw/gtsummary_theme_elements.csv") + +df_add_p_tests <- + readr::read_csv("data-raw/gtsummary_tests.csv") |> + dplyr::mutate( + test_fun = purrr::map(test_fun, ~ switch(!is.na(.x), + rlang::parse_expr(.x) + )), + fun_to_run = purrr::map(fun_to_run, ~ rlang::parse_expr(.x)), + pseudo_code = stringr::str_glue("`{pseudo_code}`") + ) + +# df_translations <- readxl::read_excel("data-raw/gtsummary_translated.xlsx") +# if (nrow(df_translations) != nrow(df_translations |> dplyr::select(en) |> dplyr::distinct())) { +# stop("STOOOOOOOOOPPPPP, error in the translations data") +# } + +special_char <- list() +special_char$interpunct <- "·" + +usethis::use_data( + # df_theme_elements, + # df_translations, + special_char, + df_add_p_tests, + internal = TRUE, overwrite = TRUE +) diff --git a/man/add_p.Rd b/man/add_p.Rd new file mode 100644 index 0000000000..e75c22c0aa --- /dev/null +++ b/man/add_p.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_p.R +\name{add_p} +\alias{add_p} +\title{Adds P-value} +\usage{ +add_p(x, ...) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +Object with class 'gtsummary'} + +\item{...}{Passed to other methods.} +} +\description{ +\itemize{ +\item \code{\link[=add_p.tbl_summary]{add_p.tbl_summary()}} +} +} +\seealso{ +\code{\link[=add_p.tbl_summary]{add_p.tbl_summary()}} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/add_p.tbl_summary.Rd b/man/add_p.tbl_summary.Rd new file mode 100644 index 0000000000..741d38ece7 --- /dev/null +++ b/man/add_p.tbl_summary.Rd @@ -0,0 +1,127 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_p.R +\name{add_p.tbl_summary} +\alias{add_p.tbl_summary} +\title{Add p-values to summary table} +\usage{ +\method{add_p}{tbl_summary}( + x, + test = NULL, + pvalue_fun = styfn_pvalue(), + group = NULL, + include = everything(), + test.args = NULL, + adj.vars = NULL, + ... +) +} +\arguments{ +\item{x}{(\code{tbl_summary})\cr +table created with \code{tbl_summary()}} + +\item{test}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the statistical tests to perform for each variable, e.g. +\code{list(all_continuous() ~ "t.test", all_categorical() ~ "fisher.test")}. + +See below for details on default tests and \link{tests} for details on available +tests and creating custom tests. + +Common tests include \code{"t.test"}, \code{"aov"}, \code{"wilcox.test"}, \code{"kruskal.test"}, +\code{"chisq.test"}, \code{"fisher.test"}, and \code{"lme4"} (for clustered data). +See \link{tests} for details, more tests, and instruction for implementing a custom test. + +Default tests when \code{group} argument not specified are \code{"kruskal.test"} +for continuous variables (\code{"wilcox.test"} when "by" variable has two levels), +\code{"chisq.test.no.correct"} for categorical variables with all expected cell +counts >=5, and \code{"fisher.test"} for categorical variables with any expected cell count <5.} + +\item{pvalue_fun}{(\code{function})\cr +Function to round and format p-values. Default is \code{styfn_pvalue()}. +The function must have a numeric vector input, and return a string that is +the rounded/formatted p-value (e.g. \code{pvalue_fun = styfn_pvalue(digits = 2)}).} + +\item{group}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variable name of an ID or grouping variable. The column can be used to +calculate p-values with correlated data. +Default is \code{NULL}. See \link{tests} for methods that utilize the \code{group} argument.} + +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in output. Default is \code{everything()}.} + +\item{test.args}{(\code{\link[=syntax]{formula-list-selector}})\cr +Containing additional arguments to pass to tests that accept arguments. +For example, add an argument for all t-tests, use +\code{test.args = all_tests("t.test") ~ list(var.equal = TRUE)}.} + +\item{adj.vars}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in adjusted calculations (e.g. in ANCOVA models). +Default is \code{NULL}.} + +\item{...}{Not used} +} +\value{ +a gtsummary table of class \code{"tbl_summary"} +} +\description{ +Adds p-values to tables created by \code{\link[=tbl_summary]{tbl_summary()}} by comparing values across groups. +} +\section{test argument}{ + + +See the \link{tests} help file for details on available tests and creating custom tests. +The \link{tests} help file also includes psuedo-code for each test to be clear +precisely how the calculation is performed. + +The default test used in \code{add_p()} primarily depends on these factors: +\itemize{ +\item whether the variable is categorical/dichotomous vs continuous +\item number of levels in the \code{tbl_summary(by)} variable +\item whether the \code{add_p(group)} argument is specified +\item whether the \code{add_p(adj.vars)} argument is specified +} +\subsection{Specified neither \code{add_p(group)} nor \code{add_p(adj.vars)}}{ +\itemize{ +\item \code{"wilcox.test"} when \code{by} variable has two levels and variable is continuous. +\item \code{"krustkal.test"} when \code{by} variable has more than two levels and variable is continuous. +\item \code{"chisq.test.no.correct"} for categorical variables with all expected cell counts >=5, +and \code{"fisher.test"} for categorical variables with any expected cell count <5. +} +} + +\subsection{Specified \code{add_p(group)} and not \code{add_p(adj.vars)}}{ +\itemize{ +\item \code{"lme4"} when \code{by} variable has two levels for all summary types. +} + +\emph{There is no default for grouped data when \code{by} variable has more than two levels.} +\emph{Users must create custom tests for this scenario.} +} + +\subsection{Specified \code{add_p(adj.vars)} and not \code{add_p(group)}}{ +\itemize{ +\item \code{"ancova"} when variable is continuous and \code{by} variable has two levels. +} +} +} + +\examples{ +\dontshow{if (gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +# Example 1 ---------------------------------- +add_p_ex1 <- + trial |> + tbl_summary(by = trt, include = c(age, grade)) |> + add_p() + +# Example 2 ---------------------------------- +add_p_ex2 <- + trial \%>\% + select(trt, age, marker) |> + tbl_summary(by = trt, missing = "no") |> + add_p( + # perform t-test for all variables + test = everything() ~ "t.test", + # assume equal variance in the t-test + test.args = all_tests("t.test") ~ list(var.equal = TRUE) + ) +\dontshow{\}) # examplesIf} +} diff --git a/man/assign_tests.Rd b/man/assign_tests.Rd new file mode 100644 index 0000000000..c9b5210ae2 --- /dev/null +++ b/man/assign_tests.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/assign_tests.R +\name{assign_tests} +\alias{assign_tests} +\alias{assign_tests.tbl_summary} +\title{Assign Test} +\usage{ +assign_tests(x, ...) + +\method{assign_tests}{tbl_summary}( + x, + test = NULL, + group = NULL, + adj.vars = NULL, + include, + calling_fun = c("add_p", "add_difference"), + ... +) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +a table of class \code{'gtsummary'}} + +\item{...}{Passed to \code{\link[rlang:abort]{rlang::abort()}}, \code{\link[rlang:abort]{rlang::warn()}} or +\code{\link[rlang:abort]{rlang::inform()}}.} + +\item{test}{(named \code{list})\cr +a named list of tests.} + +\item{group}{(\code{string})\cr +a variable name indicating the grouping column for correlated data. +Default is \code{NULL}.} + +\item{adj.vars}{(\code{character})\cr +Variables to include in adjusted calculations (e.g. in ANCOVA models).} + +\item{include}{(\code{character})\cr +Character vector of column names to assign a default tests.} + +\item{calling_fun}{(\code{string})\cr +Must be one of \code{'add_p'} and \code{'add_difference'}. Depending on the context, +different defaults are set.} +} +\value{ +A table of class \code{'gtsummary'} +} +\description{ +This function is used to assign default tests for \code{add_p()} +and \code{add_difference()}. +} +\examples{ +trial |> + tbl_summary( + by = trt, + include = c(age, stage) + ) |> + assign_tests(include = c("age", "stage"), calling_fun = "add_p") +} diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 43a24893c5..8714fc0abc 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -23,6 +23,7 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index 80c0b89205..256703c718 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -46,6 +46,7 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_hide}()}, +\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_table_body.Rd b/man/modify_table_body.Rd new file mode 100644 index 0000000000..df3a7d99c7 --- /dev/null +++ b/man/modify_table_body.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_table_body.R +\name{modify_table_body} +\alias{modify_table_body} +\title{Modify Table Body} +\usage{ +modify_table_body(x, fun, ...) +} +\arguments{ +\item{x}{gtsummary object} + +\item{fun}{A function or formula. If a \emph{function}, it is used as is. +If a \emph{formula}, e.g. \code{fun = ~ .x \%>\% arrange(variable)}, +it is converted to a function. The argument passed to \verb{fun=} is \code{x$table_body}.} + +\item{...}{Additional arguments passed on to the mapped function} +} +\description{ +Function is for advanced manipulation of gtsummary tables. +It allow users to modify the \code{.$table_body} data frame included +in each gtsummary object. + +If a new column is added to the table, default printing instructions will then +be added to \code{.$table_styling}. By default, columns are hidden. +To show a column, add a column header with \code{modify_header()}. +} +\examples{ +# Example 1 -------------------------------- +} +\seealso{ +Other Advanced modifiers: +\code{\link{modify_column_hide}()}, +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_styling}()} +} +\concept{Advanced modifiers} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index d9ac50611a..cf8107d59f 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -123,6 +123,7 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_hide}()}, -\code{\link{modify_fmt_fun}()} +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_body}()} } \concept{Advanced modifiers} diff --git a/man/select_helpers.Rd b/man/select_helpers.Rd index 5e79e3f0b6..e44cdfef3f 100644 --- a/man/select_helpers.Rd +++ b/man/select_helpers.Rd @@ -6,6 +6,7 @@ \alias{all_continuous2} \alias{all_categorical} \alias{all_dichotomous} +\alias{all_tests} \alias{all_stat_cols} \title{Select helper functions} \usage{ @@ -17,21 +18,29 @@ all_categorical(dichotomous = TRUE) all_dichotomous() +all_tests(tests) + all_stat_cols(stat_0 = TRUE) } \arguments{ -\item{continuous2}{Logical indicating whether to include continuous2 variables. Default is \code{TRUE}} +\item{continuous2}{(scalar \code{logical})\cr +Logical indicating whether to include continuous2 variables. Default is \code{TRUE}} + +\item{dichotomous}{(scalar \code{logical})\cr +Logical indicating whether to include dichotomous variables. Default is \code{TRUE}} -\item{dichotomous}{Logical indicating whether to include dichotomous variables. -Default is \code{TRUE}} +\item{tests}{(\code{character})\cr +character vector indicating the test type of the variables to select, e.g. +select all variables being compared with \code{"t.test"}.} -\item{stat_0}{When \code{FALSE}, will not select the \code{"stat_0"} column. Default is \code{TRUE}} +\item{stat_0}{(scalar \code{logical})\cr +When \code{FALSE}, will not select the \code{"stat_0"} column. Default is \code{TRUE}} } \value{ A character vector of column names selected } \description{ -Set of functions to supplement the {tidyselect} set of +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 @@ -45,6 +54,15 @@ functions for selecting columns of data frames (and other items as well). \item \code{all_contrasts()} selects variables in regression model based on their type of contrast } } +\examples{ +select_ex1 <- + trial |> + select(age, response, grade) |> + tbl_summary( + statistic = all_continuous() ~ "{mean} ({sd})", + type = all_dichotomous() ~ "categorical" + ) +} \seealso{ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 10d865b19c..ed24c45af3 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -67,10 +67,12 @@ Specifies sorting to perform for categorical variables. Values must be one of \code{c("alphanumeric", "frequency")}. Default is \code{all_categorical(FALSE) ~ "alphanumeric"}} -\item{percent}{Indicates the type of percentage to return. +\item{percent}{(\code{string})\cr +Indicates the type of percentage to return. Must be one of \code{c("column", "row", "cell")}. Default is \code{"column"}.} -\item{include}{Variables to include in the summary table. Default is \code{everything()}} +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in the summary table. Default is \code{everything()}} } \value{ a gtsummary table of class \code{"tbl_summary"} diff --git a/man/tests.Rd b/man/tests.Rd new file mode 100644 index 0000000000..0b7a99508c --- /dev/null +++ b/man/tests.Rd @@ -0,0 +1,166 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tests.R +\name{tests} +\alias{tests} +\title{Tests/methods available in \code{add_p()} and \code{add_difference()}} +\description{ +Below is a listing of tests available internally within gtsummary. + +Tests listed with \code{...} may have additional arguments +passed to them using \code{add_p(test.args=)}. For example, to +calculate a p-value from \code{t.test()} assuming equal variance, use +\code{tbl_summary(trial, by = trt) \%>\% add_p(age ~ "t.test", test.args = age ~ list(var.equal = TRUE))} +} +\section{\code{tbl_summary() \%>\% add_p()}}{ +\tabular{llll}{ + \strong{alias} \tab \strong{description} \tab \strong{pseudo-code} \tab \strong{details} \cr + \code{'t.test'} \tab t-test \tab \code{t.test(variable ~ as.factor(by), data = data, conf.level = 0.95, ...)} \tab \cr + \code{'aov'} \tab One-way ANOVA \tab \code{aov(variable ~ as.factor(by), data = data) \%>\% summary()} \tab \cr + \code{'mood.test'} \tab Mood two-sample test of scale \tab \code{mood.test(variable ~ as.factor(by), data = data, ...)} \tab Not to be confused with the Brown-Mood test of medians \cr + \code{'oneway.test'} \tab One-way ANOVA \tab \code{oneway.test(variable ~ as.factor(by), data = data, ...)} \tab \cr + \code{'kruskal.test'} \tab Kruskal-Wallis test \tab \code{kruskal.test(data[[variable]], as.factor(data[[by]]))} \tab \cr + \code{'wilcox.test'} \tab Wilcoxon rank-sum test \tab \code{wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, ...)} \tab \cr + \code{'chisq.test'} \tab chi-square test of independence \tab \code{chisq.test(x = data[[variable]], y = as.factor(data[[by]]), ...)} \tab \cr + \code{'chisq.test.no.correct'} \tab chi-square test of independence \tab \code{chisq.test(x = data[[variable]], y = as.factor(data[[by]]), correct = FALSE)} \tab \cr + \code{'fisher.test'} \tab Fisher's exact test \tab \code{fisher.test(data[[variable]], as.factor(data[[by]]), conf.level = 0.95, ...)} \tab \cr + \code{'mcnemar.test'} \tab McNemar's test \tab \verb{tidyr::pivot_wider(id_cols = group, ...); mcnemar.test(by_1, by_2, conf.level = 0.95, ...)} \tab \cr + \code{'mcnemar.test.wide'} \tab McNemar's test \tab \code{mcnemar.test(data[[variable]], data[[by]], conf.level = 0.95, ...)} \tab \cr + \code{'lme4'} \tab random intercept logistic regression \tab \verb{lme4::glmer(by ~ (1 \\UFF5C group), data, family = binomial) \%>\% anova(lme4::glmer(by ~ variable + (1 \\UFF5C group), data, family = binomial))} \tab \cr + \code{'paired.t.test'} \tab Paired t-test \tab \verb{tidyr::pivot_wider(id_cols = group, ...); t.test(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)} \tab \cr + \code{'paired.wilcox.test'} \tab Paired Wilcoxon rank-sum test \tab \verb{tidyr::pivot_wider(id_cols = group, ...); wilcox.test(by_1, by_2, paired = TRUE, conf.int = TRUE, conf.level = 0.95, ...)} \tab \cr + \code{'prop.test'} \tab Test for equality of proportions \tab \code{prop.test(x, n, conf.level = 0.95, ...)} \tab \cr + \code{'ancova'} \tab ANCOVA \tab \code{lm(variable ~ by + adj.vars)} \tab \cr + \code{'emmeans'} \tab Estimated Marginal Means or LS-means \tab \code{lm(variable ~ by + adj.vars, data) \%>\% emmeans::emmeans(specs =~by) \%>\% emmeans::contrast(method = "pairwise") \%>\% summary(infer = TRUE, level = conf.level)} \tab When variable is binary, \code{glm(family = binomial)} and \code{emmeans(regrid = "response")} arguments are used. When \code{group} is specified, \code{lme4::lmer()} and \code{lme4::glmer()} are used with the group as a random intercept. \cr +} +} + +\section{\code{tbl_svysummary() \%>\% add_p()}}{ +\tabular{llll}{ + \strong{alias} \tab \strong{description} \tab \strong{pseudo-code} \tab \strong{details} \cr + \code{'svy.t.test'} \tab t-test adapted to complex survey samples \tab \code{survey::svyttest(~variable + by, data)} \tab \cr + \code{'svy.wilcox.test'} \tab Wilcoxon rank-sum test for complex survey samples \tab \code{survey::svyranktest(~variable + by, data, test = 'wilcoxon')} \tab \cr + \code{'svy.kruskal.test'} \tab Kruskal-Wallis rank-sum test for complex survey samples \tab \code{survey::svyranktest(~variable + by, data, test = 'KruskalWallis')} \tab \cr + \code{'svy.vanderwaerden.test'} \tab van der Waerden's normal-scores test for complex survey samples \tab \code{survey::svyranktest(~variable + by, data, test = 'vanderWaerden')} \tab \cr + \code{'svy.median.test'} \tab Mood's test for the median for complex survey samples \tab \code{survey::svyranktest(~variable + by, data, test = 'median')} \tab \cr + \code{'svy.chisq.test'} \tab chi-squared test with Rao & Scott's second-order correction \tab \code{survey::svychisq(~variable + by, data, statistic = 'F')} \tab \cr + \code{'svy.adj.chisq.test'} \tab chi-squared test adjusted by a design effect estimate \tab \code{survey::svychisq(~variable + by, data, statistic = 'Chisq')} \tab \cr + \code{'svy.wald.test'} \tab Wald test of independence for complex survey samples \tab \code{survey::svychisq(~variable + by, data, statistic = 'Wald')} \tab \cr + \code{'svy.adj.wald.test'} \tab adjusted Wald test of independence for complex survey samples \tab \code{survey::svychisq(~variable + by, data, statistic = 'adjWald')} \tab \cr + \code{'svy.lincom.test'} \tab test of independence using the exact asymptotic distribution for complex survey samples \tab \code{survey::svychisq(~variable + by, data, statistic = 'lincom')} \tab \cr + \code{'svy.saddlepoint.test'} \tab test of independence using a saddlepoint approximation for complex survey samples \tab \code{survey::svychisq(~variable + by, data, statistic = 'saddlepoint')} \tab \cr + \code{'emmeans'} \tab Estimated Marginal Means or LS-means \tab \code{survey::svyglm(variable ~ by + adj.vars, data) \%>\% emmeans::emmeans(specs =~by) \%>\% emmeans::contrast(method = "pairwise") \%>\% summary(infer = TRUE, level = conf.level)} \tab When variable is binary, \code{survey::svyglm(family = binomial)} and \code{emmeans(regrid = "response")} arguments are used. \cr +} +} + +\section{\code{tbl_survfit() \%>\% add_p()}}{ +\tabular{lll}{ + \strong{alias} \tab \strong{description} \tab \strong{pseudo-code} \cr + \code{'logrank'} \tab Log-rank test \tab \code{survival::survdiff(Surv(.) ~ variable, data, rho = 0)} \cr + \code{'tarone'} \tab Tarone-Ware test \tab \code{survival::survdiff(Surv(.) ~ variable, data, rho = 1.5)} \cr + \code{'petopeto_gehanwilcoxon'} \tab Peto & Peto modification of Gehan-Wilcoxon test \tab \code{survival::survdiff(Surv(.) ~ variable, data, rho = 1)} \cr + \code{'survdiff'} \tab G-rho family test \tab \code{survival::survdiff(Surv(.) ~ variable, data, ...)} \cr + \code{'coxph_lrt'} \tab Cox regression (LRT) \tab \code{survival::coxph(Surv(.) ~ variable, data, ...)} \cr + \code{'coxph_wald'} \tab Cox regression (Wald) \tab \code{survival::coxph(Surv(.) ~ variable, data, ...)} \cr + \code{'coxph_score'} \tab Cox regression (Score) \tab \code{survival::coxph(Surv(.) ~ variable, data, ...)} \cr +} +} + +\section{\code{tbl_continuous() \%>\% add_p()}}{ +\tabular{lll}{ + \strong{alias} \tab \strong{description} \tab \strong{pseudo-code} \cr + \code{'anova_2way'} \tab Two-way ANOVA \tab \code{lm(continuous_variable ~ by + variable)} \cr + \code{'t.test'} \tab t-test \tab \code{t.test(continuous_variable ~ as.factor(variable), data = data, conf.level = 0.95, ...)} \cr + \code{'aov'} \tab One-way ANOVA \tab \code{aov(continuous_variable ~ as.factor(variable), data = data) \%>\% summary()} \cr + \code{'kruskal.test'} \tab Kruskal-Wallis test \tab \code{kruskal.test(data[[continuous_variable]], as.factor(data[[variable]]))} \cr + \code{'wilcox.test'} \tab Wilcoxon rank-sum test \tab \code{wilcox.test(as.numeric(continuous_variable) ~ as.factor(variable), data = data, ...)} \cr + \code{'lme4'} \tab random intercept logistic regression \tab \verb{lme4::glmer(by ~ (1 \\UFF5C group), data, family = binomial) \%>\% anova(lme4::glmer(variable ~ continuous_variable + (1 \\UFF5C group), data, family = binomial))} \cr + \code{'ancova'} \tab ANCOVA \tab \code{lm(continuous_variable ~ variable + adj.vars)} \cr +} +} + +\section{tbl_summary() \%>\% add_difference()}{ +\tabular{lllll}{ + \strong{alias} \tab \strong{description} \tab \strong{difference statistic} \tab \strong{pseudo-code} \tab \strong{details} \cr + \code{'t.test'} \tab t-test \tab mean difference \tab \code{t.test(variable ~ as.factor(by), data = data, conf.level = 0.95, ...)} \tab \cr + \code{'paired.t.test'} \tab Paired t-test \tab mean difference \tab \verb{tidyr::pivot_wider(id_cols = group, ...); t.test(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)} \tab \cr + \code{'prop.test'} \tab Test for equality of proportions \tab rate difference \tab \code{prop.test(x, n, conf.level = 0.95, ...)} \tab \cr + \code{'ancova'} \tab ANCOVA \tab mean difference \tab \code{lm(variable ~ by + adj.vars)} \tab \cr + \code{'ancova_lme4'} \tab ANCOVA with random intercept \tab mean difference \tab \verb{lme4::lmer(variable ~ by + adj.vars + (1 \\UFF5C group), data)} \tab \cr + \code{'cohens_d'} \tab Cohen's D \tab standardized mean difference \tab \code{effectsize::cohens_d(variable ~ by, data, ci = conf.level, ...)} \tab \cr + \code{'hedges_g'} \tab Hedge's G \tab standardized mean difference \tab \code{effectsize::hedges_g(variable ~ by, data, ci = conf.level, ...)} \tab \cr + \code{'paired_cohens_d'} \tab Paired Cohen's D \tab standardized mean difference \tab \verb{tidyr::pivot_wider(id_cols = group, ...); effectsize::cohens_d(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)} \tab \cr + \code{'paired_hedges_g'} \tab Paired Hedge's G \tab standardized mean difference \tab \verb{tidyr::pivot_wider(id_cols = group, ...); effectsize::hedges_g(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)} \tab \cr + \code{'smd'} \tab Standardized Mean Difference \tab standardized mean difference \tab \code{smd::smd(x = data[[variable]], g = data[[by]], std.error = TRUE)} \tab \cr + \code{'emmeans'} \tab Estimated Marginal Means or LS-means \tab adjusted mean difference \tab \code{lm(variable ~ by + adj.vars, data) \%>\% emmeans::emmeans(specs =~by) \%>\% emmeans::contrast(method = "pairwise") \%>\% summary(infer = TRUE, level = conf.level)} \tab When variable is binary, \code{glm(family = binomial)} and \code{emmeans(regrid = "response")} arguments are used. When \code{group} is specified, \code{lme4::lmer()} and \code{lme4::glmer()} are used with the group as a random intercept. \cr +} +} + +\section{tbl_svysummary() \%>\% add_difference()}{ +\tabular{lllll}{ + \strong{alias} \tab \strong{description} \tab \strong{difference statistic} \tab \strong{pseudo-code} \tab \strong{details} \cr + \code{'smd'} \tab Standardized Mean Difference \tab standardized mean difference \tab \code{smd::smd(x = data$variables[[variable]], g = data$variables[[by]], w = weights(data), std.error = TRUE)} \tab \cr + \code{'emmeans'} \tab Estimated Marginal Means or LS-means \tab adjusted mean difference \tab \code{survey::svyglm(variable ~ by + adj.vars, data) \%>\% emmeans::emmeans(specs =~by) \%>\% emmeans::contrast(method = "pairwise") \%>\% summary(infer = TRUE, level = conf.level)} \tab When variable is binary, \code{survey::svyglm(family = binomial)} and \code{emmeans(regrid = "response")} arguments are used. \cr +} +} + +\section{Custom Functions}{ + + +To report a p-value (or difference) for a test not available in gtsummary, you can create a +custom function. The output is a data frame that is one line long. The +structure is similar to the output of \code{broom::tidy()} of a typical +statistical test. The \code{add_p()} and \code{add_difference()} functions will look for columns called +\code{"p.value"}, \code{"estimate"}, \code{"statistic"}, \code{"std.error"}, \code{"parameter"}, +\code{"conf.low"}, \code{"conf.high"}, and \code{"method"}. + +You can also pass an Analysis Results Dataset (ARD) object with the results +for your custom result. These objects follow the structures outlined +by the \{cards\} and \{cardx\} packages. + +Example calculating a p-value from a t-test assuming a common variance +between groups. + +\if{html}{\out{
}}\preformatted{ttest_common_variance <- function(data, variable, by, ...) \{ + data <- data[c(variable, by)] \%>\% dplyr::filter(complete.cases(.)) + t.test(data[[variable]] ~ factor(data[[by]]), var.equal = TRUE) \%>\% + broom::tidy() +\} + +trial[c("age", "trt")] \%>\% + tbl_summary(by = trt) \%>\% + add_p(test = age ~ "ttest_common_variance") +}\if{html}{\out{
}} + +A custom \code{add_difference()} is similar, and accepts arguments \verb{conf.level=} +and \verb{adj.vars=} as well. + +\if{html}{\out{
}}\preformatted{ttest_common_variance <- function(data, variable, by, conf.level, ...) \{ + data <- data[c(variable, by)] \%>\% dplyr::filter(complete.cases(.)) + t.test(data[[variable]] ~ factor(data[[by]]), conf.level = conf.level, var.equal = TRUE) \%>\% + broom::tidy() +\} +}\if{html}{\out{
}} +\subsection{Function Arguments}{ + +For \code{tbl_summary()} objects, the custom function will be passed the +following arguments: \code{custom_pvalue_fun(data=, variable=, by=, group=, type=, conf.level=, adj.vars=)}. +While your function may not utilize each of these arguments, these arguments +are passed and the function must accept them. We recommend including \code{...} +to future-proof against updates where additional arguments are added. + +The following table describes the argument inputs for each gtsummary table type.\tabular{lllll}{ + \strong{argument} \tab \strong{tbl_summary} \tab \strong{tbl_svysummary} \tab \strong{tbl_survfit} \tab \strong{tbl_continuous} \cr + \verb{data=} \tab A data frame \tab A survey object \tab A \code{survfit()} object \tab A data frame \cr + \verb{variable=} \tab String variable name \tab String variable name \tab \code{NA} \tab String variable name \cr + \verb{by=} \tab String variable name \tab String variable name \tab \code{NA} \tab String variable name \cr + \verb{group=} \tab String variable name \tab \code{NA} \tab \code{NA} \tab String variable name \cr + \verb{type=} \tab Summary type \tab Summary type \tab \code{NA} \tab \code{NA} \cr + \verb{conf.level=} \tab Confidence interval level \tab \code{NA} \tab \code{NA} \tab \code{NA} \cr + \verb{adj.vars=} \tab Character vector of adjustment variable names (e.g. used in ANCOVA) \tab \code{NA} \tab \code{NA} \tab Character vector of adjustment variable names (e.g. used in ANCOVA) \cr + \verb{continuous_variable=} \tab \code{NA} \tab \code{NA} \tab \code{NA} \tab String of the continuous variable name \cr +} + +} +} + +\keyword{internal} diff --git a/man/vec_to_df.Rd b/man/vec_to_df.Rd new file mode 100644 index 0000000000..c68462a1d0 --- /dev/null +++ b/man/vec_to_df.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/select_helpers.R +\name{vec_to_df} +\alias{vec_to_df} +\title{Convert character vector to data frame} +\usage{ +vec_to_df(x) +} +\arguments{ +\item{x}{character vector} +} +\value{ +data frame +} +\description{ +This is used in some of the selecting we allow for, for example in +\code{as_gt(include=)} you can use tidyselect to select among the call +names to include. +} +\keyword{internal} diff --git a/tests/testthat/_snaps/add_p.tbl_summary.md b/tests/testthat/_snaps/add_p.tbl_summary.md new file mode 100644 index 0000000000..5ae4dd0781 --- /dev/null +++ b/tests/testthat/_snaps/add_p.tbl_summary.md @@ -0,0 +1,255 @@ +# add_p.tbl_summary() snapshots of common outputs + + Code + select(as.data.frame(add_p(tbl_summary(trial, by = grade)), col_labels = FALSE), + -all_stat_cols()) + Output + label p.value + 1 Chemotherapy Treatment 0.9 + 2 Drug A + 3 Drug B + 4 Age 0.8 + 5 Unknown + 6 Marker Level (ng/mL) 0.019 + 7 Unknown + 8 T Stage 0.6 + 9 T1 + 10 T2 + 11 T3 + 12 T4 + 13 Tumor Response >0.9 + 14 Unknown + 15 Patient Died 0.080 + 16 Months to Death/Censor 0.060 + +--- + + Code + as.data.frame(add_p(tbl_summary(mtcars, by = am))) + Message + The following warnings were returned during `add_p()`: + ! For variable `disp` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `drat` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `hp` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `mpg` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `qsec` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `wt` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + Output + **Characteristic** **0** \nN = 19 **1** \nN = 13 **p-value** + 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) 0.002 + 2 cyl 0.009 + 3 4 3 (16%) 8 (62%) + 4 6 4 (21%) 3 (23%) + 5 8 12 (63%) 2 (15%) + 6 disp 276 (168, 360) 120 (79, 160) <0.001 + 7 hp 175 (110, 205) 109 (66, 113) 0.046 + 8 drat 3.15 (3.07, 3.70) 4.08 (3.85, 4.22) <0.001 + 9 wt 3.52 (3.44, 3.85) 2.32 (1.94, 2.78) <0.001 + 10 qsec 17.82 (17.05, 19.44) 17.02 (16.46, 18.61) 0.3 + 11 vs 7 (37%) 7 (54%) 0.3 + 12 gear <0.001 + 13 3 15 (79%) 0 (0%) + 14 4 4 (21%) 8 (62%) + 15 5 0 (0%) 5 (38%) + 16 carb 0.3 + 17 1 3 (16%) 4 (31%) + 18 2 6 (32%) 4 (31%) + 19 3 3 (16%) 0 (0%) + 20 4 7 (37%) 3 (23%) + 21 6 0 (0%) 1 (7.7%) + 22 8 0 (0%) 1 (7.7%) + +--- + + Code + select(as.data.frame(add_p(tbl_summary(trial, by = trt)), col_labels = FALSE), + -all_stat_cols()) + Output + label p.value + 1 Age 0.7 + 2 Unknown + 3 Marker Level (ng/mL) 0.085 + 4 Unknown + 5 T Stage 0.9 + 6 T1 + 7 T2 + 8 T3 + 9 T4 + 10 Grade 0.9 + 11 I + 12 II + 13 III + 14 Tumor Response 0.5 + 15 Unknown + 16 Patient Died 0.4 + 17 Months to Death/Censor 0.14 + +# add_p.tbl_summary() error messaging with bad inputs + + Code + add_p(tbl_summary(trial[c("trt", "age")])) + Condition + Error in `add_p()`: + ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. + +--- + + Code + add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( + ...) mtcars)) + Condition + Error in `add_p()`: + ! The test result object for variable "age" is not the expected structure. + i Review `?gtsummary::tests()` for details on constructing a custom function. + +--- + + Code + add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( + ...) letters)) + Condition + Error in `add_p()`: + ! Expecting the test result object for variable "age" to be a . + i Review `?gtsummary::tests()` for details on constructing a custom function. + +# add_p.tbl_summary() & lme4 + + Code + as.data.frame(modify_column_hide(add_p(tbl_summary(trial, by = trt), test = everything() ~ + "lme4", group = response), all_stat_cols())) + Output + **Characteristic** **p-value** + 1 Age >0.9 + 2 Unknown + 3 Marker Level (ng/mL) 0.2 + 4 Unknown + 5 T Stage 0.9 + 6 T1 + 7 T2 + 8 T3 + 9 T4 + 10 Grade 0.8 + 11 I + 12 II + 13 III + 14 Tumor Response 0.5 + 15 Unknown + 16 Patient Died 0.3 + 17 Months to Death/Censor 0.042 + +--- + + Code + select(as.data.frame(add_p(tbl_summary(trial, by = trt), test = everything() ~ + "lme4"), col_labels = FALSE), -all_stat_cols()) + Message + The following errors were returned during `add_p()`: + x For variable `age` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `death` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `grade` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `marker` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `response` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `stage` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + x For variable `ttdeath` (`trt`) and "p.value" statistic: The `group` argument cannot be missing for "lme4" tests. + Output + label p.value + 1 Age + 2 Unknown + 3 Marker Level (ng/mL) + 4 Unknown + 5 T Stage + 6 T1 + 7 T2 + 8 T3 + 9 T4 + 10 Grade + 11 I + 12 II + 13 III + 14 Tumor Response + 15 Unknown + 16 Patient Died + 17 Months to Death/Censor + +# add_p.tbl_summary() creates output without error/warning for continuous2 + + Code + select(as.data.frame(add_p(tbl_summary(trial, by = grade, include = c(age, + marker, response), type = all_continuous() ~ "continuous2")), col_labels = FALSE), + -all_stat_cols()) + Output + label p.value + 1 Age 0.8 + 2 Median (Q1, Q3) + 3 Unknown + 4 Marker Level (ng/mL) 0.019 + 5 Median (Q1, Q3) + 6 Unknown + 7 Tumor Response >0.9 + 8 Unknown + +# add_p.tbl_summary() works well + + Code + as.data.frame(add_p(tbl_summary(mtcars, by = am), test = list(mpg = "t.test", + disp = "aov", hp = "oneway.test", cyl = "chisq.test.no.correct", carb = "mood.test"))) + Message + The following warning was returned in `add_p()` for variable "disp" + ! The test "aov" in `add_p(test)` was deprecated in gtsummary 2.0.0. i The same functionality is covered with "oneway.test". Use the following code instead: i `add_p(test = list(disp = 'oneway.test'), test.args = list(disp = list(var.equal = TRUE)))`. + The following warnings were returned during `add_p()`: + ! For variable `cyl` (`am`) and "statistic", "p.value", and "parameter" statistics: Chi-squared approximation may be incorrect + ! For variable `drat` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `qsec` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `wt` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + Output + **Characteristic** **0** \nN = 19 **1** \nN = 13 **p-value** + 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) 0.001 + 2 cyl 0.013 + 3 4 3 (16%) 8 (62%) + 4 6 4 (21%) 3 (23%) + 5 8 12 (63%) 2 (15%) + 6 disp 276 (168, 360) 120 (79, 160) <0.001 + 7 hp 175 (110, 205) 109 (66, 113) 0.2 + 8 drat 3.15 (3.07, 3.70) 4.08 (3.85, 4.22) <0.001 + 9 wt 3.52 (3.44, 3.85) 2.32 (1.94, 2.78) <0.001 + 10 qsec 17.82 (17.05, 19.44) 17.02 (16.46, 18.61) 0.3 + 11 vs 7 (37%) 7 (54%) 0.3 + 12 gear <0.001 + 13 3 15 (79%) 0 (0%) + 14 4 4 (21%) 8 (62%) + 15 5 0 (0%) 5 (38%) + 16 carb 0.017 + 17 1 3 (16%) 4 (31%) + 18 2 6 (32%) 4 (31%) + 19 3 3 (16%) 0 (0%) + 20 4 7 (37%) 3 (23%) + 21 6 0 (0%) 1 (7.7%) + 22 8 0 (0%) 1 (7.7%) + +--- + + Code + as.data.frame(add_p(tbl_summary(mtcars, by = am, include = c(mpg, disp)), test = list( + mpg = t.test, disp = oneway.test))) + Output + **Characteristic** **0** \nN = 19 **1** \nN = 13 **p-value** + 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) 0.001 + 2 disp 276 (168, 360) 120 (79, 160) <0.001 + +# Groups arg and lme4 + + Code + as.data.frame(tbl_groups) + Output + **Characteristic** **Drug A** \nN = 98 **Drug B** \nN = 102 **p-value** + 1 Age 46 (37, 60) 48 (39, 56) 0.8 + +# add_p.tbl_summary() can be run after add_difference() + + Code + add_p(add_p(tbl_summary(select(trial, age, trt), by = trt))) + Condition + Error in `add_p()`: + ! Columns "statistic" and "p.value" are already present in table (although, some may be hidden), and no new columns were added. + i Use `tbl |> modify_table_body(\(x) dplyr::select(x, -p.value))` to remove columns and they will be replaced by the new columns from the current call. + diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 16c9bbf33d..33b044cb86 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -246,7 +246,7 @@ Code tbl <- tbl_summary(trial, include = grade, type = grade ~ "continuous") Message - The following errors were returned while calculating statistics: + The following errors were returned during `tbl_summary()`: x For variable `grade` and "median" statistic: need numeric data x For variable `grade` and "p25" and "p75" statistics: (unordered) factors are not allowed @@ -256,7 +256,7 @@ tbl_summary(trial, include = grade, type = grade ~ "dichotomous", value = grade ~ "IV") Condition - Error in `cards::ard_dichotomous()`: + Error in `tbl_summary()`: ! Error in argument `value` for variable "grade". i A value of "IV" was passed, but must be one of I, II, and III. @@ -284,7 +284,7 @@ Code tbl_summary(trial, value = "grade" ~ "IV", include = c(grade, response)) Condition - Error in `cards::ard_dichotomous()`: + Error in `tbl_summary()`: ! Error in argument `value` for variable "grade". i A value of "IV" was passed, but must be one of I, II, and III. diff --git a/tests/testthat/test-add_p.tbl_summary.R b/tests/testthat/test-add_p.tbl_summary.R new file mode 100644 index 0000000000..8c3bbc4781 --- /dev/null +++ b/tests/testthat/test-add_p.tbl_summary.R @@ -0,0 +1,521 @@ +skip_if_not(is_pkg_installed(c("broom", "lme4", "broom.helpers"), reference_pkg = "cardx")) + +test_that("add_p.tbl_summary() snapshots of common outputs", { + expect_snapshot( + tbl_summary(trial, by = grade) |> + add_p() |> + as.data.frame(col_labels = FALSE) |> + select(-all_stat_cols()) + ) + + expect_snapshot( + tbl_summary(mtcars, by = am) |> + add_p() |> + as.data.frame() + ) + + expect_snapshot( + trial |> + tbl_summary(by = trt) |> + add_p() |> + as.data.frame(col_labels = FALSE) |> + select(-all_stat_cols()) + ) +}) + +test_that("add_p.tbl_summary() error messaging with bad inputs", { + # no by arg in tbl_summary + expect_snapshot( + error = TRUE, + tbl_summary(trial[c("trt", "age")]) |> + add_p() + ) + + # bad test argument values + expect_error( + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(test = mtcars) + ) + expect_snapshot( + error = TRUE, + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(test = list(age = \(...) mtcars)) + ) + expect_snapshot( + error = TRUE, + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(test = list(age = \(...) letters)) + ) + + expect_error( + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(pvalue_fun = mtcars) + ) + + expect_error( + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(group = \(x) round(x)) + ) + expect_error( + tbl_summary(trial[c("trt", "age")], by = trt) |> + add_p(group = c("trt", "age")) + ) + + +}) + +test_that("add_p.tbl_summary() & lme4", { + skip_if_not(is_pkg_installed("lme4", reference_pkg = "cardx")) + + # errors with expected use + expect_snapshot( + tbl_summary(trial, by = trt) |> + add_p(test = everything() ~ "lme4", group = response) |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + + # we see appropriate messaging when using incorrectly (no group variable) + expect_snapshot( + tbl_summary(trial, by = trt) |> + add_p(test = everything() ~ "lme4") |> + as.data.frame(col_labels = FALSE) |> + select(-all_stat_cols()) + ) +}) + +test_that("add_p.tbl_summary() creates output without error/warning for continuous2", { + expect_snapshot( + tbl_summary(trial, by = grade, include = c(age, marker, response), type = all_continuous() ~ "continuous2") |> + add_p() |> + as.data.frame(col_labels = FALSE) |> + select(-all_stat_cols()) + ) +}) + +test_that("add_p() creates errors with bad args", { + expect_error( + tbl_summary(mtcars, by = am) |> + add_p(pvalue_fun = mtcars), + NULL + ) + + expect_error( + tbl_summary(trial, by = grade, include = -response) |> + add_p(group = response), + NULL + ) +}) + +test_that("add_p.tbl_summary() works well", { + expect_snapshot( + tbl_summary(mtcars, by = am) |> + add_p( + test = list( + mpg = "t.test", + disp = "aov", + hp = "oneway.test", + cyl = "chisq.test.no.correct", + carb = "mood.test" + ) + ) |> + as.data.frame() + ) + + expect_snapshot( + tbl_summary(mtcars, by = am, include = c(mpg, disp)) |> + add_p( + test = list( + mpg = t.test, + disp = oneway.test + ) + ) |> + as.data.frame() + ) +}) + + +test_that("add_p with custom p-value function", { + withr::local_package("broom") + my_mcnemar <- function(data, variable, by, ...) { + stats::mcnemar.test(data[[variable]], data[[by]]) |> tidy() + } + + expect_error( + tbl <- + trial[c("response", "trt")] |> + tbl_summary(by = trt) |> + add_p(test = response ~ "my_mcnemar"), + NA + ) + expect_equal( + as.data.frame(tbl), + trial[c("response", "trt")] |> + tbl_summary(by = trt) |> + add_p(test = response ~ my_mcnemar) |> + as.data.frame() + ) + + + expect_equal( + tbl$cards$add_p$response$p.value, + stats::mcnemar.test(trial[["response"]], trial[["trt"]])$p.value + ) +}) + +test_that("Wilcoxon and Kruskal-Wallis p-values match ", { + t1 <- trial[c("trt", "age", "marker")] |> + tbl_summary(by = trt) |> + add_p(test = all_continuous() ~ wilcox.test) + t2 <- trial[c("trt", "age", "marker")] |> + tbl_summary(by = trt) |> + add_p(test = all_continuous() ~ kruskal.test) + expect_true( + all( + (t1$cards$add_p |> dplyr::bind_rows() |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist()) - + (t2$cards$add_p |> dplyr::bind_rows() |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist()) < 0.001) + ) +}) + + + + +test_that("p-values are replicated within tbl_summary()", { + tbl_test.args <- + trial |> + dplyr::select(trt, + var_t.test = age, + var_t.test_dots = age, + var_kruskal.test = age, + var_wilcox.test = age, + var_wilcox.test_dots = age, + var_oneway.test = age, + var_chisq.test = response, + var_chisq.test_dots = response, + var_chisq.test.no.correct = response, + var_fisher.test = response, + var_fisher.test_dots = response, + var_mcnemar.test = response, + var_mcnemar.test_dots = response, + ) |> + tbl_summary(by = trt, missing = "no") |> + add_p( + test = list( + contains("t.test") ~ t.test, + contains("kruskal.test") ~ kruskal.test, + contains("wilcox.test") ~ wilcox.test, + contains("oneway.test") ~ oneway.test, + contains("chisq.test") ~ chisq.test, + contains("chisq.test.no.correct") ~ "chisq.test.no.correct", + contains("fisher.test") ~ fisher.test, + contains("mcnemar.test") ~ "mcnemar.test.wide" + ), + test.args = list( + var_t.test_dots = list(var.equal = TRUE), + var_wilcox.test_dots = list(correct = FALSE), + var_chisq.test_dots = list(correct = FALSE), + var_fisher.test_dots = list(alternative = "greater"), + var_mcnemar.test_dots = list(correct = FALSE) + ) + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_t.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + t.test(age ~ as.factor(trt), data = trial)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_t.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + t.test(age ~ as.factor(trt), data = trial, var.equal = TRUE)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_kruskal.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + kruskal.test(trial$age, as.factor(trial$trt))$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_wilcox.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + wilcox.test(age ~ trt, data = trial)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_wilcox.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + wilcox.test(age ~ trt, data = trial, correct = FALSE)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_oneway.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + stats::oneway.test(age ~ as.factor(trt), data = trial)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_chisq.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + stats::chisq.test(x = trial[["response"]], y = as.factor(trial[["trt"]]))$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_chisq.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + stats::chisq.test(x = trial[["response"]], y = as.factor(trial[["trt"]]), correct = FALSE)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_chisq.test.no.correct"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + stats::chisq.test(x = trial[["response"]], y = as.factor(trial[["trt"]]), correct = FALSE)$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_fisher.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + fisher.test(trial[["response"]], as.factor(trial[["trt"]]))$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_fisher.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + fisher.test(trial[["response"]], as.factor(trial[["trt"]]), alternative = "greater")$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_mcnemar.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + mcnemar.test(trial[["response"]], as.factor(trial[["trt"]]))$p.value + ) + + expect_equal( + tbl_test.args$cards$add_p[["var_mcnemar.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + mcnemar.test(trial[["response"]], as.factor(trial[["trt"]]), correct = FALSE)$p.value + ) +}) + +test_that("p-values are replicated within tbl_summary() with groups", { + trial_group <- + trial |> + dplyr::group_by(trt) |> + dplyr::mutate(id = dplyr::row_number()) |> + dplyr::ungroup() + + trial_group_wide <- + trial_group |> + dplyr::filter(trt == "Drug A") |> + dplyr::full_join( + trial_group |> + dplyr::filter(trt == "Drug B"), + by = "id" + ) + + expect_message( + trial_group |> + tbl_summary(include = age, by = trt) |> + add_p(test = age ~ "paired.t.test", include = age) + ) + + expect_message( + trial_group |> + dplyr::filter(dplyr::row_number() != 1L) |> + tbl_summary(include = c(marker, age), by = trt) |> + add_p( + test = list(age = "paired.t.test", marker = "paired.wilcox.test"), + group = id + ) + ) + + tbl_groups <- + trial_group |> + select( + trt, id, + grade_lme4 = grade, + grade_mcnemar.test = grade, + response_mcnemar.test = response, + response_mcnemar.test_dots = response, + age_paired.t.test = age, + age_paired.t.test_dots = age, + age_paired.wilcox.test = age, + age_paired.wilcox.test_dots = age + ) |> + tbl_summary(by = trt, missing = "no", include = -id) |> + add_p( + test = list( + contains("paired.t.test") ~ "paired.t.test", + contains("mcnemar.test") ~ "mcnemar.test", + contains("paired.wilcox.test") ~ "paired.wilcox.test" + ), + test.args = list( + age_paired.t.test_dots ~ list(mu = 1), + response_mcnemar.test_dots ~ list(correct = FALSE), + age_paired.wilcox.test_dots ~ list(mu = 1) + ), + group = "id" + ) + + expect_equal( + tbl_groups$cards$add_p[["response_mcnemar.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + mcnemar.test(trial_group_wide[["response.x"]], trial_group_wide[["response.y"]], + correct = FALSE + )$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["response_mcnemar.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + mcnemar.test(trial_group_wide[["response.x"]], trial_group_wide[["response.y"]])$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["grade_mcnemar.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + mcnemar.test(trial_group_wide[["grade.x"]], trial_group_wide[["grade.y"]])$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["age_paired.t.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + t.test(trial_group_wide[["age.x"]], trial_group_wide[["age.y"]], paired = TRUE)$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["age_paired.t.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + t.test(trial_group_wide[["age.x"]], trial_group_wide[["age.y"]], paired = TRUE, mu = 1)$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["age_paired.wilcox.test"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + wilcox.test(trial_group_wide[["age.x"]], trial_group_wide[["age.y"]], paired = TRUE)$p.value + ) + + expect_equal( + tbl_groups$cards$add_p[["age_paired.wilcox.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), + wilcox.test(trial_group_wide[["age.x"]], trial_group_wide[["age.y"]], paired = TRUE, mu = 1)$p.value + ) +}) + +test_that("Groups arg and lme4", { + skip_if_not(is_pkg_installed(c("lme4", "broom.mixed"), reference_pkg = "cardx")) + withr::local_package("broom") + withr::local_package("lme4") + + trial_group <- + trial |> + dplyr::group_by(trt) |> + dplyr::mutate(id = dplyr::row_number()) |> + dplyr::ungroup() + + tbl_groups <- + trial_group %>% + select(trt, id, + age_lme4 = age + ) %>% + tbl_summary(by = trt, missing = "no", include = -id) %>% + add_p( + test = list(contains("lme4") ~ "lme4"), + group = "id" + ) + expect_snapshot(as.data.frame(tbl_groups)) + + expect_equal( + tbl_groups$cards$add_p$age_lme4 |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist(), + glmer(factor(trt) ~ (1 | id), tidyr::drop_na(trial_group, trt, age, id), family = binomial) |> + anova(glmer(factor(trt) ~ age + (1 | id), tidyr::drop_na(trial_group, trt, age, id), family = binomial)) |> + tidy() |> + dplyr::pull(p.value) |> + dplyr::last() + ) +}) + +test_that("no error with missing data", { + expect_message( + t1 <- + mtcars |> + dplyr::mutate( + mpg = NA, + hp = NA, + has_banana = factor(NA, levels = c("Yes", "No")), + num_banana = factor(NA, levels = c("Zero", "1+")) + ) |> + dplyr::select(has_banana, num_banana, mpg, hp, am) |> + tbl_summary(by = "am", type = hp ~ "continuous") |> + add_p() + ) + + expect_equal( + t1 |> as_tibble(col_labels = FALSE) |> dplyr::pull(p.value), + rep_len(NA_character_, 10) + ) +}) + +# TODO: After add_difference() has been added, we need to re-add these tests! +test_that("add_p.tbl_summary() can be run after add_difference()", { + # expect_error( + # trial %>% + # select(age, trt) %>% + # tbl_summary(by = trt) %>% + # add_difference() %>% + # add_p(all_continuous() ~ "t.test") + # ) + + expect_snapshot( + error = TRUE, + trial |> + select(age, trt) |> + tbl_summary(by = trt) |> + add_p() |> + add_p() + ) + + # expect_error( + # trial %>% + # select(age, trt) %>% + # tbl_summary(by = trt) %>% + # add_difference() %>% + # add_difference() + # ) + # + # expect_error( + # tbl <- + # trial %>% + # select(age, trt) %>% + # tbl_summary( + # by = trt, + # missing = "no", + # statistic = all_continuous() ~ "{mean}", + # digits = all_continuous() ~ 3 + # ) %>% + # add_difference(all_continuous() ~ "cohens_d") %>% + # add_p(all_continuous() ~ "t.test") %>% + # as_tibble(col_labels = FALSE), + # NA + # ) + # expect_snapshot(tbl) + # + # expect_equal( + # tbl %>% + # unlist(), + # c( + # label = "Age", + # stat_1 = "47.011", + # stat_2 = "47.449", + # estimate = "-0.03", + # ci = "-0.32, 0.25", + # p.value = "0.8" + # ) + # ) + # expect_true( + # tbl %>% + # select(ends_with(".x") | ends_with(".y")) %>% + # names() %>% + # rlang::is_empty() + # ) +}) + + +test_that("addressing GH #1513, where the default test was incorrect", { + expect_equal( + # before the fix, this was defaulting to a chi-squared, when it should be fisher + tibble::tibble(type = character(), answer = character()) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "A", answer = "C1"), 5)) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "B", answer = "C1"), 10)) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "A", answer = "C2"), 100)) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "B", answer = "C2"), 305)) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "A", answer = NA), 400)) |> + tibble::add_row(tidyr::uncount(tibble::tibble(type = "B", answer = NA), 300)) |> + tbl_summary(by = type) |> + assign_tests(include = "answer", calling_fun ="add_p") |> + getElement(1L) |> + attr("test_name"), + "fisher.test" + ) +}) From cd7bdcfb718a48e548e9378080c07ba2a6df97c6 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 7 May 2024 16:33:14 -0700 Subject: [PATCH 51/74] Adding `add_difference.tbl_summary()` to v2 branch (#1634) * more progress * more updates * Update DESCRIPTION * Update DESCRIPTION * Update DESCRIPTION * Update DESCRIPTION * idk what's going on * Update DESCRIPTION * Update test-add_difference.tbl_summary.R * Update DESCRIPTION * emmeans updates * emmeans updates * Update DESCRIPTION * updates * Update utils-add_p_tests.R --- .github/workflows/R-CMD-check.yaml | 4 +- DESCRIPTION | 7 +- NAMESPACE | 4 + NEWS.md | 2 + R/add_difference.R | 217 +++++++ R/add_p.R | 124 +++- R/assign_tests.R | 42 +- R/import-standalone-checks.R | 23 +- R/import-standalone-forcats.R | 12 +- R/modify_column_merge.R | 100 +++ R/modify_header.R | 95 +++ R/sysdata.rda | Bin 3030 -> 3048 bytes R/utils-add_p_tests.R | 171 +++-- data-raw/gtsummary_tests.csv | 10 +- man/add_difference.Rd | 26 + man/add_difference.tbl_summary.Rd | 106 +++ man/add_p.Rd | 2 +- man/add_p.tbl_summary.Rd | 17 +- man/modify.Rd | 126 ++++ man/modify_column_hide.Rd | 1 + man/modify_column_merge.Rd | 80 +++ man/modify_fmt_fun.Rd | 1 + man/modify_table_body.Rd | 1 + man/modify_table_styling.Rd | 1 + man/tbl_summary.Rd | 3 + man/tests.Rd | 3 +- .../_snaps/add_difference.tbl_summary.md | 125 ++++ tests/testthat/_snaps/add_p.tbl_summary.md | 43 +- .../test-add_difference.tbl_summary.R | 608 ++++++++++++++++++ tests/testthat/test-add_p.tbl_summary.R | 102 ++- 30 files changed, 1872 insertions(+), 184 deletions(-) create mode 100644 R/add_difference.R create mode 100644 R/modify_column_merge.R create mode 100644 man/add_difference.Rd create mode 100644 man/add_difference.tbl_summary.Rd create mode 100644 man/modify.Rd create mode 100644 man/modify_column_merge.Rd create mode 100644 tests/testthat/_snaps/add_difference.tbl_summary.md create mode 100644 tests/testthat/test-add_difference.tbl_summary.R diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 3b2523dbf4..c1261daf5b 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -31,8 +31,8 @@ jobs: - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'oldrel-1'} - - {os: ubuntu-latest, r: 'oldrel-2'} - - {os: ubuntu-latest, r: 'oldrel-3'} + # - {os: ubuntu-latest, r: 'oldrel-2'} + # - {os: ubuntu-latest, r: 'oldrel-3'} # - {os: ubuntu-latest, r: 'oldrel-4'} env: diff --git a/DESCRIPTION b/DESCRIPTION index 2bba9b650e..9536f0ebd4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,7 @@ BugReports: https://github.com/ddsjoberg/gtsummary/issues Depends: R (>= 4.1) Imports: - cards (>= 0.1.0.9020), + cards (>= 0.1.0.9023), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), @@ -55,7 +55,7 @@ Imports: tibble (>= 3.2.1), tidyr (>= 1.3.0) Suggests: - cardx (>= 0.1.0.9033), + cardx (>= 0.1.0.9039), knitr, testthat (>= 3.2.0), withr @@ -66,9 +66,10 @@ RdMacros: Remotes: insightsengineering/cards, insightsengineering/cardx +Config/Needs/check: broom, broom.helpers, broom.mixed, lme4, effectsize, + emmeans, smd Config/testthat/edition: 3 Config/testthat/parallel: true -Config/Needs/check: broom, broom.helpers, lme4 Encoding: UTF-8 Language: en-US LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 3254432478..54a75a2e74 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(add_difference,tbl_summary) S3method(add_p,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) @@ -7,6 +8,7 @@ S3method(assign_tests,tbl_summary) S3method(print,gtsummary) export("%>%") export(.table_styling_expr_to_row_number) +export(add_difference) export(add_p) export(all_categorical) export(all_continuous) @@ -29,8 +31,10 @@ export(everything) export(last_col) export(matches) export(modify_column_hide) +export(modify_column_merge) export(modify_column_unhide) export(modify_fmt_fun) +export(modify_header) export(modify_table_body) export(modify_table_styling) export(mutate) diff --git a/NEWS.md b/NEWS.md index 00442c4664..e397b0ad19 100644 --- a/NEWS.md +++ b/NEWS.md @@ -26,6 +26,8 @@ * Previously, the gtsummary selecting functions, e.g. `all_categorical()`, `all_continuous()`, etc., would error if used out of context. They will now select no columns when used out-of-context. +* Added the following methods for calculating differences in `add_difference.tbl_summary()`: Hedge's G, Paired data Cohen's D, and Paired data Hedge's G. All three are powered by the {effectsize} package. + #### Internal Updates * Greater consistency has been put in place for all calculated statistics in gtsummary. Previously, each function handled its own calculations and transforming these statistics into data frames that would be printed. Now each function will first prepare an Analysis Result Dataset (ARD), and ARDs are converted to gtsummary structures using bridge functions (prefixed with `brdg_*()`). The bridge functions will be exported to allow anyone to more easily extend gtsummary functions. diff --git a/R/add_difference.R b/R/add_difference.R new file mode 100644 index 0000000000..4b49c1935f --- /dev/null +++ b/R/add_difference.R @@ -0,0 +1,217 @@ +#' Add differences +#' +#' - [`add_difference.tbl_summary()`] +#' +#' @param x (`gtsummary`)\cr +#' Object with class 'gtsummary' +#' @param ... Passed to other methods. +#' @keywords internal +#' @author Daniel D. Sjoberg +#' @export +#' +#' @seealso [`add_difference.tbl_summary()`] +add_difference <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_difference") +} + + +#' Add differences between groups +#' +#' Adds difference to tables created by [`tbl_summary()`]. +#' The difference between two groups (typically mean or rate difference) is added +#' to the table along with the difference's confidence interval and a p-value (when applicable). +#' +#' @param x (`tbl_summary`)\cr +#' table created with `tbl_summary()` +#' @param test ([`formula-list-selector`][syntax])\cr +#' Specifies the tests/methods to perform for each variable, e.g. +#' `list(all_continuous() ~ "t.test", all_dichotomous() ~ "prop.test", all_categorical(FALSE) ~ "smd")`. +#' +#' See below for details on default tests and [?tests][tests] for details on available +#' tests and creating custom tests. +#' @param estimate_fun ([`formula-list-selector`][syntax])\cr +#' List of formulas specifying the functions +#' to round and format differences and confidence limits. +#' Default is +#' `list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), all_categorical() ~ \(x) paste0(style_sigfig(x, scale = 100), "%"))` +#' @param conf.level (`numeric`)\cr +#' a scalar in `⁠(0, 1`)⁠ indicating the confidence level. Default is 0.95 +#' @inheritParams add_p.tbl_summary +#' +#' @export +#' @return a gtsummary table of class `"tbl_summary"` +#' +#' @examplesIf gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx") +#' # Example 1 ---------------------------------- +#' add_difference_ex1 <- +#' trial |> +#' select(trt, age, marker, response, death) %>% +#' tbl_summary( +#' by = trt, +#' statistic = +#' list( +#' all_continuous() ~ "{mean} ({sd})", +#' all_dichotomous() ~ "{p}%" +#' ), +#' missing = "no" +#' ) |> +#' # add_n() |> +#' add_difference() +#' +#' # Example 2 ---------------------------------- +#' # ANCOVA adjusted for grade and stage +#' add_difference_ex2 <- +#' trial |> +#' select(trt, age, marker, grade, stage) %>% +#' tbl_summary( +#' by = trt, +#' statistic = list(all_continuous() ~ "{mean} ({sd})"), +#' missing = "no", +#' include = c(age, marker, trt) +#' ) |> +#' # add_n() |> +#' add_difference(adj.vars = c(grade, stage)) +add_difference.tbl_summary <- function(x, + test = NULL, + group = NULL, + adj.vars = NULL, + test.args = NULL, + conf.level = 0.95, + include = everything(), + pvalue_fun = styfn_pvalue(), + estimate_fun = list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), + all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, paste0(style_sigfig(x, scale = 100), "%")), + all_tests("smd") ~ styfn_sigfig()), + ...) { + set_cli_abort_call() + # check/process inputs ------------------------------------------------------- + check_dots_empty() + updated_call_list <- c(x$call_list, list(add_p = match.call())) + + if (rlang::is_function(estimate_fun)) { + lifecycle::deprecate_stop( + "1.4.0", + "gtsummary::add_difference(estimate_fun = 'must be a list of forumulas')" + ) + } + + # checking that input x has a by var and it has two levels + if (is_empty(x$inputs$by) || dplyr::n_distinct(x$inputs$data[[x$inputs$by]], na.rm = TRUE) != 2L) { + "Cannot run {.fun add_difference} when {.code tbl_summary(by)} column does not have exactly two levels." |> + cli::cli_abort(call = get_cli_abort_call()) + } + + # if `pvalue_fun` not modified, check if we need to use a theme p-value + if (missing(pvalue_fun)) { + pvalue_fun <- + get_theme_element("add_p.tbl_summary-arg:pvalue_fun") %||% + get_theme_element("pkgwide-fn:pvalue_fun") %||% + pvalue_fun + } + pvalue_fun <- as_function(pvalue_fun) + + cards::process_selectors( + select_prep(x$table_body, x$inputs$data[x$inputs$include]), + include = {{ include }} + ) + + # checking for `tbl_summary(percent = c("cell", "row"))`, which don't apply + if (!x$inputs$percent %in% "column" && + any(unlist(x$inputs$type[include]) %in% c("categorical", "dichotomous"))) { + cli::cli_warn(c( + "The {.code add_difference()} results for categorical variables may not + compatible with {.code tbl_summary(percent = c('cell', 'row'))}.", + i = "Use column percentages instead, {.code tbl_summary(percent = 'column')}." + )) + } + + cards::process_selectors(x$inputs$data, group = {{ group }}, adj.vars = {{ adj.vars }}) + check_scalar(group, allow_empty = TRUE) + + cards::process_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + test = test, + include_env = TRUE + ) + # add the calling env to the test + test <- .add_env_to_list_elements(test, env = caller_env()) + + # select test ---------------------------------------------------------------- + test <- + assign_tests( + x = x, + test = test, + group = group, + adj.vars = adj.vars, + include = include, + calling_fun = "add_difference" + ) + + # add all available test meta data to a data frame --------------------------- + df_test_meta_data <- + imap( + test, + ~dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) + ) |> + dplyr::bind_rows() + + # add test names to `.$table_body` so it can be used in selectors ------------ + if (!"test_name" %in% names(x$table_body)) { + x$table_body <- + dplyr::left_join( + x$table_body, + df_test_meta_data[c("variable", "test_name")], + by = "variable" + ) |> + dplyr::relocate("test_name", .after = "variable") + } + else { + x$table_body <- + dplyr::rows_update( + x$table_body, + df_test_meta_data[c("variable", "test_name")], + by = "variable", + unmatched = "ignore" + ) |> + dplyr::relocate("test_name", .after = "variable") + } + + # now process the `test.args` and `estimate_fun` arguments ------------------- + cards::process_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + estimate_fun = estimate_fun + ) + # fill in unspecified variables + cards::fill_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + estimate_fun = eval(formals(asNamespace("gtsummary")[["add_difference.tbl_summary"]])[["estimate_fun"]]) + ) + + cards::process_formula_selectors( + select_prep(x$table_body, x$inputs$data[include]), + test.args = test.args + ) + cards::check_list_elements( + test.args, + predicate = \(x) is.list(x) && is_named(x), + error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", + i = "Value must be a named list.") + ) + + # calculate tests ------------------------------------------------------------ + x <- + calculate_and_add_test_results( + x = x, include = include, group = group, test.args = test.args, adj.vars = adj.vars, + df_test_meta_data = df_test_meta_data, conf.level = conf.level, + pvalue_fun = pvalue_fun, estimate_fun = estimate_fun, calling_fun = "add_difference" + ) + + # update call list + x$call_list <- updated_call_list + + x +} + + diff --git a/R/add_p.R b/R/add_p.R index 67b3bd33af..f5d333573e 100644 --- a/R/add_p.R +++ b/R/add_p.R @@ -1,4 +1,4 @@ -#' Adds P-value +#' Add p-values #' #' - [`add_p.tbl_summary()`] #' @@ -26,17 +26,8 @@ add_p <- function(x, ...) { #' Specifies the statistical tests to perform for each variable, e.g. #' `list(all_continuous() ~ "t.test", all_categorical() ~ "fisher.test")`. #' -#' See below for details on default tests and [tests] for details on available +#' See below for details on default tests and [?tests][tests] for details on available #' tests and creating custom tests. -#' -#' Common tests include `"t.test"`, `"aov"`, `"wilcox.test"`, `"kruskal.test"`, -#' `"chisq.test"`, `"fisher.test"`, and `"lme4"` (for clustered data). -#' See [tests] for details, more tests, and instruction for implementing a custom test. -#' -#' Default tests when `group` argument not specified are `"kruskal.test"` -#' for continuous variables (`"wilcox.test"` when "by" variable has two levels), -#' `"chisq.test.no.correct"` for categorical variables with all expected cell -#' counts >=5, and `"fisher.test"` for categorical variables with any expected cell count <5. #' @param pvalue_fun (`function`)\cr #' Function to round and format p-values. Default is `styfn_pvalue()`. #' The function must have a numeric vector input, and return a string that is @@ -61,8 +52,8 @@ add_p <- function(x, ...) { #' #' @section test argument: #' -#' See the [tests] help file for details on available tests and creating custom tests. -#' The [tests] help file also includes psuedo-code for each test to be clear +#' See the [?tests][tests] help file for details on available tests and creating custom tests. +#' The [?tests][tests] help file also includes psuedo-code for each test to be clear #' precisely how the calculation is performed. #' #' The default test used in `add_p()` primarily depends on these factors: @@ -141,7 +132,6 @@ add_p.tbl_summary <- function(x, # add the calling env to the test test <- .add_env_to_list_elements(test, env = caller_env()) - cards::check_list_elements( test, predicate = \(x) is.character(x) || is.function(x), @@ -211,11 +201,11 @@ add_p.tbl_summary <- function(x, i = "Value must be a named list.") ) - # calculate p-values --------------------------------------------------------- + # calculate tests ------------------------------------------------------------ x <- calculate_and_add_test_results( x = x, include = include, group = group, test.args = test.args, adj.vars = adj.vars, - df_test_meta_data = df_test_meta_data, calling_fun = "add_p" + df_test_meta_data = df_test_meta_data, pvalue_fun = pvalue_fun, calling_fun = "add_p" ) # update call list @@ -224,8 +214,9 @@ add_p.tbl_summary <- function(x, x } -calculate_and_add_test_results <- function(x, include, group, test.args, adj.vars, - df_test_meta_data, estimate_fun = NULL, +calculate_and_add_test_results <- function(x, include, group, test.args, adj.vars = NULL, + df_test_meta_data, pvalue_fun = NULL, + estimate_fun = NULL, conf.level = 0.95, calling_fun) { # list of ARDs or broom::tidy-like results lst_results <- @@ -247,7 +238,9 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var by = x$inputs$by, group = group, type = x$inputs$type[[variable]], - test.args = test.args[[variable]] + test.args = test.args[[variable]], + adj.vars = adj.vars, + conf.level = conf.level ) ) ) @@ -278,12 +271,22 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var # print any errors or warnings lst_results |> - map(\(x) if (inherits(x, "card")) x else NULL) |> + map( + \(x) { + if (inherits(x, "card")) { + x |> + dplyr::mutate( + across(c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")), ~unlist(.) |> as.character()) + ) + } + else NULL + } + ) |> dplyr::bind_rows() %>% {switch( !is_empty(.), dplyr::filter(., .data$stat_name %in% c("estimate", "std.error", "parameter", "statistic", - "conf.low", "conf.high", "p.value")) |> + "conf.low", "conf.high", "p.value")) |> cards::print_ard_conditions() )} @@ -331,7 +334,11 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var res } ) |> - dplyr::bind_rows() + dplyr::bind_rows() |> + dplyr::select( + any_of(c("variable", "estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value")) + ) # remove new columns that already exist in gtsummary table new_columns <- names(df_results) |> setdiff(names(x$table_body)) @@ -362,14 +369,14 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var unlist() |> unique() |> paste(collapse = "; ") - if (footnote == "" || is_empty(footnote)) footnote <- NULL + if (footnote == "" || is_empty(footnote)) footnote <- NULL # styler: off # add results to `.$table_body` ---------------------------------------------- x <- x |> modify_table_body( ~dplyr::left_join( .x, - df_results |> dplyr::mutate(row_type = "header"), + df_results[c("variable", new_columns)] |> dplyr::mutate(row_type = "header"), by = c("variable", "row_type") ) ) @@ -377,29 +384,76 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var x <- modify_table_styling( x, - columns = intersect("p.value", new_columns), + columns = any_of(intersect("p.value", new_columns)), label = "**p-value**", hide = FALSE, - fmt_fun = styfn_pvalue(), + fmt_fun = pvalue_fun %||% styfn_pvalue(), + footnote = footnote + ) |> + modify_table_styling( + columns = + intersect("estimate", new_columns), + hide = calling_fun %in% "add_p", + label = ifelse(is_empty(adj.vars), "**Difference**", "**Adjusted Difference**"), footnote = footnote ) |> modify_table_styling( columns = - intersect( - c("estimate", "std.error", "parameter", "statistic", "conf.low", "conf.high"), - new_columns - ), + intersect("std.error", new_columns), hide = TRUE, + label = "**Standard Error**", + footnote = footnote + ) |> + modify_table_styling( + columns = + intersect("parameter", new_columns), + hide = TRUE, + label = "**Parameter**", fmt_fun = styfn_sigfig(), footnote = footnote + ) |> + modify_table_styling( + columns = + intersect("statistic", new_columns), + hide = TRUE, + label = "**Statistic**", + fmt_fun = styfn_sigfig(), + footnote = footnote + ) |> + modify_table_styling( + columns = + intersect("conf.low", new_columns), + hide = calling_fun %in% "add_p", + label = glue("**{conf.level * 100}% CI**"), + footnote = footnote, + footnote_abbrev = "CI = Confidence Interval" ) - # adding labels for hidden columns + if (calling_fun %in% "add_difference" && all(c("conf.low", "conf.high") %in% new_columns)) { + x <- + modify_column_merge( + x, + pattern = "{conf.low}, {conf.high}", + rows = !is.na(.data$conf.low) + ) + } + + # add the specified formatting functions + for (i in seq_along(estimate_fun)) { + x <- + rlang::inject( + modify_table_styling( + x, + columns = any_of(c("estimate", "conf.low", "conf.high")), + rows = .data$variable %in% !!names(estimate_fun[i]), + fmt_fun = !!(estimate_fun[[i]] %||% styfn_sigfig()) + ) + ) + } + + # extending modify_stat_N to new columns x$table_styling$header <- x$table_styling$header |> - dplyr::mutate( - label = ifelse(.data$column %in% "statistic", "**Statistic**", .data$label) - ) |> - tidyr::fill("modify_stat_N", .direction = "downup") # fill missing N for new cols + tidyr::fill("modify_stat_N", .direction = "downup") # add raw results to `.$card` x$cards[[calling_fun]] <- lst_results diff --git a/R/assign_tests.R b/R/assign_tests.R index d9765adbe5..5f115386de 100644 --- a/R/assign_tests.R +++ b/R/assign_tests.R @@ -54,11 +54,19 @@ assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NU lapply( include, function(variable) { - if (is.null(test[[variable]]) && calling_fun %in% "add_p") { + if (is.null(test[[variable]])) { test[[variable]] <- - .add_p_tbl_summary_default_test(data, variable = variable, - by = by, group = group, adj.vars = adj.vars, - summary_type = summary_type[[variable]]) + switch( + calling_fun, + "add_p" = + .add_p_tbl_summary_default_test(data, variable = variable, + by = by, group = group, adj.vars = adj.vars, + summary_type = summary_type[[variable]]), + "add_difference" = + .add_difference_tbl_summary_default_test(data, variable = variable, + by = by, group = group, adj.vars = adj.vars, + summary_type = summary_type[[variable]]) + ) } if (is.null(test[[variable]])) { @@ -104,8 +112,8 @@ assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NU map_lgl(~identical_no_attr(eval(.x), test)) |> which() if (is.function(test) && !is_empty(internal_test_index)) { - test_to_return <- df_add_p_tests$fun_to_run[[internal_test_index]] |> eval() - attr(test_to_return, "test_name") <- df_add_p_tests$test_name[internal_test_index] + test_to_return <- df_tests$fun_to_run[[internal_test_index]] |> eval() + attr(test_to_return, "test_name") <- df_tests$test_name[internal_test_index] return(test_to_return) } @@ -191,3 +199,25 @@ identical_no_attr <- function(x, y) { return(NULL) } + + +.add_difference_tbl_summary_default_test <- function(data, variable, by, group, adj.vars, summary_type) { + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% c("continuous", "continuous2")) { + return("t.test") + } + if (is_empty(group) && summary_type %in% c("continuous", "continuous2")) { + return("ancova") + } + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% "dichotomous") { + return("prop.test") + } + if (is_empty(group) && is_empty(adj.vars) && summary_type %in% "categorical") { + return("smd") + } + + if (!is_empty(group) && summary_type %in% c("continuous", "continuous2")) { + return("ancova_lme4") + } + + return(NULL) +} diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index 5d13798221..88c255e3ad 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -5,7 +5,7 @@ # --- # repo: ddsjoberg/standalone # file: standalone-checks.R -# last-updated: 2024-04-10 +# last-updated: 2024-05-04 # license: https://unlicense.org # dependencies: standalone-cli_call_env.R # imports: [rlang, cli] @@ -244,6 +244,27 @@ check_scalar <- function(x, ) } +#' Check Number of Levels +#' +#' @param n_levels Number of required levels (after NA are removed). +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_n_levels <- function(x, + n_levels, + message = + "The {.arg {arg_name}} argument must have {.val {length}} levels.", + arg_name = rlang::caller_arg(x), + class = "check_n_levels", + call = get_cli_abort_call()) { + check_length( + x = stats::na.omit(x) |> unique(), + length = n_levels, message = message, + allow_empty = FALSE, arg_name = arg_name, + class = class, call = call + ) +} + #' Check Range #' #' @param x numeric scalar to check diff --git a/R/import-standalone-forcats.R b/R/import-standalone-forcats.R index db001fd9e3..22a9ef3494 100644 --- a/R/import-standalone-forcats.R +++ b/R/import-standalone-forcats.R @@ -4,7 +4,7 @@ # # --- # file: standalone-forcats.R -# last-updated: 2024-01-24 +# last-updated: 2024-05-04 # license: https://unlicense.org # imports: # --- @@ -35,5 +35,15 @@ fct_inorder <- function(f, ordered = NA) { ) } +fct_rev <- function(f) { + if (!inherits(f, "factor")) f <- factor(f) + + factor( + f, + levels = rev(levels(f)), + ordered = is.ordered(f) + ) +} + # nocov end # styler: on diff --git a/R/modify_column_merge.R b/R/modify_column_merge.R new file mode 100644 index 0000000000..2e606b76e3 --- /dev/null +++ b/R/modify_column_merge.R @@ -0,0 +1,100 @@ +#' Modify Column Merging +#' +#' Merge two or more columns in a gtsummary table. +#' Use `show_header_names()` to print underlying column names. +#' +#' @param pattern glue syntax string indicating how to merge columns in +#' `x$table_body`. For example, to construct a confidence interval +#' use `"{conf.low}, {conf.high}"`. +#' @inheritParams modify_table_styling +#' +#' @section Details: +#' 1. Calling this function merely records the instructions to merge columns. +#' The actual merging occurs when the gtsummary table is printed or converted +#' with a function like `as_gt()`. +#' 2. Because the column merging is delayed, it is recommended to perform +#' major modifications to the table, such as those with `tbl_merge()` and +#' `tbl_stack()`, before assigning merging instructions. Otherwise, +#' unexpected formatting may occur in the final table. +#' 3. If this functionality is used in conjunction with `tbl_stack()` (which +#' includes `tbl_uvregression()`), there may be potential issues with printing. +#' When columns are stack AND when the column-merging is +#' defined with a quosure, you may run into issues due to the loss of the +#' environment when 2 or more quosures are combined. If the expression +#' version of the quosure is the same as the quosure (i.e. no evaluated +#' objects), there should be no issues. +#' +#' This function is used internally with care, and **it is _not_ recommended for users**. +#' +#' @section Future Updates: +#' There are planned updates to the implementation of this function +#' with respect to the `pattern=` argument. +#' Currently, this function replaces a numeric column with a +#' formatted character column following `pattern=`. +#' Once `gt::cols_merge()` gains the `rows=` argument the +#' implementation will be updated to use it, which will keep +#' numeric columns numeric. For the _vast majority_ of users, +#' _the planned change will be go unnoticed_. +#' +#' @return gtsummary table +#' @export +#' +#' @family Advanced modifiers +#' @examplesIf gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx") +#' # Example 1 ---------------------------------- +#' modify_column_merge_ex1 <- +#' trial |> +#' tbl_summary(by = trt, missing = "no", include = c(age, marker, trt)) |> +#' add_p(all_continuous() ~ "t.test", pvalue_fun = styfn_pvalue(prepend_p = TRUE)) |> +#' modify_fmt_fun(statistic ~ styfn_sigfig()) |> +#' modify_column_merge(pattern = "t = {statistic}; {p.value}") |> +#' modify_header(statistic = "**t-test**") +#' +# #' # TODO: Re-add the second example after `tbl_regression()` is added +# #' # # Example 2 ---------------------------------- +# #' # modify_column_merge_ex2 <- +# #' # lm(marker ~ age + grade, trial) |> +# #' # tbl_regression() |> +# #' # modify_column_merge( +# #' # pattern = "{estimate} ({ci})", +# #' # rows = !is.na(estimate) +# #' # ) +modify_column_merge <- function(x, pattern, rows = NULL) { + set_cli_abort_call() + # check inputs --------------------------------------------------------------- + check_class(x, "gtsummary") + check_string(pattern) + updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) + + # extract columns from pattern ----------------------------------------------- + columns <- .extract_glue_elements(pattern) + if (is_empty(columns)) { + cli::cli_abort( + c("No column names found in {.code modify_column_merge(pattern)} argument.", + i = "Wrap all column names in curly brackets, e.g {.code modify_column_merge(pattern = '{{conf.low}}, {{conf.high}}')}."), + call = get_cli_abort_call() + ) + } + if (!all(columns %in% names(x$table_body))) { + problem_cols <- columns %>% setdiff(names(x$table_body)) + cli::cli_abort( + c("Columns specified in the {.code modify_column_merge(pattern)} argument are not present in table.", + "Columns {.val {problem_cols}} not found."), + call = get_cli_abort_call() + ) + } + + # merge columns -------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = columns[1], + rows = {{ rows }}, + hide = FALSE, + cols_merge_pattern = pattern, + ) + + # return gtsummary table ----------------------------------------------------- + x$call_list <- updated_call_list + x +} diff --git a/R/modify_header.R b/R/modify_header.R index ad9628bb5c..4722e0fd53 100644 --- a/R/modify_header.R +++ b/R/modify_header.R @@ -1,3 +1,98 @@ +#' Modify column headers, footnotes, spanning headers, and table captions +#' +#' These functions assist with updating or adding column headers +#' (`modify_header()`), footnotes (`modify_footnote()`), spanning +#' headers (`modify_spanning_header()`), and table captions +#' (`modify_caption()`). Use `show_header_names()` to learn +#' the column names. +#' +#' @name modify +#' @param x a gtsummary object +#' @param update,... use these arguments to assign updates to headers, +#' spanning headers, and footnotes. See examples below. +#' - `update` expects a list of assignments, with the variable name or selector +#' on the LHS of the formula, and the updated string on the RHS. Also accepts +#' a named list. +#' - `...` pass individual updates outside of a list, e.g, +#' `modify_header(p.value = "**P**", all_stat_cols() ~ "**{level}**")` +#' +#' Use the `show_header_names()` to see the column names that can be modified. +# #' @param abbreviation Logical indicating if an abbreviation is being updated. +#' @param text_interpret String indicates whether text will be interpreted with +#' [gt::md()] or [gt::html()]. Must be `"md"` (default) or `"html"`. +# #' @param caption a string of the table caption/title +# #' @param include_example logical whether to include print of `modify_header()` example +#' @param quiet (scalar `logical`)\cr +#' When `TRUE`, additional messaging is not printed. +#' TODO: Set defaults here and theme control of argument +# #' @inheritParams modify_table_styling +#' @family tbl_summary tools +#' @family tbl_svysummary tools +#' @family tbl_regression tools +#' @family tbl_uvregression tools +#' @family tbl_survfit tools +#' @author Daniel D. Sjoberg +#' +#' @section tbl_summary(), tbl_svysummary(), and tbl_cross(): +#' When assigning column headers, footnotes, spanning headers, and captions +#' for these gtsummary tables, +#' you may use `{N}` to insert the number of observations. +#' `tbl_svysummary` objects additionally have `{N_unweighted}` available. +#' +#' When there is a stratifying `by=` argument present, the following fields are +#' additionally available to stratifying columns: `{level}`, `{n}`, and `{p}` +#' (`{n_unweighted}` and `{p_unweighted}` for `tbl_svysummary` objects) +#' +#' Syntax follows [glue::glue()], e.g. `all_stat_cols() ~ "**{level}**, N = {n}"`. +#' @section tbl_regression(): +#' When assigning column headers for `tbl_regression` tables, +#' you may use `{N}` to insert the number of observations, and `{N_event}` +#' for the number of events (when applicable). +#' +#' @section captions: +#' Captions are assigned based on output type. +#' - `gt::gt(caption=)` +#' - `flextable::set_caption(caption=)` +#' - `huxtable::set_caption(value=)` +#' - `knitr::kable(caption=)` +#' +#' @examplesIf FALSE +#' \donttest{ +#' # create summary table +#' tbl <- trial[c("age", "grade", "trt")] %>% +#' tbl_summary(by = trt, missing = "no") %>% +#' add_p() +#' +#' # print the column names that can be modified +#' show_header_names(tbl) +#' +#' # Example 1 ---------------------------------- +#' # updating column headers, footnote, and table caption +#' modify_ex1 <- tbl %>% +#' modify_header(label = "**Variable**", p.value = "**P**") %>% +#' modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (%) for Grade") %>% +#' modify_caption("**Patient Characteristics** (N = {N})") +#' +#' # Example 2 ---------------------------------- +#' # updating headers, remove all footnotes, add spanning header +#' modify_ex2 <- tbl %>% +#' modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}%)") %>% +#' # use `modify_footnote(everything() ~ NA, abbreviation = TRUE)` to delete abbrev. footnotes +#' modify_footnote(update = everything() ~ NA) %>% +#' modify_spanning_header(all_stat_cols() ~ "**Treatment Received**") +#' +#' # Example 3 ---------------------------------- +#' # updating an abbreviation in table footnote +#' modify_ex3 <- +#' glm(response ~ age + grade, trial, family = binomial) %>% +#' tbl_regression(exponentiate = TRUE) %>% +#' modify_footnote(ci = "CI = Credible Interval", abbreviation = TRUE) +#' } +#' @return Updated gtsummary object +NULL + +#' @name modify +#' @export modify_header <- function(x, ..., text_interpret = c("md", "html"), quiet = NULL, update = NULL) { # process inputs ------------------------------------------------------------- diff --git a/R/sysdata.rda b/R/sysdata.rda index 0fcf7b2ea6d142b6557dfd7ec712caa5c81a10bd..696f0351681881cff1a5c24a14485de664f34c86 100644 GIT binary patch literal 3048 zcmVXaPV;Ko^EeMw8PdWC5T6G-S{k4FRJ@fukmx zdV!z-10m@HMu;!~OaKJH000000000000001rirGBDe8Jb=>Rm-)Bpw{p`$X1<| zf(fg39{TW7v*sRs;M9vfeIR? zniYDQHUnD~2e7gCSw=*u0?Vq}y!%x^QV_DEQ06nAjcV^OFZy}J5j;82JMj#nm=EXw z%Vb?71L~k25dtdWj6qohkPrz4NdZ`a6a@fd0TKd$Q35nThzTJeED(ew0!51UK?PWv z6Ahbb(S^lJ@2zKKN<7edp!U{*!d+Zx!>mueje^>X);tPM$qNgan?W5#x^|ZeLlC(V zB&daCiZxeQ#hsv;t;=YLBoToGSgKAW;zG_v#!sCRZ3!HqFxKH>aI{-A=xo%^BAL4a z#gWlcsVFe2f*DW;5uRZnlACIXlLZdS!b%xK5F}Y}sIme^K#&b0Qb?7H1Ueuny?`qO z0zw`j>U-yL=6UrlGAhl6V!$lI3KBy)ERl!`ECMM2h>?+jlta1$SOTbdq6#nOm&5JB zP&BOt#*|SL;6JE13I7EI*nYwro^yNOBqEa~efTCQ_rt<P(5fN|$jX|ji>Z3r44Z`qg$!u$QX_r@Ew(uWqCd9`pFd7rpamyq>(lUE#) zjr}+m4U$LHb*|{sXQ`yb%Z4grg|9M&#m2>wU410%IaH50)96WG-Kxu9yvF{)4=s_?{9Bd{IgNi z++cK!AZ6B*8tZ6ke){oYhf2f&Cz7>E8VzJz}`OMQGq%wn&P)W@3>6SqMZkzyZiD^*{m^ zCin%=m;oEWIU*D3!!;Za0fsFfPk%7q6y{$hWF)&S!HoDNFRg$Y8d&W=3Y@d zjNm$tvk&s$4(dal<^va4g-gGuR#5{{@qRM+e8xWw`_PmFmzcSS{ggH!yl3K|^y)!3 zk-T2h?wsXx6>hA0b5-vNdK49Y@(aGBsriVMN8(x~6RzNS3R4Y&nkK#${4=9h(XZEl!XZbjV?CApnPV<$vOJcd1SqQ*CFcl z2!0ctd>!Z+9wRW~d(e)HBFI48HC{5K&>bU&>$n$~RA`W(QpwgA09;qfTvW*n;mo!w zx1uMl1VcG&58OC|r%;D5L@_rA97a>LNEe7!n-RP`gs7Jg1FR1ikVDDSIyHlcny&Ba z(y4J$g?I54BImfc?$7J@7s(?7n?VbW zQanfdbB5&%S7Fa!Z%jN&^(Kg3q3Xc#fzf1tVc_SXJ4@4*4gE;aVF3ULug={&SEcfrDGPSW-|`m1b21J-Rq~dhBYNaat~P|csbDUf|rIo z4EVo--6(Rp)Gzx|5N4tLWCFYQl-gi~F*h88MW`vXTm3#M$9R|_-2)OOOkzCsq*|1e zj$O7ZCH&@R7j;X8BX}3bCD3m!@3Xi1^s zJXH%BE_?NfyYs;HOP9tGH6(KwhpDiT2sG_|ZS$te7vxbx+I9vZ$VZIz1gbrlJWw+B zdy@UPYDcL9p=ucf3mnY>qyXi-9pOO|oz&wA`KR2TSw3^r@_Iqy9cCYAzz3l^lrIbn zIq~$4&AnZ@4jsAh^XQ>`3edkogd_q&P>Dz^85oo(vtkunTIaGnW4NehhS95m11x}$ zW?`@jkPK7QF95%!)|dtEx*)mWTzE0L=1pbD?)+B9>;i{oBj%Rr{EzaXFHsB*Qvp+F zkh<|!ImbXrX?vPCNh?=Vi&7G@?cS7>H?=eUW0W|{WFrd z=xQ$19M(&!ZB2+#9KDe79wXV$tkhM?43_0}TTdFZs$-B-x0kg&BxI z_f9bWU~GoeZU*2gO5?sO&VKibuRZ2Ghmzl0KpccHgtcnoaS1lkL19U^YScu6kd?Gh z(NMU7UFBh_l{g$bF|lKd#$!@Y!=$_oc+hDOkdPT1(s2sCe)&yz!%;WbVH&Kpq_YvOHkgJhU2Gd@P|T2 zY6mYbHrfqp6%#*_VXF+*Yl>HwuzCfpeg%&bB@RwBTmJ<5GsLo ziGn{Ud)Fma3$b69*x+(x{3=7r6(C5$NYD@GYZKfr9M_yeBDtp;gN~LzlU5=09#GU6 z-E>bmN=ivP3vf9zDw_PC2Pjq6g(wXOfiLZ#l28!dn4M#AS1Zu9Tf!_NKJW$M2IOji zW~g&v?h}B(X#nU=T=qoCySfi@744C`ex`A!-0uuqPz3Uu*%(i%NYGynhq00000 z000000z{J_iIGpyJtk4KjP*98WO@)7N2p-{WO|!TH9bJ|^)&-SOoJcD%()E=N@ zXvv@frh$+e8UWBVXfzrP10c`U@1u4soDjcSYZ;Fu!0lo@IKrVxk6%BOm`gDYi5K+!0K+6inMdjH*UI0AX z4C60MhsU0m?93h)rA!C_NFfM3j>BTv0K61wUO}5nH+Ko0+>ZVfL_{_Y(5?wvD6`0k zTV%K$w>u9}N7;3gHHa5xooF)3&I6FeJ1U<_gYUJXCIcUrok0`Lu7k@E(kYPtpZ;G% z2_PRe0p<`Qu4u#+kVz2$kW`UHkOn{`0E|Kr0ze87Wgsy`l0aC5A`%3M!F!^DtWBh) z{JY~)0u!1?31IDtLubfs5^yjWReTuXhf1;qXR>aJ3eM>Zh=Vhf4Gu3?s`!!^Oc5eW ziaKglS@bBVR3>kJ^D_wsK!PrJCk*K!cMke*m0D_y%}C#0MkhxVvVQk1IgpUcfnv~{ zRMkR)^+=+20tGUtNHnIg$dV2rIudZ4A_R(jO1yxPkR(HFN|FVl!49a3FLDZ`6%jfd zN^9o!a;s1(kz|pv8qorzM3EITgn$u%NJxOlfG~p=A)G_m0kjcRJRpiM`AlK0iOoS{VpG$ru}VtcuT(7Xugwa&j0x5@QyWfFfeRfm;^HrHaCO>(+GToEmH28!svDmdaY{NtviXa+1nm1e0Fi zfU+I9AT|u(0@rG^j7RG}Eh4q8_SU4xt#_H5Oo6wFBlZBe8oeM4UKC>^2thGFTl9mD zA7Xq9WGiCTtQK3Aw3w0;?7^~$GazAl&oLT+#Ue1j*D3&?V=HO^bdq6^30K!E(WpYC zB?5L8E#%57(fmyY;5&%47o2WebtfHv*qf`B@~#X8-F?0(>2iPHhj(}~0f{mO2uxkH z34WUL22Jq=)JeV@lKtzOZZ>>%ki2HpO3k7#5{rbpjH46P4{7K!<(Ida*g>3G7-eEq zxj$#5&)RIm7$BH+_fYz@N zcx+6zr_JUM4qWoAEm{0}@NnnQGlFokzQ3B)a$K3U8x#T57Zphgz`l@P2_X9Nl>!*R z!dlA~!)O@oG$lfb0-C_z3jz1d%c67kr0|m!__+<`_y>%#xEIha3?k?+Tj)mdWLXFr zv8c8S4^VZETrlY|GO*G@g07vRfCdG;3=0||t{ls9%Zeg|? z1BlXhi31gFTam;)B(Rte1GEo7kVDhgI<^Ctny~Wf+hoA8MY=eP5q0n|Ja$ia$e%7) zo7ZSL`15;4G!xa;dB=L!+r^Si4NF#Q_#0d;3@Zs zmnPhW+>^6n>V7T9iRXI9jMiLx`NIV7)PanWFgdn}U}}-#KNmP~P|bH7_XiZq&aaU+ zp^Askf#?IO=>B8e=c0F*rz#yDKxknIK}tn*JiwL)$Qxjxuqg^O6M+KAew`b`B-nEj zPe&Y#WTSpYt_%oFYqHyQEMO&iEfWzX;==;U7$~BFW|?~i&02^tE9nJ2*2X7rvkVDi z#zui!2xf3O2A0UC@p1L>PCP`(4;UGdEN2ntwMDT~qo;k#Nsl?K;_WLg zXbV5$_bn(~kh(dPI_!nuxh)q`C{clA3!a(a(I(T*dF&T7U40t_;r@_5d4l=^CZvwB zh^xeUjauMS_f>|Eyo+ui7{wa?9H6!Fe>RSeZ0_QV8)Bxqg z9)O_|rr@80_})hRC!5F09$>E(^|*j?(W;P8D=X2nDXpQa#k5&>Yv}cDP{swQ$7w_) z0zy#|l0=IbQ6VF}D!aBHzE7NasWMLEt3)+w0zsO?a26mLr>w*S9YqxQ#ML+1g8(9H~f=~bd`_cRpqBQyvfSl%DF4bbFA0B{19yl2#&+x(tZ z-qZEo!{)i(zy`w#kfj=$+QM9hBsPd=g{!P!k_gwDiA5#^0=;#9x>V^pd-J(-i_&Le zQI}bW8#AG(goJ>|>q*2a`F~)r?Ac1bp3B9*I;EJgERF_Y179Z?@uA5OeUKjVa*!mD zBq1u0kq?{e({K!N3U;B@2ii}a5GwR^CSkzq-n}sDNbf-9<>vKF;_0Z4!Wg5LW|u7PsP)j0K1 z)j!o0Rw{=g|1v%vO)={(^b diff --git a/R/utils-add_p_tests.R b/R/utils-add_p_tests.R index b67651e545..506e9c3c82 100644 --- a/R/utils-add_p_tests.R +++ b/R/utils-add_p_tests.R @@ -1,9 +1,7 @@ # add_p.tbl_summary ------------------------------------------------------------ -# TODO: how to handle wilcox test with CIs? add them by default? separate test that includes CIs? - add_p_test_t.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_t_test( @@ -16,15 +14,17 @@ add_p_test_t.test <- function(data, variable, by, test.args, conf.level = 0.95, ) } -add_p_test_wilcox.test <- function(data, variable, by, test.args, ...) { +add_p_test_wilcox.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_wilcox_test( data = data, variable = all_of(variable), by = all_of(by), + conf.int = TRUE, + conf.level = conf.level, !!!test.args ) ) |> @@ -37,9 +37,10 @@ add_p_test_wilcox.test <- function(data, variable, by, test.args, ...) { ) } + add_p_test_mcnemar.test <- function(data, variable, by, group, test.args, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("adj.vars"), ...) + check_empty(c("adj.vars"), ...) check_length(group, 1L) warn_unbalanced_pairs(data, by, variable, group) @@ -56,7 +57,7 @@ add_p_test_mcnemar.test <- function(data, variable, by, group, test.args, ...) { add_p_test_mcnemar.test_wide <- function(data, variable, by, test.args, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_mcnemar_test( @@ -70,7 +71,7 @@ add_p_test_mcnemar.test_wide <- function(data, variable, by, test.args, ...) { add_p_test_chisq.test <- function(data, variable, by, test.args, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_chisq_test( @@ -96,7 +97,7 @@ add_p_test_chisq.test.no.correct <- function(data, variable, by, test.args, ...) add_p_test_mood.test <- function(data, variable, by, test.args, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_mood_test( @@ -111,7 +112,7 @@ add_p_test_mood.test <- function(data, variable, by, test.args, ...) { add_p_test_kruskal.test <- function(data, variable, by, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars", "test.args"), ...) + check_empty(c("group", "adj.vars", "test.args"), ...) cardx::ard_stats_kruskal_test( data = data, @@ -122,7 +123,7 @@ add_p_test_kruskal.test <- function(data, variable, by, ...) { add_p_test_fisher.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_fisher_test( @@ -155,7 +156,7 @@ add_p_test_aov <- function(data, variable, by, ...) { add_p_test_oneway.test <- function(data, variable, by, test.args, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_stats_oneway_test( @@ -168,7 +169,7 @@ add_p_test_oneway.test <- function(data, variable, by, test.args, ...) { add_p_test_mood.test <- function(data, variable, by, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars", "test.args"), ...) + check_empty(c("group", "adj.vars", "test.args"), ...) rlang::inject( cardx::ard_stats_mood_test( @@ -182,7 +183,7 @@ add_p_test_mood.test <- function(data, variable, by, ...) { add_p_test_lme4 <- function(data, variable, by, group, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") check_pkg_installed("lme4", reference_pkg = "cardx") - check_null(c("test.args", "adj.vars"), ...) + check_empty(c("test.args", "adj.vars"), ...) if (is_empty(group)) { cli::cli_abort("The {.arg group} argument cannot be missing for {.val lme4} tests.") @@ -213,7 +214,7 @@ add_p_tbl_summary_paired.t.test <- function(data, variable, by, group, test.args check_pkg_installed("cardx", reference_pkg = "gtsummary") check_length(group, 1L) warn_unbalanced_pairs(data, by, variable, group) - check_null(c("adj.vars"), ...) + check_empty(c("adj.vars"), ...) rlang::inject( cardx::ard_stats_paired_t_test( @@ -229,7 +230,7 @@ add_p_tbl_summary_paired.t.test <- function(data, variable, by, group, test.args add_p_tbl_summary_paired.wilcox.test <- function(data, variable, by, group, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("adj.vars"), ...) + check_empty(c("adj.vars"), ...) check_length(group, 1L) warn_unbalanced_pairs(data, by, variable, group) @@ -247,7 +248,7 @@ add_p_tbl_summary_paired.wilcox.test <- function(data, variable, by, group, test add_p_test_prop.test <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("adj.vars", "group"), ...) + check_empty(c("adj.vars", "group"), ...) rlang::inject( cardx::ard_stats_prop_test( @@ -260,23 +261,18 @@ add_p_test_prop.test <- function(data, variable, by, test.args, conf.level = 0.9 ) } -add_p_test_ancova <- function(data, variable, by, adj.vars, ...) { +add_p_test_ancova <- function(data, variable, by, adj.vars = NULL, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "test.args"), ...) - - if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) { - cli::cli_abort( - c("Error in {.val ancova} model for variable {.val {variable}}.", - i = "This inplementation requires the {.val by} variable to have {.val {2}} levels, - but it has {.val {dplyr::n_distinct(data[[by]], na.rm = TRUE)}}"), - call = get_cli_abort_call() - ) - } + check_empty(c("group", "test.args"), ...) + check_n_levels(data[[by]], 2L, message = "The {.arg by} column must have {.val {length}} levels.") + + # reverse coding the 'by' variable + data[[by]] <- fct_rev(factor(data[[by]])) cardx::ard_regression_basic( x = cardx::construct_model( - data = data, + x = data, formula = cardx::reformulate2(c(by, adj.vars), response = variable), method = "lm" ) @@ -291,27 +287,35 @@ add_p_test_ancova <- function(data, variable, by, adj.vars, ...) { dplyr::mutate( stat = "method", stat_name = "method", + stat_label = "method", stat = dplyr::case_when( - is.null(adj.vars) ~ "One-way ANOVA", - TRUE ~ "ANCOVA" + is.null(adj.vars) ~ list("One-way ANOVA"), + TRUE ~ list("ANCOVA") ), fmt_fun = list(NULL) ) + ) |> + dplyr::select(-cards::all_ard_variables("levels")) |> + dplyr::mutate( + group1 = .env$by, + variable = .env$variable, + .before = 1L ) } add_p_test_cohens_d <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_effectsize_cohens_d( data = data, variable = all_of(variable), by = all_of(by), - ci = conf.level, + conf.level = conf.level, + verbose = FALSE, !!!test.args ) ) @@ -319,7 +323,7 @@ add_p_test_cohens_d <- function(data, variable, by, test.args, conf.level = 0.95 add_p_test_paired_cohens_d <- function(data, variable, by, test.args, group, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("adj.vars"), ...) + check_empty(c("adj.vars"), ...) check_length(group, 1L) warn_unbalanced_pairs(data, by, variable, group) @@ -329,7 +333,8 @@ add_p_test_paired_cohens_d <- function(data, variable, by, test.args, group, con variable = all_of(variable), by = all_of(by), id = all_of(group), - ci = conf.level, + conf.level = conf.level, + verbose = FALSE, !!!test.args ) ) @@ -337,14 +342,15 @@ add_p_test_paired_cohens_d <- function(data, variable, by, test.args, group, con add_p_test_hedges_g <- function(data, variable, by, test.args, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars"), ...) + check_empty(c("group", "adj.vars"), ...) rlang::inject( cardx::ard_effectsize_hedges_g( data = data, variable = all_of(variable), by = all_of(by), - ci = conf.level, + conf.level = conf.level, + verbose = FALSE, !!!test.args ) ) @@ -352,7 +358,7 @@ add_p_test_hedges_g <- function(data, variable, by, test.args, conf.level = 0.95 add_p_test_paired_hedges_g <- function(data, variable, by, test.args, group, conf.level = 0.95, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("adj.vars"), ...) + check_empty(c("adj.vars"), ...) check_length(group, 1L) warn_unbalanced_pairs(data, by, variable, group) @@ -362,7 +368,8 @@ add_p_test_paired_hedges_g <- function(data, variable, by, test.args, group, con variable = all_of(variable), by = all_of(by), id = all_of(group), - ci = conf.level, + conf.level = conf.level, + verbose = FALSE, !!!test.args ) ) @@ -370,19 +377,20 @@ add_p_test_paired_hedges_g <- function(data, variable, by, test.args, group, con add_p_test_smd <- function(data, variable, by, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("group", "adj.vars", "test.args"), ...) + check_empty(c("group", "adj.vars", "test.args"), ...) cardx::ard_smd_smd( data = data, variable = all_of(variable), - by = all_of(by) + by = all_of(by), + std.error = TRUE ) } -add_p_test_emmeans <- function(data, variable, by, adj.vars, conf.level = 0.95, +add_p_test_emmeans <- function(data, variable, by, adj.vars = NULL, conf.level = 0.95, type, group = NULL, ...) { check_pkg_installed("cardx", reference_pkg = "gtsummary") - check_null(c("test.args"), ...) + check_empty(c("test.args"), ...) if (!is.null(group)) check_pkg_installed("lme4", reference_pkg = "cardx") if (inherits(data, "survey.design")) check_pkg_installed("survey", reference_pkg = "cardx") @@ -416,11 +424,11 @@ add_p_test_emmeans <- function(data, variable, by, adj.vars, conf.level = 0.95, # styler: off method.args <- list() package <- "base" - if (is.data.frame(data) && is.null(group) && type %in% "continuous") { + if (is.data.frame(data) && is_empty(group) && type %in% c("continuous", "continuous2")) { method <- "lm" } - else if (is.data.frame(data) && is.null(group) && type %in% "dichotomous") { - method <- "lm" + else if (is.data.frame(data) && is_empty(group) && type %in% "dichotomous") { + method <- "glm" method.args <- list(family = stats::binomial()) } else if (inherits(data, "survey.design")) { @@ -428,10 +436,13 @@ add_p_test_emmeans <- function(data, variable, by, adj.vars, conf.level = 0.95, method <- "svyglm" if (type %in% "dichotomous") method.args <- list(family = stats::binomial()) } - else if (is.data.frame(data) && !is.null(group)) { + else if (is.data.frame(data) && !is_empty(group)) { package <- "lme4" - method <- "glmer" - if (type %in% "dichotomous") method.args <- list(family = stats::binomial()) + if (type %in% "dichotomous") { + method <- "glmer" + method.args <- list(family = stats::binomial()) + } + else method <- "lmer" } # styler: on @@ -444,9 +455,66 @@ add_p_test_emmeans <- function(data, variable, by, adj.vars, conf.level = 0.95, response_type = type, conf.level = conf.level, primary_covariate = by - ) + ) |> + dplyr::select(-cards::all_ard_variables("levels")) |> + dplyr::mutate( + group1 = .env$by, + variable = .env$variable, + .before = 1L + ) +} + +add_p_test_ancova_lme4 <- function(data, variable, by, group, conf.level = 0.95, adj.vars = NULL, ...) { + check_pkg_installed("cardx", reference_pkg = "gtsummary") + check_empty(c("test.args"), ...) + check_length(group, 1L) + + # reverse coding the 'by' variable + data[[by]] <- fct_rev(factor(data[[by]])) + + # building model + cardx::ard_regression_basic( + x = + cardx::construct_model( + x = data, + formula = + stats::reformulate( + termlabels = c(cardx::bt(c(by, adj.vars)), glue("(1 | {cardx::bt(group)})")), + response = cardx::bt(variable) + ), + method = "lmer", + package = "lme4" + ), + effects = "fixed" + ) |> + dplyr::filter( + .data$variable %in% .env$by, + .data$stat_name %in% c("estimate", "std.error", "statistic", "conf.low", "conf.high", "p.value") + ) %>% + dplyr::bind_rows( + ., + dplyr::filter(., dplyr::row_number() == 1L) |> + dplyr::mutate( + stat = "method", + stat_name = "method", + stat_label = "method", + stat = + dplyr::case_when( + is.null(adj.vars) ~ list("One-way ANOVA with random intercept"), + TRUE ~ list("ANCOVA with random intercept") + ), + fmt_fun = list(NULL) + ) + ) |> + dplyr::select(-cards::all_ard_variables("levels")) |> + dplyr::mutate( + group1 = .env$by, + variable = .env$variable, + .before = 1L + ) } + # UTILITY FUNCTIONS ------------------------------------------------------------ .extract_data_frame <- function(x) { if (is.data.frame(x)) { @@ -479,7 +547,7 @@ warn_unbalanced_pairs <- function(data, by, variable, group) { invisible() } -check_null <- function(x, variable = get("variable", envir = caller_env()), +check_empty <- function(x, variable = get("variable", envir = caller_env()), call = get_cli_abort_call(), ...) { dots <- dots_list(...) walk( @@ -496,3 +564,4 @@ check_null <- function(x, variable = get("variable", envir = caller_env()), invisible() } + diff --git a/data-raw/gtsummary_tests.csv b/data-raw/gtsummary_tests.csv index 9af1a00566..5591b4f18f 100644 --- a/data-raw/gtsummary_tests.csv +++ b/data-raw/gtsummary_tests.csv @@ -4,7 +4,7 @@ tbl_summary,TRUE,FALSE,,stats,aov,stats::aov,gtsummary:::add_p_test_aov,FALSE,"a tbl_summary,TRUE,FALSE,,stats,mood.test,stats::mood.test,gtsummary:::add_p_test_mood.test,TRUE,"mood.test(variable ~ as.factor(by), data = data, ...) ",Mood two-sample test of scale,Not to be confused with the Brown-Mood test of medians tbl_summary,TRUE,FALSE,,stats,oneway.test,stats::oneway.test,gtsummary:::add_p_test_oneway.test,TRUE,"oneway.test(variable ~ as.factor(by), data = data, ...) ",One-way ANOVA, tbl_summary,TRUE,FALSE,,stats,kruskal.test,stats::kruskal.test,gtsummary:::add_p_test_kruskal.test,FALSE,"kruskal.test(data[[variable]], as.factor(data[[by]]))",Kruskal-Wallis test, -tbl_summary,TRUE,FALSE,,stats,wilcox.test,stats::wilcox.test,gtsummary:::add_p_test_wilcox.test,TRUE,"wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, ...)",Wilcoxon rank-sum test, +tbl_summary,TRUE,TRUE,,stats,wilcox.test,stats::wilcox.test,gtsummary:::add_p_test_wilcox.test,TRUE,"wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, conf.int = TRUE, conf.level = conf.level, ...)",Wilcoxon rank-sum test, tbl_summary,TRUE,FALSE,,stats,chisq.test,stats::chisq.test,gtsummary:::add_p_test_chisq.test,TRUE,"chisq.test(x = data[[variable]], y = as.factor(data[[by]]), ...)",chi-square test of independence, tbl_summary,TRUE,FALSE,,stats,chisq.test.no.correct,,gtsummary:::add_p_test_chisq.test.no.correct,FALSE,"chisq.test(x = data[[variable]], y = as.factor(data[[by]]), correct = FALSE)",chi-square test of independence, tbl_summary,TRUE,FALSE,,stats,fisher.test,stats::fisher.test,gtsummary:::add_p_test_fisher.test,TRUE,"fisher.test(data[[variable]], as.factor(data[[by]]), conf.level = 0.95, ...)",Fisher's exact test, @@ -16,10 +16,10 @@ tbl_summary,TRUE,FALSE,,stats,paired.wilcox.test,,gtsummary:::add_p_tbl_summary_ tbl_summary,TRUE,TRUE,rate difference,stats,prop.test,stats::prop.test,gtsummary:::add_p_test_prop.test,TRUE,"prop.test(x, n, conf.level = 0.95, ...)",Test for equality of proportions, tbl_summary,TRUE,TRUE,mean difference,stats,ancova,,gtsummary:::add_p_test_ancova,FALSE,lm(variable ~ by + adj.vars),ANCOVA, tbl_summary,FALSE,TRUE,mean difference,stats,ancova_lme4,,gtsummary:::add_p_test_ancova_lme4,FALSE,"lme4::lmer(variable ~ by + adj.vars + (1 \UFF5C group), data)",ANCOVA with random intercept, -tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,cohens_d,effectsize::cohens_d,gtsummary:::add_p_test_cohens_d,TRUE,"effectsize::cohens_d(variable ~ by, data, ci = conf.level, ...)",Cohen's D, -tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,hedges_g,effectsize::hedges_g,gsummary:::add_p_test_hedges_g,TRUE,"effectsize::hedges_g(variable ~ by, data, ci = conf.level, ...)",Hedge's G, -tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_cohens_d,,gtsummary:::add_p_test_paired_cohens_d,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::cohens_d(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)",Paired Cohen's D, -tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_hedges_g,,gtsummary:::add_p_test_paired_hedges_g,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::hedges_g(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)",Paired Hedge's G, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,cohens_d,effectsize::cohens_d,gtsummary:::add_p_test_cohens_d,TRUE,"effectsize::cohens_d(variable ~ by, data, ci = conf.level, verbose = FALSE, ...)",Cohen's D, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,hedges_g,effectsize::hedges_g,gtsummary:::add_p_test_hedges_g,TRUE,"effectsize::hedges_g(variable ~ by, data, ci = conf.level, verbose = FALSE, ...)",Hedge's G, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_cohens_d,,gtsummary:::add_p_test_paired_cohens_d,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::cohens_d(by_1, by_2, paired = TRUE, conf.level = 0.95, verbose = FALSE, ...)",Paired Cohen's D, +tbl_summary,FALSE,TRUE,standardized mean difference,effectsize,paired_hedges_g,,gtsummary:::add_p_test_paired_hedges_g,TRUE,"tidyr::pivot_wider(id_cols = group, ...); effectsize::hedges_g(by_1, by_2, paired = TRUE, conf.level = 0.95, verbose = FALSE, ...)",Paired Hedge's G, tbl_summary,FALSE,TRUE,standardized mean difference,smd,smd,,gtsummary:::add_p_test_smd,FALSE,"smd::smd(x = data[[variable]], g = data[[by]], std.error = TRUE)",Standardized Mean Difference, tbl_summary,TRUE,TRUE,adjusted mean difference,emmeans,emmeans,emmeans::emmeans,gtsummary:::add_p_test_emmeans,FALSE,"lm(variable ~ by + adj.vars, data) %>% emmeans::emmeans(specs =~by) %>% emmeans::contrast(method = ""pairwise"") %>% summary(infer = TRUE, level = conf.level)",Estimated Marginal Means or LS-means,"When variable is binary, `glm(family = binomial)` and `emmeans(regrid = ""response"")` arguments are used. When `group` is specified, `lme4::lmer()` and `lme4::glmer()` are used with the group as a random intercept." tbl_svysummary,FALSE,TRUE,standardized mean difference,smd,smd,,gtsummary:::add_p_test_smd,FALSE,"smd::smd(x = data$variables[[variable]], g = data$variables[[by]], w = weights(data), std.error = TRUE)",Standardized Mean Difference, diff --git a/man/add_difference.Rd b/man/add_difference.Rd new file mode 100644 index 0000000000..bf31bfa054 --- /dev/null +++ b/man/add_difference.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_difference.R +\name{add_difference} +\alias{add_difference} +\title{Add differences} +\usage{ +add_difference(x, ...) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +Object with class 'gtsummary'} + +\item{...}{Passed to other methods.} +} +\description{ +\itemize{ +\item \code{\link[=add_difference.tbl_summary]{add_difference.tbl_summary()}} +} +} +\seealso{ +\code{\link[=add_difference.tbl_summary]{add_difference.tbl_summary()}} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/add_difference.tbl_summary.Rd b/man/add_difference.tbl_summary.Rd new file mode 100644 index 0000000000..d9774f8f9b --- /dev/null +++ b/man/add_difference.tbl_summary.Rd @@ -0,0 +1,106 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_difference.R +\name{add_difference.tbl_summary} +\alias{add_difference.tbl_summary} +\title{Add differences between groups} +\usage{ +\method{add_difference}{tbl_summary}( + x, + test = NULL, + group = NULL, + adj.vars = NULL, + test.args = NULL, + conf.level = 0.95, + include = everything(), + pvalue_fun = styfn_pvalue(), + estimate_fun = list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), + all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, + paste0(style_sigfig(x, scale = 100), "\%")), all_tests("smd") ~ styfn_sigfig()), + ... +) +} +\arguments{ +\item{x}{(\code{tbl_summary})\cr +table created with \code{tbl_summary()}} + +\item{test}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the tests/methods to perform for each variable, e.g. +\code{list(all_continuous() ~ "t.test", all_dichotomous() ~ "prop.test", all_categorical(FALSE) ~ "smd")}. + +See below for details on default tests and \link[=tests]{?tests} for details on available +tests and creating custom tests.} + +\item{group}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variable name of an ID or grouping variable. The column can be used to +calculate p-values with correlated data. +Default is \code{NULL}. See \link{tests} for methods that utilize the \code{group} argument.} + +\item{adj.vars}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in adjusted calculations (e.g. in ANCOVA models). +Default is \code{NULL}.} + +\item{test.args}{(\code{\link[=syntax]{formula-list-selector}})\cr +Containing additional arguments to pass to tests that accept arguments. +For example, add an argument for all t-tests, use +\code{test.args = all_tests("t.test") ~ list(var.equal = TRUE)}.} + +\item{conf.level}{(\code{numeric})\cr +a scalar in \verb{⁠(0, 1})⁠ indicating the confidence level. Default is 0.95} + +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in output. Default is \code{everything()}.} + +\item{pvalue_fun}{(\code{function})\cr +Function to round and format p-values. Default is \code{styfn_pvalue()}. +The function must have a numeric vector input, and return a string that is +the rounded/formatted p-value (e.g. \code{pvalue_fun = styfn_pvalue(digits = 2)}).} + +\item{estimate_fun}{(\code{\link[=syntax]{formula-list-selector}})\cr +List of formulas specifying the functions +to round and format differences and confidence limits. +Default is +\verb{list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), all_categorical() ~ \\(x) paste0(style_sigfig(x, scale = 100), "\%"))}} + +\item{...}{Not used} +} +\value{ +a gtsummary table of class \code{"tbl_summary"} +} +\description{ +Adds difference to tables created by \code{\link[=tbl_summary]{tbl_summary()}}. +The difference between two groups (typically mean or rate difference) is added +to the table along with the difference's confidence interval and a p-value (when applicable). +} +\examples{ +\dontshow{if (gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +# Example 1 ---------------------------------- +add_difference_ex1 <- + trial |> + select(trt, age, marker, response, death) \%>\% + tbl_summary( + by = trt, + statistic = + list( + all_continuous() ~ "{mean} ({sd})", + all_dichotomous() ~ "{p}\%" + ), + missing = "no" + ) |> + # add_n() |> + add_difference() + +# Example 2 ---------------------------------- +# ANCOVA adjusted for grade and stage +add_difference_ex2 <- + trial |> + select(trt, age, marker, grade, stage) \%>\% + tbl_summary( + by = trt, + statistic = list(all_continuous() ~ "{mean} ({sd})"), + missing = "no", + include = c(age, marker, trt) + ) |> + # add_n() |> + add_difference(adj.vars = c(grade, stage)) +\dontshow{\}) # examplesIf} +} diff --git a/man/add_p.Rd b/man/add_p.Rd index e75c22c0aa..aade90d100 100644 --- a/man/add_p.Rd +++ b/man/add_p.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/add_p.R \name{add_p} \alias{add_p} -\title{Adds P-value} +\title{Add p-values} \usage{ add_p(x, ...) } diff --git a/man/add_p.tbl_summary.Rd b/man/add_p.tbl_summary.Rd index 741d38ece7..c14886804f 100644 --- a/man/add_p.tbl_summary.Rd +++ b/man/add_p.tbl_summary.Rd @@ -23,17 +23,8 @@ table created with \code{tbl_summary()}} Specifies the statistical tests to perform for each variable, e.g. \code{list(all_continuous() ~ "t.test", all_categorical() ~ "fisher.test")}. -See below for details on default tests and \link{tests} for details on available -tests and creating custom tests. - -Common tests include \code{"t.test"}, \code{"aov"}, \code{"wilcox.test"}, \code{"kruskal.test"}, -\code{"chisq.test"}, \code{"fisher.test"}, and \code{"lme4"} (for clustered data). -See \link{tests} for details, more tests, and instruction for implementing a custom test. - -Default tests when \code{group} argument not specified are \code{"kruskal.test"} -for continuous variables (\code{"wilcox.test"} when "by" variable has two levels), -\code{"chisq.test.no.correct"} for categorical variables with all expected cell -counts >=5, and \code{"fisher.test"} for categorical variables with any expected cell count <5.} +See below for details on default tests and \link[=tests]{?tests} for details on available +tests and creating custom tests.} \item{pvalue_fun}{(\code{function})\cr Function to round and format p-values. Default is \code{styfn_pvalue()}. @@ -68,8 +59,8 @@ Adds p-values to tables created by \code{\link[=tbl_summary]{tbl_summary()}} by \section{test argument}{ -See the \link{tests} help file for details on available tests and creating custom tests. -The \link{tests} help file also includes psuedo-code for each test to be clear +See the \link[=tests]{?tests} help file for details on available tests and creating custom tests. +The \link[=tests]{?tests} help file also includes psuedo-code for each test to be clear precisely how the calculation is performed. The default test used in \code{add_p()} primarily depends on these factors: diff --git a/man/modify.Rd b/man/modify.Rd new file mode 100644 index 0000000000..4643a98215 --- /dev/null +++ b/man/modify.Rd @@ -0,0 +1,126 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_header.R +\name{modify} +\alias{modify} +\alias{modify_header} +\title{Modify column headers, footnotes, spanning headers, and table captions} +\usage{ +modify_header( + x, + ..., + text_interpret = c("md", "html"), + quiet = NULL, + update = NULL +) +} +\arguments{ +\item{x}{a gtsummary object} + +\item{text_interpret}{String indicates whether text will be interpreted with +\code{\link[gt:md]{gt::md()}} or \code{\link[gt:html]{gt::html()}}. Must be \code{"md"} (default) or \code{"html"}.} + +\item{quiet}{(scalar \code{logical})\cr +When \code{TRUE}, additional messaging is not printed. +TODO: Set defaults here and theme control of argument} + +\item{update, ...}{use these arguments to assign updates to headers, +spanning headers, and footnotes. See examples below. +\itemize{ +\item \code{update} expects a list of assignments, with the variable name or selector +on the LHS of the formula, and the updated string on the RHS. Also accepts +a named list. +\item \code{...} pass individual updates outside of a list, e.g, +\code{modify_header(p.value = "**P**", all_stat_cols() ~ "**{level}**")} +} + +Use the \code{show_header_names()} to see the column names that can be modified.} +} +\value{ +Updated gtsummary object +} +\description{ +These functions assist with updating or adding column headers +(\code{modify_header()}), footnotes (\code{modify_footnote()}), spanning +headers (\code{modify_spanning_header()}), and table captions +(\code{modify_caption()}). Use \code{show_header_names()} to learn +the column names. +} +\section{tbl_summary(), tbl_svysummary(), and tbl_cross()}{ + +When assigning column headers, footnotes, spanning headers, and captions +for these gtsummary tables, +you may use \code{{N}} to insert the number of observations. +\code{tbl_svysummary} objects additionally have \code{{N_unweighted}} available. + +When there is a stratifying \verb{by=} argument present, the following fields are +additionally available to stratifying columns: \code{{level}}, \code{{n}}, and \code{{p}} +(\code{{n_unweighted}} and \code{{p_unweighted}} for \code{tbl_svysummary} objects) + +Syntax follows \code{\link[glue:glue]{glue::glue()}}, e.g. \code{all_stat_cols() ~ "**{level}**, N = {n}"}. +} + +\section{tbl_regression()}{ + +When assigning column headers for \code{tbl_regression} tables, +you may use \code{{N}} to insert the number of observations, and \code{{N_event}} +for the number of events (when applicable). +} + +\section{captions}{ + +Captions are assigned based on output type. +\itemize{ +\item \code{gt::gt(caption=)} +\item \code{flextable::set_caption(caption=)} +\item \code{huxtable::set_caption(value=)} +\item \code{knitr::kable(caption=)} +} +} + +\examples{ +\dontshow{if (FALSE) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\donttest{ +# create summary table +tbl <- trial[c("age", "grade", "trt")] \%>\% + tbl_summary(by = trt, missing = "no") \%>\% + add_p() + +# print the column names that can be modified +show_header_names(tbl) + +# Example 1 ---------------------------------- +# updating column headers, footnote, and table caption +modify_ex1 <- tbl \%>\% + modify_header(label = "**Variable**", p.value = "**P**") \%>\% + modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (\%) for Grade") \%>\% + modify_caption("**Patient Characteristics** (N = {N})") + +# Example 2 ---------------------------------- +# updating headers, remove all footnotes, add spanning header +modify_ex2 <- tbl \%>\% + modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}\%)") \%>\% + # use `modify_footnote(everything() ~ NA, abbreviation = TRUE)` to delete abbrev. footnotes + modify_footnote(update = everything() ~ NA) \%>\% + modify_spanning_header(all_stat_cols() ~ "**Treatment Received**") + +# Example 3 ---------------------------------- +# updating an abbreviation in table footnote +modify_ex3 <- + glm(response ~ age + grade, trial, family = binomial) \%>\% + tbl_regression(exponentiate = TRUE) \%>\% + modify_footnote(ci = "CI = Credible Interval", abbreviation = TRUE) +} +\dontshow{\}) # examplesIf} +} +\seealso{ +Other tbl_summary tools: +\code{\link{tbl_summary}()} +} +\author{ +Daniel D. Sjoberg +} +\concept{tbl_regression tools} +\concept{tbl_summary tools} +\concept{tbl_survfit tools} +\concept{tbl_svysummary tools} +\concept{tbl_uvregression tools} diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 8714fc0abc..411d184d1e 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -22,6 +22,7 @@ Use these functions to hide or unhide columns in a gtsummary table. Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: +\code{\link{modify_column_merge}()}, \code{\link{modify_fmt_fun}()}, \code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd new file mode 100644 index 0000000000..438b896851 --- /dev/null +++ b/man/modify_column_merge.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_column_merge.R +\name{modify_column_merge} +\alias{modify_column_merge} +\title{Modify Column Merging} +\usage{ +modify_column_merge(x, pattern, rows = NULL) +} +\arguments{ +\item{x}{gtsummary object} + +\item{pattern}{glue syntax string indicating how to merge columns in +\code{x$table_body}. For example, to construct a confidence interval +use \code{"{conf.low}, {conf.high}"}.} + +\item{rows}{predicate expression to select rows in \code{x$table_body}. +Can be used to style footnote, formatting functions, missing symbols, +and text formatting. Default is \code{NULL}. See details below.} +} +\value{ +gtsummary table +} +\description{ +Merge two or more columns in a gtsummary table. +Use \code{show_header_names()} to print underlying column names. +} +\section{Details}{ + +\enumerate{ +\item Calling this function merely records the instructions to merge columns. +The actual merging occurs when the gtsummary table is printed or converted +with a function like \code{as_gt()}. +\item Because the column merging is delayed, it is recommended to perform +major modifications to the table, such as those with \code{tbl_merge()} and +\code{tbl_stack()}, before assigning merging instructions. Otherwise, +unexpected formatting may occur in the final table. +\item If this functionality is used in conjunction with \code{tbl_stack()} (which +includes \code{tbl_uvregression()}), there may be potential issues with printing. +When columns are stack AND when the column-merging is +defined with a quosure, you may run into issues due to the loss of the +environment when 2 or more quosures are combined. If the expression +version of the quosure is the same as the quosure (i.e. no evaluated +objects), there should be no issues. +} + +This function is used internally with care, and \strong{it is \emph{not} recommended for users}. +} + +\section{Future Updates}{ + +There are planned updates to the implementation of this function +with respect to the \verb{pattern=} argument. +Currently, this function replaces a numeric column with a +formatted character column following \verb{pattern=}. +Once \code{gt::cols_merge()} gains the \verb{rows=} argument the +implementation will be updated to use it, which will keep +numeric columns numeric. For the \emph{vast majority} of users, +\emph{the planned change will be go unnoticed}. +} + +\examples{ +\dontshow{if (gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +# Example 1 ---------------------------------- +modify_column_merge_ex1 <- + trial |> + tbl_summary(by = trt, missing = "no", include = c(age, marker, trt)) |> + add_p(all_continuous() ~ "t.test", pvalue_fun = styfn_pvalue(prepend_p = TRUE)) |> + modify_fmt_fun(statistic ~ styfn_sigfig()) |> + modify_column_merge(pattern = "t = {statistic}; {p.value}") |> + modify_header(statistic = "**t-test**") +\dontshow{\}) # examplesIf} +} +\seealso{ +Other Advanced modifiers: +\code{\link{modify_column_hide}()}, +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_body}()}, +\code{\link{modify_table_styling}()} +} +\concept{Advanced modifiers} diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index 256703c718..3a63f7da4f 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -46,6 +46,7 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_hide}()}, +\code{\link{modify_column_merge}()}, \code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } diff --git a/man/modify_table_body.Rd b/man/modify_table_body.Rd index df3a7d99c7..474e38bfa9 100644 --- a/man/modify_table_body.Rd +++ b/man/modify_table_body.Rd @@ -30,6 +30,7 @@ To show a column, add a column header with \code{modify_header()}. \seealso{ Other Advanced modifiers: \code{\link{modify_column_hide}()}, +\code{\link{modify_column_merge}()}, \code{\link{modify_fmt_fun}()}, \code{\link{modify_table_styling}()} } diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index cf8107d59f..7f216568d1 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -123,6 +123,7 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_hide}()}, +\code{\link{modify_column_merge}()}, \code{\link{modify_fmt_fun}()}, \code{\link{modify_table_body}()} } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index ed24c45af3..8c72cd5a8e 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -192,6 +192,9 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tb See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary + +Other tbl_summary tools: +\code{\link{modify}} } \author{ Daniel D. Sjoberg diff --git a/man/tests.Rd b/man/tests.Rd index 0b7a99508c..a6722e09ba 100644 --- a/man/tests.Rd +++ b/man/tests.Rd @@ -19,7 +19,7 @@ calculate a p-value from \code{t.test()} assuming equal variance, use \code{'mood.test'} \tab Mood two-sample test of scale \tab \code{mood.test(variable ~ as.factor(by), data = data, ...)} \tab Not to be confused with the Brown-Mood test of medians \cr \code{'oneway.test'} \tab One-way ANOVA \tab \code{oneway.test(variable ~ as.factor(by), data = data, ...)} \tab \cr \code{'kruskal.test'} \tab Kruskal-Wallis test \tab \code{kruskal.test(data[[variable]], as.factor(data[[by]]))} \tab \cr - \code{'wilcox.test'} \tab Wilcoxon rank-sum test \tab \code{wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, ...)} \tab \cr + \code{'wilcox.test'} \tab Wilcoxon rank-sum test \tab \code{wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, conf.int = TRUE, conf.level = conf.level, ...)} \tab \cr \code{'chisq.test'} \tab chi-square test of independence \tab \code{chisq.test(x = data[[variable]], y = as.factor(data[[by]]), ...)} \tab \cr \code{'chisq.test.no.correct'} \tab chi-square test of independence \tab \code{chisq.test(x = data[[variable]], y = as.factor(data[[by]]), correct = FALSE)} \tab \cr \code{'fisher.test'} \tab Fisher's exact test \tab \code{fisher.test(data[[variable]], as.factor(data[[by]]), conf.level = 0.95, ...)} \tab \cr @@ -82,6 +82,7 @@ calculate a p-value from \code{t.test()} assuming equal variance, use \tabular{lllll}{ \strong{alias} \tab \strong{description} \tab \strong{difference statistic} \tab \strong{pseudo-code} \tab \strong{details} \cr \code{'t.test'} \tab t-test \tab mean difference \tab \code{t.test(variable ~ as.factor(by), data = data, conf.level = 0.95, ...)} \tab \cr + \code{'wilcox.test'} \tab Wilcoxon rank-sum test \tab \tab \code{wilcox.test(as.numeric(variable) ~ as.factor(by), data = data, conf.int = TRUE, conf.level = conf.level, ...)} \tab \cr \code{'paired.t.test'} \tab Paired t-test \tab mean difference \tab \verb{tidyr::pivot_wider(id_cols = group, ...); t.test(by_1, by_2, paired = TRUE, conf.level = 0.95, ...)} \tab \cr \code{'prop.test'} \tab Test for equality of proportions \tab rate difference \tab \code{prop.test(x, n, conf.level = 0.95, ...)} \tab \cr \code{'ancova'} \tab ANCOVA \tab mean difference \tab \code{lm(variable ~ by + adj.vars)} \tab \cr diff --git a/tests/testthat/_snaps/add_difference.tbl_summary.md b/tests/testthat/_snaps/add_difference.tbl_summary.md new file mode 100644 index 0000000000..b9b8aec96d --- /dev/null +++ b/tests/testthat/_snaps/add_difference.tbl_summary.md @@ -0,0 +1,125 @@ +# add_difference.tbl_summary() works with basic usage + + Code + as.data.frame(modify_column_hide(tbl_diff, all_stat_cols())) + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 Marker Level (ng/mL) 0.20 -0.05, 0.44 0.12 + 2 Age -0.44 -4.6, 3.7 0.8 + +--- + + Code + as.data.frame(modify_column_hide(add_difference(tbl_summary(select(trial, trt, + response, grade), by = trt, percent = "row")), all_stat_cols())) + Condition + Warning: + The `add_difference()` results for categorical variables may not compatible with `tbl_summary(percent = c('cell', 'row'))`. + i Use column percentages instead, `tbl_summary(percent = 'column')`. + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 Tumor Response -4.2% -18%, 9.9% 0.6 + 2 Unknown + 3 Grade 0.07 -0.20, 0.35 + 4 I + 5 II + 6 III + +# statistics are replicated within add_difference.tbl_summary() + + Code + as.data.frame(modify_column_hide(tbl_test.args, all_stat_cols())) + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 var_t.test -0.44 -4.6, 3.7 0.8 + 2 var_t.test_dots -0.44 -4.6, 3.7 0.8 + 3 var_wilcox.test -1.0 -5.0, 4.0 0.7 + 4 var_wilcox.test_dots -1.0 -5.0, 4.0 0.7 + 5 var_prop.test -4.2% -18%, 9.9% 0.6 + 6 var_prop.test_dots -4.2% -16%, 100% 0.7 + 7 var_ancova -0.44 -4.6, 3.7 0.8 + 8 var_cohens_d -0.03 -0.32, 0.25 + 9 var_hedges_g -0.03 -0.31, 0.25 + 10 var_smd -0.03 -0.32, 0.25 + +# statistics are replicated within add_difference.tbl_summary(group) + + Code + as.data.frame(modify_column_hide(tbl_groups, all_stat_cols())) + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 age_ancova_lme4 -0.57 -4.0, 2.8 + 2 age_paired_t_test -0.85 -4.4, 2.7 0.6 + 3 age_paired_cohens_d -0.05 -0.26, 0.16 + 4 age_paired_hedges_g -0.05 -0.26, 0.16 + +# row formatting of differences and CIs work + + Code + tbl1 + Output + # A tibble: 4 x 6 + label stat_1 stat_2 estimate conf.low p.value + + 1 Age 47 (15) 47 (14) -0.44 -4.6, 3.7 0.8 + 2 Marker Level (ng/mL) 1.02 (0.89) 0.82 (0.83) 0.20 -0.05, 0.44 0.12 + 3 Tumor Response 29% 34% -4.2% -18%, 9.9% 0.6 + 4 Patient Died 53% 59% -5.8% -21%, 9.0% 0.5 + +# no error with missing data + + Code + as.data.frame(modify_column_hide(t1, all_stat_cols())) + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 mpg + 2 hp + +# add_difference() with smd + + Code + tbl + Output + label stat_1 stat_2 estimate conf.low + 1 Age 46 (37, 60) 48 (39, 56) -0.03 -0.32, 0.25 + 2 Tumor Response 28 (29%) 33 (34%) -0.09 -0.37, 0.19 + 3 Grade 0.07 -0.20, 0.35 + 4 I 35 (36%) 33 (32%) + 5 II 32 (33%) 36 (35%) + 6 III 31 (32%) 33 (32%) + +# add_difference.tbl_summary() with emmeans() + + Code + as.data.frame(modify_column_hide(res, all_stat_cols())) + Output + **Characteristic** **Adjusted Difference** **95% CI** **p-value** + 1 Age -0.42 -4.5, 3.7 0.8 + 2 Tumor Response -4.7% -18%, 8.4% 0.5 + +# ordering in add_difference.tbl_summary() with paired tests + + Code + as.data.frame(modify_column_hide(add_difference(mutate(mtcars, .by = am, id = dplyr::row_number(), + am = factor(am, levels = c(0, 1))) %>% tbl_summary(by = am, include = mpg), + test = ~"paired.t.test", group = id), all_stat_cols())) + Message + The following warning was returned in `add_difference()` for variable "mpg" + ! Some observations included in the stratified summary statistics were omitted from the comparison due to unbalanced missingness within group. + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 mpg -7.0 -10, -3.6 <0.001 + +--- + + Code + as.data.frame(modify_column_hide(add_difference(tbl_summary(mutate(mtcars, .by = am, + id = dplyr::row_number(), am = factor(am, levels = c(1, 0))), by = am, + include = mpg), test = ~"paired.t.test", group = id), all_stat_cols())) + Message + The following warning was returned in `add_difference()` for variable "mpg" + ! Some observations included in the stratified summary statistics were omitted from the comparison due to unbalanced missingness within group. + Output + **Characteristic** **Difference** **95% CI** **p-value** + 1 mpg 7.0 3.6, 10 <0.001 + diff --git a/tests/testthat/_snaps/add_p.tbl_summary.md b/tests/testthat/_snaps/add_p.tbl_summary.md index 5ae4dd0781..9794d62c40 100644 --- a/tests/testthat/_snaps/add_p.tbl_summary.md +++ b/tests/testthat/_snaps/add_p.tbl_summary.md @@ -28,12 +28,18 @@ as.data.frame(add_p(tbl_summary(mtcars, by = am))) Message The following warnings were returned during `add_p()`: - ! For variable `disp` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `drat` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `hp` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `mpg` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `qsec` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `wt` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `disp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `disp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `drat` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `drat` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `hp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `hp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `mpg` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `mpg` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `qsec` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `qsec` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `wt` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `wt` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties Output **Characteristic** **0** \nN = 19 **1** \nN = 13 **p-value** 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) 0.002 @@ -192,15 +198,18 @@ Code as.data.frame(add_p(tbl_summary(mtcars, by = am), test = list(mpg = "t.test", - disp = "aov", hp = "oneway.test", cyl = "chisq.test.no.correct", carb = "mood.test"))) + hp = "oneway.test", cyl = "chisq.test.no.correct", carb = "mood.test"))) Message - The following warning was returned in `add_p()` for variable "disp" - ! The test "aov" in `add_p(test)` was deprecated in gtsummary 2.0.0. i The same functionality is covered with "oneway.test". Use the following code instead: i `add_p(test = list(disp = 'oneway.test'), test.args = list(disp = list(var.equal = TRUE)))`. The following warnings were returned during `add_p()`: ! For variable `cyl` (`am`) and "statistic", "p.value", and "parameter" statistics: Chi-squared approximation may be incorrect - ! For variable `drat` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `qsec` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties - ! For variable `wt` (`am`) and "statistic" and "p.value" statistics: cannot compute exact p-value with ties + ! For variable `disp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `disp` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `drat` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `drat` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `qsec` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `qsec` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties + ! For variable `wt` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact p-value with ties + ! For variable `wt` (`am`) and "estimate", "statistic", "p.value", "conf.low", and "conf.high" statistics: cannot compute exact confidence intervals with ties Output **Characteristic** **0** \nN = 19 **1** \nN = 13 **p-value** 1 mpg 17.3 (14.7, 19.2) 22.8 (21.0, 30.4) 0.001 @@ -250,6 +259,14 @@ add_p(add_p(tbl_summary(select(trial, age, trt), by = trt))) Condition Error in `add_p()`: - ! Columns "statistic" and "p.value" are already present in table (although, some may be hidden), and no new columns were added. + ! Columns "estimate", "statistic", "conf.low", "conf.high", and "p.value" are already present in table (although, some may be hidden), and no new columns were added. i Use `tbl |> modify_table_body(\(x) dplyr::select(x, -p.value))` to remove columns and they will be replaced by the new columns from the current call. +--- + + Code + tbl + Output + label stat_1 stat_2 estimate conf.low p.value + 1 Age 47.011 47.449 -0.03 -0.32, 0.25 0.8 + diff --git a/tests/testthat/test-add_difference.tbl_summary.R b/tests/testthat/test-add_difference.tbl_summary.R new file mode 100644 index 0000000000..538520802a --- /dev/null +++ b/tests/testthat/test-add_difference.tbl_summary.R @@ -0,0 +1,608 @@ +skip_if_not(is_pkg_installed(c("broom", "broom.helpers", "lme4", "smd", + "effectsize", "emmeans"), reference_pkg = "cardx")) + +test_that("add_difference.tbl_summary() works with basic usage", { + expect_error( + tbl_diff <- + trial |> + select(trt, marker, age) |> + tbl_summary(by = trt, missing = "no") |> + add_difference( + test = everything() ~ "t.test", + test.args = all_tests("t.test") ~ list(var.equal = TRUE) + ), + NA + ) + expect_snapshot( + tbl_diff |> + modify_column_hide(all_stat_cols()) |> + as.data.frame()) + + expect_equal( + tbl_diff$cards$add_difference$marker |> + dplyr::filter(stat_name %in% c("estimate", "statistic", "parameter", "conf.low", "conf.high", "p.value")) |> + dplyr::mutate(stat = unlist(stat)) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat + ) |> + dplyr::select(all_of(c("estimate", "statistic", "parameter", "conf.low", "conf.high", "p.value"))), + t.test(marker ~ trt, trial, var.equal = TRUE) %>% + {withr::with_package("broom", tidy(.))} |> + select(all_of(c("estimate", "statistic", "parameter", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_snapshot( + trial |> + select(trt, response, grade) |> + tbl_summary(by = trt, percent = "row") |> + add_difference() |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) +}) + +test_that("add_difference.tbl_summary(tests = 'emmeans')", { + skip_if_not(is_pkg_installed("emmeans", reference_pkg = "cardx")) + tbl1 <- + trial |> + tbl_summary( + by = trt, + include = ttdeath + ) |> + add_difference(test = ~"emmeans") + + expect_equal( + tbl1$cards$add_difference$ttdeath |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ), + cardx::ard_emmeans_mean_difference( + data = trial, + formula = ttdeath ~ trt, + method = "lm", + response_type = "continuous" + ) |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ) + ) + + tbl2 <- + trial |> + tbl_summary( + by = trt, + include = ttdeath + ) |> + add_difference(test = ~"emmeans", group = "grade") + + expect_equal( + tbl2$cards$add_difference$ttdeath |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ), + cardx::ard_emmeans_mean_difference( + data = trial, + formula = ttdeath ~ trt + (1 | grade), + method = "lmer", + package = "lme4", + response_type = "continuous" + ) |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ) + ) + + tbl3 <- + trial |> + tbl_summary( + by = trt, + include = response + ) |> + add_difference(test = ~"emmeans") + + expect_equal( + tbl3$cards$add_difference$response |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ), + cardx::ard_emmeans_mean_difference( + data = trial, + formula = response ~ trt, + method = "glm", + method.args = list(family = binomial), + response_type = "dichotomous" + ) |> + dplyr::select( + -cards::all_ard_groups(), + -cards::all_ard_variables() + ) + ) +}) + +test_that("statistics are replicated within add_difference.tbl_summary()", { + tbl_test.args <- + trial |> + select(trt, + var_t.test = age, + var_t.test_dots = age, + var_wilcox.test = age, + var_wilcox.test_dots = age, + var_prop.test = response, + var_prop.test_dots = response, + var_ancova = age, + var_cohens_d = age, + var_hedges_g = age, + var_smd = age + ) %>% + tbl_summary( + by = trt, missing = "no", + statistic = list(all_continuous() ~ "{mean}", all_categorical() ~ "{p}%"), + digits = all_continuous() ~ 3, + label = as.list(names(.)) |> setNames(names(.)) + ) |> + add_difference( + test = list( + contains("t.test") ~ t.test, + contains("wilcox.test") ~ wilcox.test, + contains("prop.test") ~ prop.test, + contains("ancova") ~ "ancova", + contains("cohens_d") ~ "cohens_d", + contains("hedges_g") ~ "hedges_g", + contains("smd") ~ "smd", + contains("emmeans") ~ "emmeans" + ), + test.args = list( + var_t.test_dots = list(var.equal = TRUE), + var_wilcox.test_dots = list(correct = FALSE), + var_prop.test_dots = list(alternative = "greater") + ) + ) + expect_snapshot( + tbl_test.args |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_t.test |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + t.test(age ~ as.factor(trt), data = trial) %>% + {withr::with_package("broom", tidy(.))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_t.test_dots |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + t.test(age ~ as.factor(trt), data = trial, var.equal = TRUE) %>% + {withr::with_package("broom", tidy(.))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + + expect_equal( + tbl_test.args$cards$add_difference$var_wilcox.test |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + wilcox.test(age ~ trt, data = trial, conf.int = TRUE) %>% + {withr::with_package("broom", tidy(.))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_wilcox.test_dots |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + wilcox.test(age ~ trt, data = trial, correct = FALSE, conf.int = TRUE) %>% + {withr::with_package("broom", tidy(.))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_prop.test |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + table(trial$trt, factor(trial$response) %>% fct_rev()) |> + prop.test() %>% + {withr::with_package("broom", tidy(.))} |> + dplyr::mutate(estimate = estimate1 - estimate2) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_prop.test_dots |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(group1, variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + table(trial$trt, factor(trial$response) %>% fct_rev()) |> + prop.test(alternative = "greater") %>% + {withr::with_package("broom", tidy(.))} |> + dplyr::mutate(estimate = estimate1 - estimate2) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_ancova |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + lm(age ~ fct_rev(trt), trial) %>% + {withr::with_package("broom", tidy(., conf.int = TRUE))} |> + dplyr::slice(dplyr::n()) %>% + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_cohens_d |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + withr::with_package( + package = "effectsize", + cohens_d( + age ~ trt, + data = trial %>% tidyr::drop_na("age", "trt"), + verbose = FALSE + ) + ) |> + tibble::as_tibble() |> + select(-CI) |> + set_names(c("estimate", "conf.low", "conf.high")), + ignore_attr = TRUE + ) + + expect_equal( + tbl_test.args$cards$add_difference$var_hedges_g |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + withr::with_package( + package = "effectsize", + hedges_g( + age ~ trt, + data = trial %>% tidyr::drop_na("age", "trt"), + verbose = FALSE + ) + ) |> + tibble::as_tibble() |> + select(-CI) |> + set_names(c("estimate", "conf.low", "conf.high")), + ignore_attr = TRUE + ) +}) + + +test_that("statistics are replicated within add_difference.tbl_summary(group)", { + trial_group <- trial |> + dplyr::mutate(.by = trt, id = dplyr::row_number()) + trial_group_wide <- + trial_group |> + dplyr::filter(trt == "Drug A") |> + dplyr::full_join( + trial_group |> + dplyr::filter(trt == "Drug B"), + by = "id" + ) + + tbl_groups <- + trial_group |> + select(trt, id, stage, marker, + age_ancova_lme4 = age, + age_paired_t_test = age, + age_paired_cohens_d = age, + age_paired_hedges_g = age + ) %>% + tbl_summary( + by = trt, + missing = "no", + include = starts_with("age_"), + label = as.list(names(.)) |> setNames(names(.)) + ) |> + add_difference( + test = list(age_ancova_lme4 = "ancova_lme4", + age_paired_t_test = "paired.t.test", + age_paired_cohens_d = "paired_cohens_d", + age_paired_hedges_g = "paired_hedges_g"), + group = "id" + ) + expect_snapshot( + tbl_groups |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + + expect_equal( + tbl_groups$cards$add_difference$age_ancova_lme4 |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + withr::with_package( + package = "lme4", + lmer(age ~ fct_rev(factor(trt)) + (1 | id), trial_group) + ) %>% + {withr::with_package("broom.mixed", tidy(., conf.int = TRUE, effects = "fixed"))} |> + dplyr::slice(dplyr::n()) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_groups$cards$add_difference$age_paired_t_test |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + stats::t.test( + x = trial_group_wide$age.x, + y = trial_group_wide$age.y, + paired = TRUE + ) %>% + {withr::with_package("broom", tidy(.))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_groups$cards$add_difference$age_paired_cohens_d |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + withr::with_package( + package = "effectsize", + cohens_d( + x = trial_group_wide$age.x, + y = trial_group_wide$age.y, + paired = TRUE, + verbose = FALSE + ) + ) %>% + {withr::with_package("parameters", standardize_names(., style = "broom"))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) + + expect_equal( + tbl_groups$cards$add_difference$age_paired_hedges_g |> + dplyr::filter(stat_name %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + tidyr::pivot_wider( + id_cols = c(variable), + names_from = stat_name, + values_from = stat, + values_fn = unlist + ) |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + withr::with_package( + package = "effectsize", + hedges_g( + x = trial_group_wide$age.x, + y = trial_group_wide$age.y, + paired = TRUE, + verbose = FALSE + ) + ) %>% + {withr::with_package("parameters", standardize_names(., style = "broom"))} |> + select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), + ignore_attr = TRUE + ) +}) + +test_that("row formatting of differences and CIs work", { + expect_error( + tbl1 <- + trial |> + select(trt, age, marker, response, death) |> + tbl_summary( + by = trt, + statistic = + list( + all_continuous() ~ "{mean} ({sd})", + all_dichotomous() ~ "{p}%" + ), + missing = "no" + ) %>% + add_difference() |> + as_tibble(col_labels = FALSE), + NA + ) + expect_snapshot(tbl1) + + expect_equal( + tbl1$estimate, + c("-0.44", "0.20", "-4.2%", "-5.8%") + ) + + expect_equal( + tbl1$conf.low, + c("-4.6, 3.7", "-0.05, 0.44", "-18%, 9.9%", "-21%, 9.0%") + ) +}) + +test_that("no error with missing data", { + expect_message( + t1 <- + mtcars |> + mutate(mpg = NA, hp = NA) |> + select(mpg, hp, am) |> + tbl_summary(by = "am", type = hp ~ "continuous", missing = "no") |> + add_difference() + ) + expect_snapshot(t1 |> modify_column_hide(all_stat_cols()) |> as.data.frame()) + + expect_equal( + t1 %>% as_tibble(col_labels = FALSE) %>% dplyr::pull(p.value), + rep_len(NA_character_, 2) + ) +}) + +test_that("add_difference() with smd", { + expect_error( + tbl <- + trial |> + select(trt, age, response, grade) |> + tbl_summary(by = trt, missing = "no") |> + add_difference(test = everything() ~ "smd") |> + as.data.frame(col_labels = FALSE), + NA + ) + expect_equal( + tbl$estimate[1:3], + c("-0.03", "-0.09", "0.07") + ) + expect_equal( + tbl$conf.low[1:3], + c("-0.32, 0.25", "-0.37, 0.19", "-0.20, 0.35") + ) + expect_snapshot(tbl) +}) + +test_that("add_difference.tbl_summary() with emmeans()", { + tbl <- + tbl_summary( + trial, + by = trt, + include = c(age, response), + missing = "no" + ) + + expect_error( + res <- add_difference(tbl, test = everything() ~ "emmeans", adj.vars = "stage"), + NA + ) + expect_snapshot( + res |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + expect_error( + tbl |> + add_difference(test = everything() ~ "emmeans", group = "death"), + NA + ) + + # TODO: Add this after `tbl_svysummary()` added to pkg + # expect_error( + # survey::svydesign(ids = ~1, data = trial, weights = ~1) %>% + # tbl_svysummary( + # by = trt, + # include = c(age, response), + # missing = "no" + # ) %>% + # add_difference(test = everything() ~ "emmeans", adj.vars = "marker"), + # NA + # ) +}) + +test_that("ordering in add_difference.tbl_summary() with paired tests", { + expect_snapshot( + mtcars |> + mutate( + .by = am, + id = dplyr::row_number(), + am = factor(am, levels = c(0, 1)) + ) %>% + tbl_summary( + by = am, + include = mpg + ) |> + add_difference(test = ~"paired.t.test", group = id) |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + expect_snapshot( + mtcars |> + mutate( + .by = am, + id = dplyr::row_number(), + am = factor(am, levels = c(1, 0)) + ) |> + tbl_summary( + by = am, + include = mpg + ) |> + add_difference(test = ~"paired.t.test", group = id) |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) +}) + diff --git a/tests/testthat/test-add_p.tbl_summary.R b/tests/testthat/test-add_p.tbl_summary.R index 8c3bbc4781..733d17359c 100644 --- a/tests/testthat/test-add_p.tbl_summary.R +++ b/tests/testthat/test-add_p.tbl_summary.R @@ -113,7 +113,6 @@ test_that("add_p.tbl_summary() works well", { add_p( test = list( mpg = "t.test", - disp = "aov", hp = "oneway.test", cyl = "chisq.test.no.correct", carb = "mood.test" @@ -437,15 +436,14 @@ test_that("no error with missing data", { ) }) -# TODO: After add_difference() has been added, we need to re-add these tests! test_that("add_p.tbl_summary() can be run after add_difference()", { - # expect_error( - # trial %>% - # select(age, trt) %>% - # tbl_summary(by = trt) %>% - # add_difference() %>% - # add_p(all_continuous() ~ "t.test") - # ) + expect_error( + trial |> + select(age, trt) |> + tbl_summary(by = trt) |> + add_difference() |> + add_p(all_continuous() ~ "t.test") + ) expect_snapshot( error = TRUE, @@ -456,49 +454,49 @@ test_that("add_p.tbl_summary() can be run after add_difference()", { add_p() ) - # expect_error( - # trial %>% - # select(age, trt) %>% - # tbl_summary(by = trt) %>% - # add_difference() %>% - # add_difference() - # ) - # - # expect_error( - # tbl <- - # trial %>% - # select(age, trt) %>% - # tbl_summary( - # by = trt, - # missing = "no", - # statistic = all_continuous() ~ "{mean}", - # digits = all_continuous() ~ 3 - # ) %>% - # add_difference(all_continuous() ~ "cohens_d") %>% - # add_p(all_continuous() ~ "t.test") %>% - # as_tibble(col_labels = FALSE), - # NA - # ) - # expect_snapshot(tbl) - # - # expect_equal( - # tbl %>% - # unlist(), - # c( - # label = "Age", - # stat_1 = "47.011", - # stat_2 = "47.449", - # estimate = "-0.03", - # ci = "-0.32, 0.25", - # p.value = "0.8" - # ) - # ) - # expect_true( - # tbl %>% - # select(ends_with(".x") | ends_with(".y")) %>% - # names() %>% - # rlang::is_empty() - # ) + expect_error( + trial |> + select(age, trt) |> + tbl_summary(by = trt) |> + add_difference() |> + add_difference() + ) + + expect_error( + tbl <- + trial |> + select(age, trt) |> + tbl_summary( + by = trt, + missing = "no", + statistic = all_continuous() ~ "{mean}", + digits = all_continuous() ~ 3 + ) %>% + add_difference(all_continuous() ~ "cohens_d") |> + add_p(all_continuous() ~ "t.test") |> + as.data.frame(col_labels = FALSE), + NA + ) + expect_snapshot(tbl) + + expect_equal( + tbl |> + unlist(), + c( + label = "Age", + stat_1 = "47.011", + stat_2 = "47.449", + estimate = "-0.03", + conf.low = "-0.32, 0.25", + p.value = "0.8" + ) + ) + expect_true( + tbl %>% + select(ends_with(".x") | ends_with(".y")) %>% + names() %>% + rlang::is_empty() + ) }) From f69d0e35adfe81af4959feb1fd7572f0244e7d10 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 13 May 2024 11:07:46 -0700 Subject: [PATCH 52/74] First draft of `card_summary()` (#1636) * first draft of `card_summary()` * Update card_summary.R * adding some unit tests * more tests * styler --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/add_difference.R | 20 +- R/add_p.R | 77 +++-- R/assign_tests.R | 42 +-- R/bridge_summary.R | 95 ++++--- R/card_summary.R | 264 ++++++++++++++++++ R/import-standalone-tibble.R | 7 +- R/modify_column_merge.R | 9 +- R/select_helpers.R | 4 +- R/tbl_summary.R | 17 +- R/utils-add_p_tests.R | 9 +- man/assign_tests.Rd | 2 +- man/bridge_summary.Rd | 29 +- man/card_summary.Rd | 76 +++++ man/tbl_summary.Rd | 2 +- tests/testthat/_snaps/card_summary.md | 120 ++++++++ .../test-add_difference.tbl_summary.R | 96 ++++--- tests/testthat/test-add_p.tbl_summary.R | 41 ++- tests/testthat/test-card_summary.R | 146 ++++++++++ tests/testthat/test-tbl_summary.R | 58 ++-- 21 files changed, 916 insertions(+), 201 deletions(-) create mode 100644 R/card_summary.R create mode 100644 man/card_summary.Rd create mode 100644 tests/testthat/_snaps/card_summary.md create mode 100644 tests/testthat/test-card_summary.R diff --git a/DESCRIPTION b/DESCRIPTION index 9536f0ebd4..ee69c00dcb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,7 @@ BugReports: https://github.com/ddsjoberg/gtsummary/issues Depends: R (>= 4.1) Imports: - cards (>= 0.1.0.9023), + cards (>= 0.1.0.9024), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), diff --git a/NAMESPACE b/NAMESPACE index 54a75a2e74..9ef0007797 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ export(assign_summary_digits) export(assign_summary_type) export(assign_tests) export(brdg_summary) +export(card_summary) export(contains) export(default_stat_labels) export(ends_with) diff --git a/R/add_difference.R b/R/add_difference.R index 4b49c1935f..bd996bfc1a 100644 --- a/R/add_difference.R +++ b/R/add_difference.R @@ -81,9 +81,11 @@ add_difference.tbl_summary <- function(x, conf.level = 0.95, include = everything(), pvalue_fun = styfn_pvalue(), - estimate_fun = list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), - all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, paste0(style_sigfig(x, scale = 100), "%")), - all_tests("smd") ~ styfn_sigfig()), + estimate_fun = list( + c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), + all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, paste0(style_sigfig(x, scale = 100), "%")), + all_tests("smd") ~ styfn_sigfig() + ), ...) { set_cli_abort_call() # check/process inputs ------------------------------------------------------- @@ -119,7 +121,7 @@ add_difference.tbl_summary <- function(x, # checking for `tbl_summary(percent = c("cell", "row"))`, which don't apply if (!x$inputs$percent %in% "column" && - any(unlist(x$inputs$type[include]) %in% c("categorical", "dichotomous"))) { + any(unlist(x$inputs$type[include]) %in% c("categorical", "dichotomous"))) { cli::cli_warn(c( "The {.code add_difference()} results for categorical variables may not compatible with {.code tbl_summary(percent = c('cell', 'row'))}.", @@ -153,7 +155,7 @@ add_difference.tbl_summary <- function(x, df_test_meta_data <- imap( test, - ~dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) + ~ dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) ) |> dplyr::bind_rows() @@ -166,8 +168,7 @@ add_difference.tbl_summary <- function(x, by = "variable" ) |> dplyr::relocate("test_name", .after = "variable") - } - else { + } else { x$table_body <- dplyr::rows_update( x$table_body, @@ -197,7 +198,8 @@ add_difference.tbl_summary <- function(x, test.args, predicate = \(x) is.list(x) && is_named(x), error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", - i = "Value must be a named list.") + i = "Value must be a named list." + ) ) # calculate tests ------------------------------------------------------------ @@ -213,5 +215,3 @@ add_difference.tbl_summary <- function(x, x } - - diff --git a/R/add_p.R b/R/add_p.R index f5d333573e..d8bfbbd094 100644 --- a/R/add_p.R +++ b/R/add_p.R @@ -136,7 +136,8 @@ add_p.tbl_summary <- function(x, test, predicate = \(x) is.character(x) || is.function(x), error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", - i = "Value must be {.cls character} or {.cls function}.") + i = "Value must be {.cls character} or {.cls function}." + ) ) # if `pvalue_fun` not modified, check if we need to use a theme p-value @@ -163,7 +164,7 @@ add_p.tbl_summary <- function(x, df_test_meta_data <- imap( test, - ~dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) + ~ dplyr::tibble(variable = .y, fun_to_run = list(.x), test_name = attr(.x, "test_name") %||% NA_character_) ) |> dplyr::bind_rows() @@ -176,8 +177,7 @@ add_p.tbl_summary <- function(x, by = "variable" ) |> dplyr::relocate("test_name", .after = "variable") - } - else { + } else { x$table_body <- dplyr::rows_update( x$table_body, @@ -198,7 +198,8 @@ add_p.tbl_summary <- function(x, test.args, predicate = \(x) is.list(x) && is_named(x), error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", - i = "Value must be a named list.") + i = "Value must be a named list." + ) ) # calculate tests ------------------------------------------------------------ @@ -229,9 +230,9 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var do.call( what = df_test_meta_data |> - dplyr::filter(.data$variable %in% .env$variable) |> - dplyr::pull("fun_to_run") %>% - getElement(1), + dplyr::filter(.data$variable %in% .env$variable) |> + dplyr::pull("fun_to_run") %>% + getElement(1), args = list( data = x$inputs$data, variable = variable, @@ -259,7 +260,10 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var dplyr::tibble( group1 = x$inputs$by, variable = variable, - stat_name = switch(calling_fun, "add_p" = "p.value", "add_difference" = "estimate"), + stat_name = switch(calling_fun, + "add_p" = "p.value", + "add_difference" = "estimate" + ), stat = list(NULL), warning = lst_captured_results["warning"], error = lst_captured_results["error"] @@ -276,19 +280,23 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var if (inherits(x, "card")) { x |> dplyr::mutate( - across(c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")), ~unlist(.) |> as.character()) + across(c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")), ~ unlist(.) |> as.character()) ) + } else { + NULL } - else NULL } ) |> dplyr::bind_rows() %>% - {switch( - !is_empty(.), - dplyr::filter(., .data$stat_name %in% c("estimate", "std.error", "parameter", "statistic", - "conf.low", "conf.high", "p.value")) |> - cards::print_ard_conditions() - )} + { + switch(!is_empty(.), + dplyr::filter(., .data$stat_name %in% c( + "estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value" + )) |> + cards::print_ard_conditions() + ) + } # combine results into a single data frame @@ -299,8 +307,10 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var # if results are an ARD, reshape into broom::tidy-like format if (inherits(x, "card")) { res <- - dplyr::filter(x, .data$stat_name %in% c("estimate", "std.error", "parameter", "statistic", - "conf.low", "conf.high", "p.value")) |> + dplyr::filter(x, .data$stat_name %in% c( + "estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value" + )) |> cards::replace_null_statistic() |> tidyr::pivot_wider( id_cols = "variable", @@ -308,25 +318,28 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var values_from = "stat" ) |> dplyr::mutate(across(-"variable", unlist)) - } - else { + } else { if (!is.data.frame(x)) { cli::cli_abort( c("Expecting the test result object for variable {.val {variable}} to be a {.cls {c('data.frame', 'tibble')}}.", - i = "Review {.help gtsummary::tests} for details on constructing a custom function."), + i = "Review {.help gtsummary::tests} for details on constructing a custom function." + ), call = get_cli_abort_call() ) } res <- - dplyr::select(x, any_of(c("estimate", "std.error", "parameter", "statistic", - "conf.low", "conf.high", "p.value"))) |> + dplyr::select(x, any_of(c( + "estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value" + ))) |> dplyr::mutate(variable = .env$variable, .before = 1L) # check the result structure if (identical(names(res), "variable") || nrow(res) != 1L) { cli::cli_abort( c("The test result object for variable {.val {variable}} is not the expected structure.", - i = "Review {.help gtsummary::tests} for details on constructing a custom function."), + i = "Review {.help gtsummary::tests} for details on constructing a custom function." + ), call = get_cli_abort_call() ) } @@ -336,8 +349,10 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var ) |> dplyr::bind_rows() |> dplyr::select( - any_of(c("variable", "estimate", "std.error", "parameter", "statistic", - "conf.low", "conf.high", "p.value")) + any_of(c( + "variable", "estimate", "std.error", "parameter", "statistic", + "conf.low", "conf.high", "p.value" + )) ) # remove new columns that already exist in gtsummary table @@ -345,7 +360,8 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var if (is_empty(new_columns)) { cli::cli_abort( c("Columns {.val {names(df_results) |> setdiff('variable')}} are already present in table (although, some may be hidden), and no new columns were added.", - i = "Use {.code tbl |> modify_table_body(\\(x) dplyr::select(x, -p.value))} to remove columns and they will be replaced by the new columns from the current call."), + i = "Use {.code tbl |> modify_table_body(\\(x) dplyr::select(x, -p.value))} to remove columns and they will be replaced by the new columns from the current call." + ), call = get_cli_abort_call() ) } @@ -359,8 +375,7 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var dplyr::filter(.data$stat_name %in% "method") |> dplyr::pull("stat") |> unlist() - } - else { + } else { ft <- x[["method"]] } ft @@ -374,7 +389,7 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var # add results to `.$table_body` ---------------------------------------------- x <- x |> modify_table_body( - ~dplyr::left_join( + ~ dplyr::left_join( .x, df_results[c("variable", new_columns)] |> dplyr::mutate(row_type = "header"), by = c("variable", "row_type") diff --git a/R/assign_tests.R b/R/assign_tests.R index 5f115386de..a7b5aa70c3 100644 --- a/R/assign_tests.R +++ b/R/assign_tests.R @@ -26,7 +26,7 @@ #' trial |> #' tbl_summary( #' by = trt, -#' include = c(age, stage) +#' include = c(age, stage) #' ) |> #' assign_tests(include = c("age", "stage"), calling_fun = "add_p") NULL @@ -56,23 +56,28 @@ assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NU function(variable) { if (is.null(test[[variable]])) { test[[variable]] <- - switch( - calling_fun, + switch(calling_fun, "add_p" = - .add_p_tbl_summary_default_test(data, variable = variable, - by = by, group = group, adj.vars = adj.vars, - summary_type = summary_type[[variable]]), + .add_p_tbl_summary_default_test(data, + variable = variable, + by = by, group = group, adj.vars = adj.vars, + summary_type = summary_type[[variable]] + ), "add_difference" = - .add_difference_tbl_summary_default_test(data, variable = variable, - by = by, group = group, adj.vars = adj.vars, - summary_type = summary_type[[variable]]) + .add_difference_tbl_summary_default_test(data, + variable = variable, + by = by, group = group, adj.vars = adj.vars, + summary_type = summary_type[[variable]] + ) ) } if (is.null(test[[variable]])) { - cli::cli_abort(c( - "There is no default test set for column {.val {variable}}.", - i = "Set a value in the {.arg test} argument for column {.val {variable}} or exclude with {.code include = -{variable}}."), + cli::cli_abort( + c( + "There is no default test set for column {.val {variable}}.", + i = "Set a value in the {.arg test} argument for column {.val {variable}} or exclude with {.code include = -{variable}}." + ), call = get_cli_abort_call() ) } @@ -109,7 +114,7 @@ assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NU # if passed test is a function and it's an internal test internal_test_index <- df_tests$test_fun |> - map_lgl(~identical_no_attr(eval(.x), test)) |> + map_lgl(~ identical_no_attr(eval(.x), test)) |> which() if (is.function(test) && !is_empty(internal_test_index)) { test_to_return <- df_tests$fun_to_run[[internal_test_index]] |> eval() @@ -119,15 +124,16 @@ assign_tests.tbl_summary <- function(x, test = NULL, group = NULL, adj.vars = NU # otherwise, if it's a function, return it return(eval(test, envir = attr(test, ".Environment"))) - } # compare after removing attributes identical_no_attr <- function(x, y) { - tryCatch({ - attributes(x) <- NULL - attributes(y) <- NULL - identical(x, y)}, + tryCatch( + { + attributes(x) <- NULL + attributes(y) <- NULL + identical(x, y) + }, error = \(x) FALSE ) } diff --git a/R/bridge_summary.R b/R/bridge_summary.R index bbeef8592f..cfe568d24d 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -64,11 +64,15 @@ NULL #' @rdname bridge_summary #' @export -brdg_summary <- function(x, calling_function = "tbl_summary") { +brdg_summary <- function(x, + calling_function = "tbl_summary", + by = x$inputs$by, + include = x$inputs$include, + type = x$inputs$type) { set_cli_abort_call() # add gts info to the cards table -------------------------------------------- # adding the name of the column the stats will populate - if (is_empty(x$inputs$by)) { + if (is_empty(by)) { x[["cards"]][[calling_function]]$gts_column <- ifelse( x[["cards"]][[calling_function]]$context %in% c("continuous", "categorical", "dichotomous", "missing"), @@ -77,17 +81,24 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { ) } else { x[["cards"]][[calling_function]] <- - x[["cards"]][[calling_function]] |> - dplyr::mutate( - .by = cards::all_ard_groups(), - gts_column = - ifelse( - .data$context %in% c("continuous", "categorical", "dichotomous", "missing") & - !.data$variable %in% .env$x$inputs$tbl_summary$by, - paste0("stat_", dplyr::cur_group_id() - 1L), - NA_character_ - ) - ) + x[["cards"]][[calling_function]] %>% + { + dplyr::left_join( + ., + dplyr::filter( + ., + .data$variable %in% .env$include, + .data$context %in% c("continuous", "categorical", "dichotomous", "missing") + ) |> + dplyr::select(cards::all_ard_groups(), "variable", "context") |> + dplyr::distinct() |> + dplyr::mutate( + .by = cards::all_ard_groups(), + gts_column = paste0("stat_", dplyr::cur_group_id()) + ), + by = names(dplyr::select(., cards::all_ard_groups(), "variable", "context")) + ) + } } @@ -95,31 +106,31 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { x$table_body <- dplyr::left_join( dplyr::tibble( - variable = x$inputs$include, - var_type = x$inputs$type[.data$variable] |> unlist() |> unname() + variable = include, + var_type = type[.data$variable] |> unlist() |> unname() ), dplyr::bind_rows( pier_summary_continuous( x, - variables = .get_variables_by_type(x$inputs$type, type = "continuous"), + variables = .get_variables_by_type(type, type = "continuous"), calling_function = calling_function ), pier_summary_continuous2( x, - variables = .get_variables_by_type(x$inputs$type, type = "continuous2"), + variables = .get_variables_by_type(type, type = "continuous2"), calling_function = calling_function ), pier_summary_categorical( x, - variables = .get_variables_by_type(x$inputs$type, type = "categorical"), + variables = .get_variables_by_type(type, type = "categorical"), calling_function = calling_function ), pier_summary_dichotomous( x, - variables = .get_variables_by_type(x$inputs$type, type = "dichotomous"), + variables = .get_variables_by_type(type, type = "dichotomous"), calling_function = calling_function ), - pier_summary_missing_row(x, calling_function = calling_function) + pier_summary_missing_row(x, variables = include, calling_function = calling_function) ), by = "variable" ) @@ -128,7 +139,7 @@ brdg_summary <- function(x, calling_function = "tbl_summary") { x <- construct_initial_table_styling(x) # add info to x$table_styling$header for dynamic headers --------------------- - x <- .add_table_styling_stats(x) + x <- .add_table_styling_stats(x, by = by, calling_function = calling_function) x } @@ -154,7 +165,8 @@ pier_summary_dichotomous <- function(x, variables, value = x$inputs$value, #' @rdname bridge_summary #' @export -pier_summary_categorical <- function(x, variables, missing, missing_text, missing_stat, +pier_summary_categorical <- function(x, variables, + missing, missing_text, missing_stat, calling_function = "tbl_summary") { set_cli_abort_call() if (is_empty(variables)) { @@ -375,7 +387,10 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export -pier_summary_continuous <- function(x, variables, missing, missing_text, missing_stat, +pier_summary_continuous <- function(x, + variables, + statistic = x$inputs$statistic, + missing, missing_text, missing_stat, calling_function = "tbl_summary") { set_cli_abort_call() if (is_empty(variables)) { @@ -398,10 +413,10 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing .data = .y, stat = glue::glue( - x$inputs$statistic[[.data$variable[1]]], + statistic[[.data$variable[1]]], .envir = cards::get_ard_statistics(.x, .column = "stat_fmt") ) |> - as.character() + as.character() ) } ) |> @@ -439,7 +454,10 @@ pier_summary_continuous <- function(x, variables, missing, missing_text, missing #' @rdname bridge_summary #' @export -pier_summary_missing_row <- function(x, variables = x$inputs$include, +pier_summary_missing_row <- function(x, + variables = x$inputs$include, + missing_stat = x$inputs$missing_stat, + missing_text = x$inputs$missing_text, calling_function = "tbl_summary") { set_cli_abort_call() if (is_empty(variables)) { @@ -463,19 +481,19 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include, # slightly modifying the `x` object for missing value calculations ----------- # make all the summary stats the same for all vars - x$inputs$statistic <- rep_named(variables, list(x$inputs$missing_stat)) + statistic <- rep_named(variables, list(missing_stat)) - pier_summary_continuous(x, variables = variables) |> + pier_summary_continuous(x, variables = variables, statistic = statistic) |> # update the row_type and label dplyr::mutate( row_type = "missing", - label = x$inputs$missing_text + label = missing_text ) } -.add_table_styling_stats <- function(x, calling_function = "tbl_summary") { - if (is_empty(x$inputs$by)) { +.add_table_styling_stats <- function(x, by = x$inputs$by, calling_function = "tbl_summary") { + if (is_empty(by)) { x$table_styling$header <- x$table_styling$header |> dplyr::mutate( @@ -491,7 +509,7 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include, ) } else { df_by_stats <- x[["cards"]][[calling_function]] |> - dplyr::filter(.data$variable %in% .env$x$inputs$by & .data$stat_name %in% c("N", "n", "p")) + dplyr::filter(.data$variable %in% .env$by & .data$stat_name %in% c("N", "n", "p")) # get a data frame with the by variable stats df_by_stats_wide <- @@ -501,14 +519,11 @@ pier_summary_missing_row <- function(x, variables = x$inputs$include, .by = "variable_level", column = paste0("stat_", dplyr::cur_group_id()) ) %>% - { - dplyr::bind_rows( - ., - dplyr::select(., "variable_level", "column", stat = "variable_level") |> - dplyr::mutate(stat_name = "level") |> - dplyr::distinct() - ) - } |> + dplyr::bind_rows( + dplyr::select(., "variable_level", "column", stat = "variable_level") |> + dplyr::mutate(stat_name = "level") |> + dplyr::distinct() + ) |> tidyr::pivot_wider( id_cols = "column", names_from = "stat_name", diff --git a/R/card_summary.R b/R/card_summary.R new file mode 100644 index 0000000000..6052407f38 --- /dev/null +++ b/R/card_summary.R @@ -0,0 +1,264 @@ +#' ARD summary table +#' +#' The `card_summary()` function tables descriptive statistics for +#' continuous, categorical, and dichotomous variables. +#' The functions accepts an ARD object. +#' +#' @param cards (`card`)\cr +#' An ARD object of class `"card"` typically created with `cards::ard_*()` functions. +#' @param statistic ([`formula-list-selector`][syntax])\cr +#' Used to specify the summary statistics for each variable. +#' Each of the statistics must be present in `card` as no new statistics are calculated +#' in this function. +#' The default is +#' `list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)")`. +#' @param missing,missing_text,missing_stat +#' Arguments dictating how and if missing values are presented: +#' - `missing`: must be one of `c("ifany", "no", "always")` +#' - `missing_text`: string indicating text shown on missing row. Default is `"Unknown"` +#' - `missing_stat`: statistic to show on missing row. Default is `"{N_miss}"`. +#' Possible values are `N_miss`, `N_obs`, `N_nonmiss`, `p_miss`, `p_nonmiss` +#' @param type ([`formula-list-selector`][syntax])\cr +#' Specifies the summary type. Accepted value are +#' `c("continuous", "continuous2", "categorical", "dichotomous")`. +#' Continuous summaries may be assigned `c("continuous", "continuous2")`, while +#' categorical and dichotomous cannot be modified. +#' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variables to include in the summary table. Default is `everything()` +#' +#' @return a gtsummary table of class `"card_summary"` +#' @export +#' +#' @examples +#' library(cards) +#' +#' ard_stack( +#' data = ADSL, +#' by = NULL, +#' ard_categorical(variables = "AGEGR1"), +#' ard_continuous(variables = "AGE"), +#' .attributes = TRUE, +#' .missing = TRUE +#' ) |> +#' card_summary() +#' +#' ard_stack( +#' data = ADSL, +#' by = ARM, +#' ard_categorical(variables = "AGEGR1"), +#' ard_continuous(variables = "AGE"), +#' .attributes = TRUE, +#' .missing = TRUE +#' ) |> +#' card_summary() +card_summary <- function(cards, + statistic = list( + all_continuous() ~ "{median} ({p25}, {p75})", + all_categorical() ~ "{n} ({p}%)" + ), + type = NULL, + missing = c("ifany", "no", "always"), + missing_text = "Unknown", + missing_stat = "{N_miss}", + include = everything()) { + set_cli_abort_call() + # data argument checks ------------------------------------------------------- + check_not_missing(cards) + check_class(cards, "card") + missing <- arg_match(missing) + + # check structure of ARD input ----------------------------------------------- + # TODO: What other checks should we add? + if (!is_empty(names(dplyr::select(cards, cards::all_ard_groups())) |> setdiff(c("group1", "group1_level")))) { + cli::cli_abort( + c("The {.arg cards} object may only contain a single stratifying variable.", + i = "But contains {.val {names(dplyr::select(cards, cards::all_ard_groups())) |> setdiff(c('group1', 'group1_level'))}}." + ), + call = get_cli_abort_call() + ) + } + + # define a data frame based on the context of `card` ------------------------- + data <- cards |> + dplyr::select(cards::all_ard_variables()) |> + dplyr::bind_rows( + dplyr::select(cards, cards::all_ard_groups()) |> + dplyr::rename(variable = any_of("group1"), variable_level = any_of("group1_level")) + ) |> + dplyr::filter(!is.na(.data$variable)) |> + dplyr::slice(.by = "variable", 1L) |> + dplyr::mutate(variable_level = map(.data$variable_level, ~ .x %||% NA_real_)) |> + tidyr::pivot_wider( + names_from = "variable", + values_from = "variable_level" + ) |> + dplyr::mutate(across(everything(), unlist)) + + if ("group1" %in% names(cards)) { + by <- stats::na.omit(cards$group1)[1] |> unclass() + } else { + by <- character(0L) + } + cards::process_selectors(data, include = {{ include }}) + include <- setdiff(include, by) # remove by variable from list vars included + + # check that each included variable has 'missing' and 'attributes' ARDs (this can probably be relaxed later) + missing_or_attributes_ard <- + imap( + include, + ~ dplyr::filter(cards, .data$variable %in% .env$.x, .data$context %in% c("missing", "attributes")) |> + dplyr::select("variable", "context") |> + dplyr::distinct() |> + nrow() %>% + {!identical(., 2L)} # styler: off + ) |> + set_names(include) |> + unlist() + if (any(missing_or_attributes_ard)) { + cli::cli_abort( + c("{.val {names(missing_or_attributes_ard)[missing_or_attributes_ard]}} + {?does/do} not have associated {.field missing} or {.field attributes} ARD results.", + i = "Use {.fun cards::ard_missing}, {.fun cards::ard_attributes}, or + {.code cards::ard_stack(.missing=TRUE, .attributes=TRUE)} to calculate needed results." + ), + call = get_cli_abort_call() + ) + } + + # temporary type so we can evaluate `statistic`, then we'll update it + default_types <- dplyr::select(cards, "variable", "context") |> + dplyr::distinct() |> + dplyr::filter( + .data$context %in% c("continuous", "categorical", "dichotomous"), + .data$variable %in% .env$include + ) |> + deframe() |> + as.list() + + # process arguments ---------------------------------------------------------- + cards::process_formula_selectors( + data = select_prep(.list2tb(default_types, "var_type"), data[include]), + type = type + ) + # fill in unspecified variables + cards::fill_formula_selectors( + select_prep(.list2tb(default_types, "var_type"), data[include]), + type = default_types, + ) + cards::check_list_elements( + x = type, + predicate = \(x) is.character(x) && length(x) == 1L && x %in% c("categorical", "dichotomous", "continuous", "continuous2"), + error_msg = "Elements of the {.arg type} argumnet must be one of {.val {c('categorical', 'dichotomous', 'continuous', 'continuous2')}}." + ) + # if the user passed `type` then check that the values are compatible with ARD summary types + if (!missing(type)) { + walk( + include, + function(variable) { + if (default_types[[variable]] %in% "continuous" && + !type[[variable]] %in% c("continuous", "continuous2")) { + cli::cli_abort( + "Summary type for variable {.val {variable}} must be one of + {.val {c('continuous', 'continuous2')}}, not {.val {type[[variable]]}}.", + call = get_cli_abort_call() + ) + } else if (default_types[[variable]] %in% c("categorical", "dichotomous") && + !identical(type[[variable]], default_types[[variable]])) { + cli::cli_abort( + "Summary type for variable {.val {variable}} must be + {.val {default_types[[variable]]}}, not {.val {type[[variable]]}}.", + call = get_cli_abort_call() + ) + } + } + ) + } + + cards::process_formula_selectors( + data = select_prep(.list2tb(type, "var_type"), data[include]), + statistic = statistic + ) + # fill in unspecified variables + cards::fill_formula_selectors( + select_prep(.list2tb(type, "var_type"), data[include]), + statistic = eval(formals(gtsummary::card_summary)[["statistic"]]), + ) + cards::check_list_elements( + x = statistic, + predicate = \(x) is.character(x), + error_msg = "The {.arg statistic} argument values must be class {.cls character} vector." + ) + walk( + include, + \(variable) { + stat_names <- .extract_glue_elements(statistic[[variable]]) + stat_names_not_in_cards <- + stat_names |> + discard(~ .x %in% dplyr::filter(cards, .data$variable %in% .env$variable)$stat_name) + if (!is_empty(stat_names_not_in_cards)) { + cli::cli_abort( + c("The {.val {stat_names_not_in_cards}} statistics for variable {.val {variable}} + are not present in the {.arg cards} ARD object.", + i = "Choose among the following statistics + {.val {dplyr::filter(cards, .data$variable %in% .env$variable, !.data$context %in% 'attributes')$stat_name |> unique()}}." + ), + call = get_cli_abort_call() + ) + } + } + ) + walk( + include, + \(variable) { + if (type[[variable]] %in% c("categorical", "dichotomous", "continuous") && + !is_string(statistic[[variable]])) { + cli::cli_abort( + "Variable {.val {variable}} is type {.arg {type[[variable]]}} and + {.arg statistic} argument value must be a string of length one.", + call = get_cli_abort_call() + ) + } + } + ) + # save inputs + card_summary_inputs <- as.list(environment())[names(formals(card_summary))] + call <- match.call() + + # construct initial card_summary object -------------------------------------- + x <- + list( + cards = list(card_summary = cards), + inputs = card_summary_inputs, + call_list = list(card_summary = call) + ) |> + brdg_summary( + calling_function = "card_summary", + by = by, + include = include, + type = type + ) |> + structure(class = c("card_summary", "gtsummary")) + + # adding styling ------------------------------------------------------------- + x <- x |> + # add header to label column and add default indentation + modify_table_styling( + columns = "label", + label = "**Characteristic**", + rows = .data$row_type %in% c("level", "missing"), + indentation = 4L + ) |> + # adding the statistic footnote + modify_table_styling( + columns = all_stat_cols(), + footnote = + .construct_summary_footnote(x$cards[["card_summary"]], include, statistic, type) + ) |> + # updating the headers for the stats columns + modify_header( + all_stat_cols() ~ ifelse(is_empty(by), "**N = {N}**", "**{level}** \nN = {n}") + ) + + # return card_summary table -------------------------------------------------- + x +} diff --git a/R/import-standalone-tibble.R b/R/import-standalone-tibble.R index 1133e623c3..f4c7b001fc 100644 --- a/R/import-standalone-tibble.R +++ b/R/import-standalone-tibble.R @@ -4,7 +4,7 @@ # # --- # file: standalone-tibble.R -# last-updated: 2024-03-09 +# last-updated: 2024-05-07 # license: https://unlicense.org # imports: [dplyr] # --- @@ -18,6 +18,11 @@ # nocov start # styler: off +deframe <- function(x) { + if (ncol(x) == 1L) return(x[[1]]) + x[[2]] |> stats::setNames(x[[1]]) +} + enframe <- function(x, name = "name", value = "value") { if (!is.null(names(x))) { lst <- list(names(x), unname(x)) |> stats::setNames(c(name, value)) diff --git a/R/modify_column_merge.R b/R/modify_column_merge.R index 2e606b76e3..dfa404646e 100644 --- a/R/modify_column_merge.R +++ b/R/modify_column_merge.R @@ -71,15 +71,18 @@ modify_column_merge <- function(x, pattern, rows = NULL) { if (is_empty(columns)) { cli::cli_abort( c("No column names found in {.code modify_column_merge(pattern)} argument.", - i = "Wrap all column names in curly brackets, e.g {.code modify_column_merge(pattern = '{{conf.low}}, {{conf.high}}')}."), + i = "Wrap all column names in curly brackets, e.g {.code modify_column_merge(pattern = '{{conf.low}}, {{conf.high}}')}." + ), call = get_cli_abort_call() ) } if (!all(columns %in% names(x$table_body))) { problem_cols <- columns %>% setdiff(names(x$table_body)) cli::cli_abort( - c("Columns specified in the {.code modify_column_merge(pattern)} argument are not present in table.", - "Columns {.val {problem_cols}} not found."), + c( + "Columns specified in the {.code modify_column_merge(pattern)} argument are not present in table.", + "Columns {.val {problem_cols}} not found." + ), call = get_cli_abort_call() ) } diff --git a/R/select_helpers.R b/R/select_helpers.R index 86eef01d48..40d03b9c1d 100644 --- a/R/select_helpers.R +++ b/R/select_helpers.R @@ -150,7 +150,9 @@ select_prep <- function(table_body, data = NULL) { if (!is.null(table_body)) { attr_cols <- intersect(names(table_body), c("var_type", "test_name")) for (v in attr_cols) { - df_attr <- table_body[c("variable", v)] |> unique() |> tidyr::drop_na() + df_attr <- table_body[c("variable", v)] |> + unique() |> + tidyr::drop_na() for (i in seq_len(nrow(df_attr))) { attr(data[[df_attr$variable[i]]], paste0("gtsummary.", v)) <- df_attr[[v]][i] } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index ca1f1b84d6..a0b06a7c44 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -1,4 +1,4 @@ -#' Summary statistics table +#' Summary table #' #' The `tbl_summary()` function calculates descriptive statistics for #' continuous, categorical, and dichotomous variables. @@ -182,7 +182,8 @@ tbl_summary <- function(data, by, allow_empty = TRUE, message = c("The {.arg {arg_name}} argument must be length {.val {length}} or empty.", - i = "Use {.fun tbl_strata} for more than one {.arg by} variable.") + i = "Use {.fun tbl_strata} for more than one {.arg by} variable." + ) ) data <- dplyr::ungroup(data) |> .drop_missing_by_obs(by = by) # styler: off include <- setdiff(include, by) # remove by variable from list vars included @@ -200,7 +201,7 @@ tbl_summary <- function(data, cards::process_formula_selectors( data = select_prep(.list2tb(default_types, "var_type"), data[include]), type = type - ) + ) # fill in any types not specified by user type <- utils::modifyList(default_types, type) } else { @@ -297,7 +298,7 @@ tbl_summary <- function(data, stat_label = ~ default_stat_labels() ), # tabulate by variable for header stats - if (!rlang::is_empty(by)) { + if (!is_empty(by)) { cards::ard_categorical(data, variables = all_of(by), stat_label = ~ default_stat_labels() @@ -376,7 +377,9 @@ tbl_summary <- function(data, } .drop_missing_by_obs <- function(data, by) { - if (is_empty(by) || !any(is.na(data[[by]]))) return(data) + if (is_empty(by) || !any(is.na(data[[by]]))) { + return(data) + } obs_to_drop <- is.na(data[[by]]) cli::cli_inform("{.val {sum(obs_to_drop)}} missing observations in the {.val {by}} column have been removed.") @@ -398,7 +401,8 @@ tbl_summary <- function(data, if (!is_empty(missing_stats)) { cli::cli_abort( c("Statistic {.val {missing_stats}} is not available for variable {.val {variable}}.", - i = "Select among {.val {rev(unique(available_stats))}}."), + i = "Select among {.val {rev(unique(available_stats))}}." + ), call = get_cli_abort_call() ) } @@ -572,7 +576,6 @@ tbl_summary <- function(data, ), call = get_cli_abort_call()) } ) - } ) |> set_names(chr_fun_names) diff --git a/R/utils-add_p_tests.R b/R/utils-add_p_tests.R index 506e9c3c82..130cb4eb9b 100644 --- a/R/utils-add_p_tests.R +++ b/R/utils-add_p_tests.R @@ -91,8 +91,10 @@ add_p_test_chisq.test <- function(data, variable, by, test.args, ...) { } add_p_test_chisq.test.no.correct <- function(data, variable, by, test.args, ...) { - add_p_test_chisq.test(data = data, variable = variable, by = by, - test.args = c(list(correct = FALSE), test.args), ...) + add_p_test_chisq.test( + data = data, variable = variable, by = by, + test.args = c(list(correct = FALSE), test.args), ... + ) } add_p_test_mood.test <- function(data, variable, by, test.args, ...) { @@ -548,7 +550,7 @@ warn_unbalanced_pairs <- function(data, by, variable, group) { } check_empty <- function(x, variable = get("variable", envir = caller_env()), - call = get_cli_abort_call(), ...) { + call = get_cli_abort_call(), ...) { dots <- dots_list(...) walk( x, @@ -564,4 +566,3 @@ check_empty <- function(x, variable = get("variable", envir = caller_env()), invisible() } - diff --git a/man/assign_tests.Rd b/man/assign_tests.Rd index c9b5210ae2..ec726b864a 100644 --- a/man/assign_tests.Rd +++ b/man/assign_tests.Rd @@ -52,7 +52,7 @@ and \code{add_difference()}. trial |> tbl_summary( by = trt, - include = c(age, stage) + include = c(age, stage) ) |> assign_tests(include = c("age", "stage"), calling_fun = "add_p") } diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index a13248d9fb..906c11a43c 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -10,7 +10,13 @@ \alias{pier_summary_missing_row} \title{Summary Table Bridges} \usage{ -brdg_summary(x, calling_function = "tbl_summary") +brdg_summary( + x, + calling_function = "tbl_summary", + by = x$inputs$by, + include = x$inputs$include, + type = x$inputs$type +) pier_summary_dichotomous( x, @@ -40,6 +46,7 @@ pier_summary_continuous2( pier_summary_continuous( x, variables, + statistic = x$inputs$statistic, missing, missing_text, missing_stat, @@ -49,6 +56,8 @@ pier_summary_continuous( pier_summary_missing_row( x, variables = x$inputs$include, + missing_stat = x$inputs$missing_stat, + missing_text = x$inputs$missing_text, calling_function = "tbl_summary" ) } @@ -59,6 +68,19 @@ pier_summary_missing_row( calling thie bridge function, e.g. \code{call_function = "tbl_summary"}. This is used internally to organize results.} +\item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +A single column from \code{data}. Summary statistics will be stratified by this variable. +Default is \code{NULL}} + +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in the summary table. Default is \code{everything()}} + +\item{type}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the summary type. Accepted value are +\code{c("continuous", "continuous2", "categorical", "dichotomous")}. +If not specified, default type is assigned via +\code{assign_summary_type()}. See below for details.} + \item{variables}{character list of variables} \item{value}{named list of values to be summarized. the names are the @@ -71,6 +93,11 @@ variable names.} \item \code{missing_stat}: statistic to show on missing row. Default is \code{"{N_miss}"}. Possible values are \code{N_miss}, \code{N_obs}, \code{N_nonmiss}, \code{p_miss}, \code{p_nonmiss} }} + +\item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies summary statistics to display for each variable. The default is +\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. +See below for details.} } \value{ data frame diff --git a/man/card_summary.Rd b/man/card_summary.Rd new file mode 100644 index 0000000000..a45383f5bb --- /dev/null +++ b/man/card_summary.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/card_summary.R +\name{card_summary} +\alias{card_summary} +\title{ARD summary table} +\usage{ +card_summary( + cards, + statistic = list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ + "{n} ({p}\%)"), + type = NULL, + missing = c("ifany", "no", "always"), + missing_text = "Unknown", + missing_stat = "{N_miss}", + include = everything() +) +} +\arguments{ +\item{cards}{(\code{card})\cr +An ARD object of class \code{"card"} typically created with \verb{cards::ard_*()} functions.} + +\item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr +Used to specify the summary statistics for each variable. +Each of the statistics must be present in \code{card} as no new statistics are calculated +in this function. +The default is +\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}.} + +\item{type}{(\code{\link[=syntax]{formula-list-selector}})\cr +Specifies the summary type. Accepted value are +\code{c("continuous", "continuous2", "categorical", "dichotomous")}. +Continuous summaries may be assigned \code{c("continuous", "continuous2")}, while +categorical and dichotomous cannot be modified.} + +\item{missing, missing_text, missing_stat}{Arguments dictating how and if missing values are presented: +\itemize{ +\item \code{missing}: must be one of \code{c("ifany", "no", "always")} +\item \code{missing_text}: string indicating text shown on missing row. Default is \code{"Unknown"} +\item \code{missing_stat}: statistic to show on missing row. Default is \code{"{N_miss}"}. +Possible values are \code{N_miss}, \code{N_obs}, \code{N_nonmiss}, \code{p_miss}, \code{p_nonmiss} +}} + +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in the summary table. Default is \code{everything()}} +} +\value{ +a gtsummary table of class \code{"card_summary"} +} +\description{ +The \code{card_summary()} function tables descriptive statistics for +continuous, categorical, and dichotomous variables. +The functions accepts an ARD object. +} +\examples{ +library(cards) + +ard_stack( + data = ADSL, + by = NULL, + ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE +) |> + card_summary() + +ard_stack( + data = ADSL, + by = ARM, + ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE +) |> + card_summary() +} diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index 8c72cd5a8e..d9f46097b1 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tbl_summary.R \name{tbl_summary} \alias{tbl_summary} -\title{Summary statistics table} +\title{Summary table} \usage{ tbl_summary( data, diff --git a/tests/testthat/_snaps/card_summary.md b/tests/testthat/_snaps/card_summary.md new file mode 100644 index 0000000000..1a2b6bda9f --- /dev/null +++ b/tests/testthat/_snaps/card_summary.md @@ -0,0 +1,120 @@ +# card_summary() works + + Code + as.data.frame(card_summary(ard_stack(data = ADSL, by = ARM, ard_categorical( + variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, + .missing = TRUE))) + Output + **Characteristic** **Placebo** \nN = 86 **Xanomeline High Dose** \nN = 84 + 1 Pooled Age Group 1 + 2 65-80 42 (48.8%) 55 (65.5%) + 3 <65 14 (16.3%) 11 (13.1%) + 4 >80 30 (34.9%) 18 (21.4%) + 5 Age 76.0 (69.0, 82.0) 76.0 (70.5, 80.0) + **Xanomeline Low Dose** \nN = 84 + 1 + 2 47 (56.0%) + 3 8 (9.5%) + 4 29 (34.5%) + 5 77.5 (71.0, 82.0) + +--- + + Code + as.data.frame(card_summary(ard_stack(data = ADSL, by = NULL, ard_categorical( + variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, + .missing = TRUE))) + Output + **Characteristic** **N = 254** + 1 Pooled Age Group 1 + 2 65-80 144 (56.7%) + 3 <65 33 (13.0%) + 4 >80 77 (30.3%) + 5 Age 77.0 (70.0, 81.0) + +# card_summary(statistic) argument works + + Code + as.data.frame(card_summary(ard, statistic = list(all_continuous() ~ "{median}", + all_categorical() ~ "{n} / {N} (Total {N_obs})"))) + Output + **Characteristic** **N = 254** + 1 Pooled Age Group 1 + 2 65-80 144 / 254 (Total 254) + 3 <65 33 / 254 (Total 254) + 4 >80 77 / 254 (Total 254) + 5 Age 77.0 + +--- + + Code + as.data.frame(card_summary(ard, type = list(all_continuous() ~ "continuous2"), + statistic = list(all_continuous() ~ c("{median}", "{mean}")))) + Output + **Characteristic** **N = 254** + 1 Pooled Age Group 1 + 2 65-80 144 (56.7%) + 3 <65 33 (13.0%) + 4 >80 77 (30.3%) + 5 Age + 6 Median 77.0 + 7 Mean 75.1 + +# card_summary(cards) error messages + + Code + card_summary(ard_stack(data = ADSL, by = c(ARM, AGEGR1), ard_continuous( + variables = "AGE"), .attributes = TRUE, .missing = TRUE)) + Condition + Error in `card_summary()`: + ! The `cards` object may only contain a single stratifying variable. + i But contains "group2" and "group2_level". + +--- + + Code + card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + .attributes = FALSE, .missing = TRUE)) + Condition + Error in `card_summary()`: + ! "AGE" does not have associated missing or attributes ARD results. + i Use `cards::ard_missing()`, `cards::ard_attributes()`, or `cards::ard_stack(.missing=TRUE, .attributes=TRUE)` to calculate needed results. + +# card_summary(type) error messages + + Code + card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + .attributes = TRUE, .missing = TRUE), type = list(AGE = "categorical")) + Condition + Error in `card_summary()`: + ! Summary type for variable "AGE" must be one of "continuous" and "continuous2", not "categorical". + +--- + + Code + card_summary(ard_stack(data = ADSL, by = ARM, ard_categorical(variables = "AGEGR1"), + .attributes = TRUE, .missing = TRUE), type = list(AGEGR1 = "continuous")) + Condition + Error in `card_summary()`: + ! Summary type for variable "AGEGR1" must be "categorical", not "continuous". + +# card_summary(statistic) error messages + + Code + card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + .attributes = TRUE, .missing = TRUE), statistic = list(AGE = "{not_a_valid_summary_statistic}")) + Condition + Error in `card_summary()`: + ! The "not_a_valid_summary_statistic" statistics for variable "AGE" are not present in the `cards` ARD object. + i Choose among the following statistics "N", "mean", "sd", "median", "p25", "p75", "min", "max", "N_obs", "N_miss", "N_nonmiss", "p_miss", and "p_nonmiss". + +--- + + Code + card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + .attributes = TRUE, .missing = TRUE), statistic = list(AGE = c("{mean}", + "{median}"))) + Condition + Error in `card_summary()`: + ! Variable "AGE" is type `continuous` and `statistic` argument value must be a string of length one. + diff --git a/tests/testthat/test-add_difference.tbl_summary.R b/tests/testthat/test-add_difference.tbl_summary.R index 538520802a..fcafa219bf 100644 --- a/tests/testthat/test-add_difference.tbl_summary.R +++ b/tests/testthat/test-add_difference.tbl_summary.R @@ -1,5 +1,7 @@ -skip_if_not(is_pkg_installed(c("broom", "broom.helpers", "lme4", "smd", - "effectsize", "emmeans"), reference_pkg = "cardx")) +skip_if_not(is_pkg_installed(c( + "broom", "broom.helpers", "lme4", "smd", + "effectsize", "emmeans" +), reference_pkg = "cardx")) test_that("add_difference.tbl_summary() works with basic usage", { expect_error( @@ -16,7 +18,8 @@ test_that("add_difference.tbl_summary() works with basic usage", { expect_snapshot( tbl_diff |> modify_column_hide(all_stat_cols()) |> - as.data.frame()) + as.data.frame() + ) expect_equal( tbl_diff$cards$add_difference$marker |> @@ -29,7 +32,9 @@ test_that("add_difference.tbl_summary() works with basic usage", { ) |> dplyr::select(all_of(c("estimate", "statistic", "parameter", "conf.low", "conf.high", "p.value"))), t.test(marker ~ trt, trial, var.equal = TRUE) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(all_of(c("estimate", "statistic", "parameter", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -131,16 +136,16 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { tbl_test.args <- trial |> select(trt, - var_t.test = age, - var_t.test_dots = age, - var_wilcox.test = age, - var_wilcox.test_dots = age, - var_prop.test = response, - var_prop.test_dots = response, - var_ancova = age, - var_cohens_d = age, - var_hedges_g = age, - var_smd = age + var_t.test = age, + var_t.test_dots = age, + var_wilcox.test = age, + var_wilcox.test_dots = age, + var_prop.test = response, + var_prop.test_dots = response, + var_ancova = age, + var_cohens_d = age, + var_hedges_g = age, + var_smd = age ) %>% tbl_summary( by = trt, missing = "no", @@ -182,7 +187,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { ) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), t.test(age ~ as.factor(trt), data = trial) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -198,7 +205,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { ) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), t.test(age ~ as.factor(trt), data = trial, var.equal = TRUE) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -215,7 +224,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { ) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), wilcox.test(age ~ trt, data = trial, conf.int = TRUE) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -231,7 +242,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { ) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), wilcox.test(age ~ trt, data = trial, correct = FALSE, conf.int = TRUE) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -248,7 +261,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), table(trial$trt, factor(trial$response) %>% fct_rev()) |> prop.test() %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> dplyr::mutate(estimate = estimate1 - estimate2) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE @@ -266,7 +281,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), table(trial$trt, factor(trial$response) %>% fct_rev()) |> prop.test(alternative = "greater") %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> dplyr::mutate(estimate = estimate1 - estimate2) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE @@ -283,7 +300,9 @@ test_that("statistics are replicated within add_difference.tbl_summary()", { ) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), lm(age ~ fct_rev(trt), trial) %>% - {withr::with_package("broom", tidy(., conf.int = TRUE))} |> + { + withr::with_package("broom", tidy(., conf.int = TRUE)) + } |> dplyr::slice(dplyr::n()) %>% select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE @@ -354,10 +373,10 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", tbl_groups <- trial_group |> select(trt, id, stage, marker, - age_ancova_lme4 = age, - age_paired_t_test = age, - age_paired_cohens_d = age, - age_paired_hedges_g = age + age_ancova_lme4 = age, + age_paired_t_test = age, + age_paired_cohens_d = age, + age_paired_hedges_g = age ) %>% tbl_summary( by = trt, @@ -366,10 +385,12 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", label = as.list(names(.)) |> setNames(names(.)) ) |> add_difference( - test = list(age_ancova_lme4 = "ancova_lme4", - age_paired_t_test = "paired.t.test", - age_paired_cohens_d = "paired_cohens_d", - age_paired_hedges_g = "paired_hedges_g"), + test = list( + age_ancova_lme4 = "ancova_lme4", + age_paired_t_test = "paired.t.test", + age_paired_cohens_d = "paired_cohens_d", + age_paired_hedges_g = "paired_hedges_g" + ), group = "id" ) expect_snapshot( @@ -392,7 +413,9 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", package = "lme4", lmer(age ~ fct_rev(factor(trt)) + (1 | id), trial_group) ) %>% - {withr::with_package("broom.mixed", tidy(., conf.int = TRUE, effects = "fixed"))} |> + { + withr::with_package("broom.mixed", tidy(., conf.int = TRUE, effects = "fixed")) + } |> dplyr::slice(dplyr::n()) |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE @@ -413,7 +436,9 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", y = trial_group_wide$age.y, paired = TRUE ) %>% - {withr::with_package("broom", tidy(.))} |> + { + withr::with_package("broom", tidy(.)) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -437,7 +462,9 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", verbose = FALSE ) ) %>% - {withr::with_package("parameters", standardize_names(., style = "broom"))} |> + { + withr::with_package("parameters", standardize_names(., style = "broom")) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -461,7 +488,9 @@ test_that("statistics are replicated within add_difference.tbl_summary(group)", verbose = FALSE ) ) %>% - {withr::with_package("parameters", standardize_names(., style = "broom"))} |> + { + withr::with_package("parameters", standardize_names(., style = "broom")) + } |> select(any_of(c("estimate", "conf.low", "conf.high", "p.value"))), ignore_attr = TRUE ) @@ -605,4 +634,3 @@ test_that("ordering in add_difference.tbl_summary() with paired tests", { as.data.frame() ) }) - diff --git a/tests/testthat/test-add_p.tbl_summary.R b/tests/testthat/test-add_p.tbl_summary.R index 733d17359c..1342b441d0 100644 --- a/tests/testthat/test-add_p.tbl_summary.R +++ b/tests/testthat/test-add_p.tbl_summary.R @@ -60,8 +60,6 @@ test_that("add_p.tbl_summary() error messaging with bad inputs", { tbl_summary(trial[c("trt", "age")], by = trt) |> add_p(group = c("trt", "age")) ) - - }) test_that("add_p.tbl_summary() & lme4", { @@ -149,7 +147,7 @@ test_that("add_p with custom p-value function", { ) expect_equal( as.data.frame(tbl), - trial[c("response", "trt")] |> + trial[c("response", "trt")] |> tbl_summary(by = trt) |> add_p(test = response ~ my_mcnemar) |> as.data.frame() @@ -172,7 +170,8 @@ test_that("Wilcoxon and Kruskal-Wallis p-values match ", { expect_true( all( (t1$cards$add_p |> dplyr::bind_rows() |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist()) - - (t2$cards$add_p |> dplyr::bind_rows() |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist()) < 0.001) + (t2$cards$add_p |> dplyr::bind_rows() |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist()) < 0.001 + ) ) }) @@ -183,19 +182,19 @@ test_that("p-values are replicated within tbl_summary()", { tbl_test.args <- trial |> dplyr::select(trt, - var_t.test = age, - var_t.test_dots = age, - var_kruskal.test = age, - var_wilcox.test = age, - var_wilcox.test_dots = age, - var_oneway.test = age, - var_chisq.test = response, - var_chisq.test_dots = response, - var_chisq.test.no.correct = response, - var_fisher.test = response, - var_fisher.test_dots = response, - var_mcnemar.test = response, - var_mcnemar.test_dots = response, + var_t.test = age, + var_t.test_dots = age, + var_kruskal.test = age, + var_wilcox.test = age, + var_wilcox.test_dots = age, + var_oneway.test = age, + var_chisq.test = response, + var_chisq.test_dots = response, + var_chisq.test.no.correct = response, + var_fisher.test = response, + var_fisher.test_dots = response, + var_mcnemar.test = response, + var_mcnemar.test_dots = response, ) |> tbl_summary(by = trt, missing = "no") |> add_p( @@ -295,7 +294,7 @@ test_that("p-values are replicated within tbl_summary() with groups", { trial_group |> dplyr::filter(trt == "Drug A") |> dplyr::full_join( - trial_group |> + trial_group |> dplyr::filter(trt == "Drug B"), by = "id" ) @@ -347,7 +346,7 @@ test_that("p-values are replicated within tbl_summary() with groups", { expect_equal( tbl_groups$cards$add_p[["response_mcnemar.test_dots"]] |> dplyr::filter(stat_name %in% "p.value") |> dplyr::pull(stat) |> unlist() |> unname(), mcnemar.test(trial_group_wide[["response.x"]], trial_group_wide[["response.y"]], - correct = FALSE + correct = FALSE )$p.value ) @@ -396,7 +395,7 @@ test_that("Groups arg and lme4", { tbl_groups <- trial_group %>% select(trt, id, - age_lme4 = age + age_lme4 = age ) %>% tbl_summary(by = trt, missing = "no", include = -id) %>% add_p( @@ -511,7 +510,7 @@ test_that("addressing GH #1513, where the default test was incorrect", { tibble::add_row(tidyr::uncount(tibble::tibble(type = "A", answer = NA), 400)) |> tibble::add_row(tidyr::uncount(tibble::tibble(type = "B", answer = NA), 300)) |> tbl_summary(by = type) |> - assign_tests(include = "answer", calling_fun ="add_p") |> + assign_tests(include = "answer", calling_fun = "add_p") |> getElement(1L) |> attr("test_name"), "fisher.test" diff --git a/tests/testthat/test-card_summary.R b/tests/testthat/test-card_summary.R new file mode 100644 index 0000000000..6b2b43cc03 --- /dev/null +++ b/tests/testthat/test-card_summary.R @@ -0,0 +1,146 @@ +# adding a few basic tests here to ensure we don't break the function with other updates +test_that("card_summary() works", { + withr::local_package(package = "cards") # TODO: We can delete this after ard_stack() works when cards not loaded + + expect_snapshot( + ard_stack( + data = ADSL, + by = ARM, + ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary() |> + as.data.frame() + ) + + expect_snapshot( + ard_stack( + data = ADSL, + by = NULL, + ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary() |> + as.data.frame() + ) +}) + +test_that("card_summary(statistic) argument works", { + withr::local_package(package = "cards") # TODO: We can delete this after ard_stack() works when cards not loaded + + ard <- + ard_stack( + data = ADSL, + by = NULL, + ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) + + expect_snapshot( + card_summary( + ard, + statistic = list(all_continuous() ~ "{median}", all_categorical() ~ "{n} / {N} (Total {N_obs})") + ) |> + as.data.frame() + ) + + expect_snapshot( + card_summary( + ard, + type = list(all_continuous() ~ "continuous2"), + statistic = list(all_continuous() ~ c("{median}", "{mean}")) + ) |> + as.data.frame() + ) +}) + + +test_that("card_summary(cards) error messages", { + withr::local_package(package = "cards") # TODO: We can delete this after ard_stack() works when cards not loaded + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = c(ARM, AGEGR1), + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary() + ) + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = ARM, + ard_continuous(variables = "AGE"), + .attributes = FALSE, + .missing = TRUE + ) |> + card_summary() + ) +}) + +test_that("card_summary(type) error messages", { + withr::local_package(package = "cards") # TODO: We can delete this after ard_stack() works when cards not loaded + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = ARM, + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary(type = list(AGE = "categorical")) + ) + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = ARM, + ard_categorical(variables = "AGEGR1"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary(type = list(AGEGR1 = "continuous")) + ) +}) + +test_that("card_summary(statistic) error messages", { + withr::local_package(package = "cards") # TODO: We can delete this after ard_stack() works when cards not loaded + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = ARM, + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary(statistic = list(AGE = "{not_a_valid_summary_statistic}")) + ) + + expect_snapshot( + error = TRUE, + ard_stack( + data = ADSL, + by = ARM, + ard_continuous(variables = "AGE"), + .attributes = TRUE, + .missing = TRUE + ) |> + card_summary(statistic = list(AGE = c("{mean}", "{median}"))) + ) +}) diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index 57b4b6d4c7..b2f3333d4e 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -75,32 +75,36 @@ test_that("tbl_summary(statistic)", { ) # continuous summary, testing cv function and passed in formula - expect_equal({ - cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 - trial |> - tbl_summary( - include = age, - statistic = - age ~ "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}", - missing = "no" - ) |> - as.data.frame(col_labels = FALSE) |> - dplyr::pull(stat_0)}, + expect_equal( + { + cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 + trial |> + tbl_summary( + include = age, + statistic = + age ~ "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}", + missing = "no" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0) + }, "cv=30 | N_obs=200 | N_miss=11 | N_nonmiss=189 | p_miss=5.5 | p_nonmiss=95" ) # continuous summary, testing cv function and passed in named list - expect_equal({ - cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 - trial |> - tbl_summary( - include = age, - statistic = - list(age = "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}"), - missing = "no" - ) |> - as.data.frame(col_labels = FALSE) |> - dplyr::pull(stat_0)}, + expect_equal( + { + cv <- function(x) sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100 + trial |> + tbl_summary( + include = age, + statistic = + list(age = "cv={cv} | N_obs={N_obs} | N_miss={N_miss} | N_nonmiss={N_nonmiss} | p_miss={p_miss} | p_nonmiss={p_nonmiss}"), + missing = "no" + ) |> + as.data.frame(col_labels = FALSE) |> + dplyr::pull(stat_0) + }, "cv=30 | N_obs=200 | N_miss=11 | N_nonmiss=189 | p_miss=5.5 | p_nonmiss=95" ) }) @@ -184,8 +188,10 @@ test_that("tbl_summary(digit) errors properly", { trial, include = age, digits = list( - age = list(median = letters, # this is not a function! - p25 = \(x) style_number(x, digits = 2)) + age = list( + median = letters, # this is not a function! + p25 = \(x) style_number(x, digits = 2) + ) ), missing = "no" ), @@ -302,8 +308,6 @@ test_that("tbl_summary(type)", { getElement("yn"), "categorical" ) - - }) test_that("tbl_summary(type) proper errors/messages", { @@ -397,7 +401,7 @@ test_that("tbl_summary(missing)", { as.data.frame() ) # age includes an Unknown row, and trt does not - expect_equal(tbl[,1], c("Chemotherapy Treatment", "Drug A", "Drug B", "Age", "Unknown")) + expect_equal(tbl[, 1], c("Chemotherapy Treatment", "Drug A", "Drug B", "Age", "Unknown")) # all vars have a missing row when requested expect_equal( From f0e3a0b567fd0492a3292c80af2ff583e9f5c6fa Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Tue, 14 May 2024 10:27:19 -0700 Subject: [PATCH 53/74] Generalizing `brdg_summary()` and supporting `pier_*()` functions (#1642) * brdg updates! * updates --- R/bridge_summary.R | 277 +++++++++++------- R/card_summary.R | 43 +-- R/tbl_summary.R | 34 ++- man/bridge_summary.Rd | 180 ++++++------ .../testthat/_snaps/add_p.tbl_summary.new.md | 34 +++ tests/testthat/_snaps/card_summary.md | 4 +- 6 files changed, 325 insertions(+), 247 deletions(-) create mode 100644 tests/testthat/_snaps/add_p.tbl_summary.new.md diff --git a/R/bridge_summary.R b/R/bridge_summary.R index cfe568d24d..e7a9dc3dff 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -7,87 +7,128 @@ #' This file also contains helper functions for constructing the bridge, #' referred to as the piers (supports for a bridge) and begin with `pier_*()`. #' -#' @param x gtsummary object of class `"tbl_summary"` -#' @param variables character list of variables -#' @param value named list of values to be summarized. the names are the -#' variable names. -#' @param calling_function string indicating the name of the function that is -#' calling thie bridge function, e.g. `call_function = "tbl_summary"`. This is used -#' internally to organize results. +#' - `brdg_summary()`: The bridge function ingests an ARD data frame and returns +#' a gtsummary table that includes `.$table_body` and a basic `.$table_styling`. +#' The `.$table_styling$header` data frame includes the header statistics. +#' Based on context, this function adds a column to the ARD data frame named +#' `"gts_column"`. This column is used during the reshaping in the `pier_*()` +#' functions defining column names. +#' +#' - `pier_*()`: these functions accept a cards tibble and returns a tibble +#' that is a piece of the `.$table_body`. Typically these will be stacked +#' to construct the final table body data frame. The ARD object passed here +#' will have two primary parts: the calculated summary statistics and the +#' attributes ARD. The attributes ARD is used for labeling. The ARD data frame +#' passed to this function must include a `"gts_column"` column, which is +#' added in `brdg_summary()`. +#' +#' @param cards (`card`)\cr +#' An ARD object of class `"card"` typically created with `cards::ard_*()` functions. +#' @param variables (`character`)\cr +#' character list of variables +#' @param by (`string`)\cr +#' string indicating the stratifying column +#' @param type (named `list`)\cr +#' named list of summary types +#' @param statistic (named `list`)\cr +#' named list of summary statistic names #' @inheritParams tbl_summary #' #' @return data frame #' @name bridge_summary #' #' @examples -#' tbl <- -#' tbl_summary( -#' data = mtcars, -#' include = c("cyl", "am", "mpg", "hp"), -#' type = -#' list( -#' cyl = "categorical", -#' am = "dichotomous", -#' mpg = "continuous", -#' hp = "continuous2" -#' ), -#' value = list(am = 1), -#' statistic = -#' list( -#' c(cyl, am) ~ "{n} ({p}%)", -#' mpg = "{mean} ({sd})", -#' hp = c("{mean}", "{median}") -#' ) -#' ) +#' library(cards) +#' +#' # first build ARD data frame +#' cards <- +#' ard_stack( +#' mtcars, +#' by = NULL, +#' ard_continuous(variables = c("mpg", "hp")), +#' ard_categorical(variables = "cyl"), +#' ard_dichotomous(variables = "am"), +#' .missing = TRUE, +#' .attributes = TRUE +#' ) |> +#' # this column is used by the `pier_*()` functions +#' dplyr::mutate(gts_column = ifelse(context == "attributes", NA, "stat_0")) +#' +#' brdg_summary( +#' cards = cards, +#' variables = c("cyl", "am", "mpg", "hp"), +#' type = +#' list( +#' cyl = "categorical", +#' am = "dichotomous", +#' mpg = "continuous", +#' hp = "continuous2" +#' ), +#' statistic = +#' list( +#' cyl = "{n} / {N}", +#' am = "{n} / {N}", +#' mpg = "{mean} ({sd})", +#' hp = c("{median} ({p25}, {p75})", "{mean} ({sd})") +#' ) +#' ) |> +#' as_tibble() #' #' pier_summary_dichotomous( -#' x = tbl, +#' cards = cards, #' variables = "am", -#' value = list(am = 1) +#' statistic = list(am = "{n} ({p})") #' ) #' #' pier_summary_categorical( -#' x = tbl, -#' variables = "cyl" +#' cards = cards, +#' variables = "cyl", +#' statistic = list(cyl = "{n} ({p})") #' ) #' #' pier_summary_continuous2( -#' x = tbl, -#' variables = "hp" +#' cards = cards, +#' variables = "hp", +#' statistic = list(hp = c("{median}", "{mean}")) #' ) #' #' pier_summary_continuous( -#' x = tbl, -#' variables = "mpg" +#' cards = cards, +#' variables = "mpg", +#' statistic = list(mpg = "{median}") #' ) NULL #' @rdname bridge_summary #' @export -brdg_summary <- function(x, - calling_function = "tbl_summary", - by = x$inputs$by, - include = x$inputs$include, - type = x$inputs$type) { +brdg_summary <- function(cards, + variables, + type, + statistic, + by = NULL, + missing = "no", + missing_stat = "{N_miss}", + missing_text = "Unknown") { set_cli_abort_call() + # add gts info to the cards table -------------------------------------------- # adding the name of the column the stats will populate if (is_empty(by)) { - x[["cards"]][[calling_function]]$gts_column <- + cards$gts_column <- ifelse( - x[["cards"]][[calling_function]]$context %in% c("continuous", "categorical", "dichotomous", "missing"), + cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), "stat_0", NA_character_ ) } else { - x[["cards"]][[calling_function]] <- - x[["cards"]][[calling_function]] %>% + cards <- + cards %>% { dplyr::left_join( ., dplyr::filter( ., - .data$variable %in% .env$include, + .data$variable %in% .env$variables, .data$context %in% c("continuous", "categorical", "dichotomous", "missing") ) |> dplyr::select(cards::all_ard_groups(), "variable", "context") |> @@ -103,34 +144,41 @@ brdg_summary <- function(x, # build the table body pieces with bridge functions and stack them ----------- + x <- list() x$table_body <- dplyr::left_join( dplyr::tibble( - variable = include, + variable = variables, var_type = type[.data$variable] |> unlist() |> unname() ), dplyr::bind_rows( pier_summary_continuous( - x, + cards = cards, variables = .get_variables_by_type(type, type = "continuous"), - calling_function = calling_function + statistic = statistic ), pier_summary_continuous2( - x, + cards = cards, variables = .get_variables_by_type(type, type = "continuous2"), - calling_function = calling_function + statistic = statistic ), pier_summary_categorical( - x, + cards = cards, variables = .get_variables_by_type(type, type = "categorical"), - calling_function = calling_function + statistic = statistic ), pier_summary_dichotomous( - x, + cards = cards, variables = .get_variables_by_type(type, type = "dichotomous"), - calling_function = calling_function + statistic = statistic ), - pier_summary_missing_row(x, variables = include, calling_function = calling_function) + pier_summary_missing_row( + cards = cards, + variables = variables, + missing = missing, + missing_stat = missing_stat, + missing_text = missing_text + ) ), by = "variable" ) @@ -139,49 +187,50 @@ brdg_summary <- function(x, x <- construct_initial_table_styling(x) # add info to x$table_styling$header for dynamic headers --------------------- - x <- .add_table_styling_stats(x, by = by, calling_function = calling_function) + x <- .add_table_styling_stats(x, cards = cards, by = by) - x + x |> + structure(class = "gtsummary") |> + modify_column_unhide(columns = all_stat_cols()) } #' @rdname bridge_summary #' @export -pier_summary_dichotomous <- function(x, variables, value = x$inputs$value, - calling_function = "tbl_summary") { +pier_summary_dichotomous <- function(cards, + variables, + statistic) { set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } - # updating the context to continuous, because it will be processed that way below - x[["cards"]][[calling_function]] <- - x[["cards"]][[calling_function]] |> - dplyr::mutate( - context = ifelse(.data$context %in% "dichotomous", "continuous", .data$context) - ) - - pier_summary_continuous(x = x, variables = variables) + pier_summary_continuous( + cards = cards, + variables = variables, + statistic = statistic + ) } #' @rdname bridge_summary #' @export -pier_summary_categorical <- function(x, variables, - missing, missing_text, missing_stat, - calling_function = "tbl_summary") { +pier_summary_categorical <- function(cards, + variables, + statistic) { set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } # subsetting cards object on categorical summaries ---------------------------- - card <- - x[["cards"]][[calling_function]] |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("categorical", "missing")) |> + cards_no_attr <- + cards |> + dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |> cards::apply_fmt_fn() + # construct formatted statistics --------------------------------------------- df_glued <- # construct stat columns with glue by grouping variables and primary summary variable - card |> + cards_no_attr |> dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(df_variable_stats, df_groups_and_variable) { @@ -193,7 +242,7 @@ pier_summary_categorical <- function(x, variables, ) str_statistic_pre_glue <- - x$inputs$statistic[[df_groups_and_variable$variable[1]]] + statistic[[df_groups_and_variable$variable[1]]] dplyr::mutate( .data = df_groups_and_variable, @@ -234,7 +283,7 @@ pier_summary_categorical <- function(x, variables, df_glued |> # merge in variable label dplyr::left_join( - x[["cards"]][[calling_function]] |> + cards |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -282,22 +331,23 @@ pier_summary_categorical <- function(x, variables, #' @rdname bridge_summary #' @export -pier_summary_continuous2 <- function(x, variables, missing, missing_text, missing_stat, - calling_function = "tbl_summary") { +pier_summary_continuous2 <- function(cards, + variables, + statistic) { set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } # subsetting cards object on continuous2 summaries ---------------------------- - card <- - x[["cards"]][[calling_function]] |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> + cards_no_attr <- + cards |> + dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |> cards::apply_fmt_fn() # construct formatted statistics --------------------------------------------- df_glued <- # construct stat columns with glue by grouping variables and primary summary variable - card |> + cards_no_attr |> dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(.x, .y) { @@ -305,7 +355,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin .data = .y, stat = map( - x$inputs$statistic[[.y$variable[1]]], + statistic[[.y$variable[1]]], function(str_to_glue) { stat <- glue::glue( @@ -318,7 +368,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin list(), label = map( - x$inputs$statistic[[.y$variable[1]]], + statistic[[.y$variable[1]]], function(str_to_glue) { label <- glue::glue( @@ -339,7 +389,7 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin df_glued |> # merge in variable label dplyr::left_join( - x[["cards"]][[calling_function]] |> + cards |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -387,25 +437,23 @@ pier_summary_continuous2 <- function(x, variables, missing, missing_text, missin #' @rdname bridge_summary #' @export -pier_summary_continuous <- function(x, +pier_summary_continuous <- function(cards, variables, - statistic = x$inputs$statistic, - missing, missing_text, missing_stat, - calling_function = "tbl_summary") { + statistic) { set_cli_abort_call() if (is_empty(variables)) { return(dplyr::tibble()) } - # subsetting cards object on continuous summaries ---------------------------- - card <- - x[["cards"]][[calling_function]] |> - dplyr::filter(.data$variable %in% .env$variables, .data$context %in% c("continuous", "missing")) |> + # subsetting cards object on statistical summaries --------------------------- + cards_no_attr <- + cards |> + dplyr::filter(.data$variable %in% .env$variables, !.data$context %in% "attributes") |> cards::apply_fmt_fn() # construct formatted statistics --------------------------------------------- df_glued <- # construct stat columns with glue by grouping variables and primary summary variable - card |> + cards_no_attr |> dplyr::group_by(across(c("gts_column", cards::all_ard_groups(), "variable"))) |> dplyr::group_map( function(.x, .y) { @@ -427,7 +475,7 @@ pier_summary_continuous <- function(x, df_glued |> # merge in variable label dplyr::left_join( - x[["cards"]][[calling_function]] |> + cards |> dplyr::filter( .data$variable %in% .env$variables, .data$context %in% "attributes", @@ -454,37 +502,38 @@ pier_summary_continuous <- function(x, #' @rdname bridge_summary #' @export -pier_summary_missing_row <- function(x, - variables = x$inputs$include, - missing_stat = x$inputs$missing_stat, - missing_text = x$inputs$missing_text, - calling_function = "tbl_summary") { +pier_summary_missing_row <- function(cards, + variables, + missing = "no", + missing_stat = "{N_miss}", + missing_text = "Unknown") { set_cli_abort_call() - if (is_empty(variables)) { - return(dplyr::tibble()) - } - # keeping variables to report missing obs for (or returning empty df if none) - if (x$inputs$missing == "no") { + + # return empty tibble if no missing row requested + if (is_empty(variables) || missing == "no") { return(dplyr::tibble()) } - if (x$inputs$missing == "ifany") { + + # if "ifany", replace the variables vector with those that have missing values + if (missing == "ifany") { variables <- - x[["cards"]][[calling_function]] |> + cards |> dplyr::filter(.data$stat_name == "N_miss", .data$variable %in% .env$variables) |> dplyr::filter(.data$stat > 0L) |> dplyr::pull("variable") |> unique() } - if (is_empty(variables)) { - return(dplyr::tibble()) - } # slightly modifying the `x` object for missing value calculations ----------- # make all the summary stats the same for all vars statistic <- rep_named(variables, list(missing_stat)) - - pier_summary_continuous(x, variables = variables, statistic = statistic) |> + # reshape the missing stats + pier_summary_continuous( + cards = cards, + variables = variables, + statistic = statistic + ) |> # update the row_type and label dplyr::mutate( row_type = "missing", @@ -492,13 +541,13 @@ pier_summary_missing_row <- function(x, ) } -.add_table_styling_stats <- function(x, by = x$inputs$by, calling_function = "tbl_summary") { +.add_table_styling_stats <- function(x, cards, by) { if (is_empty(by)) { x$table_styling$header <- x$table_styling$header |> dplyr::mutate( modify_stat_N = - x[["cards"]][[calling_function]] |> + cards |> dplyr::filter(.data$stat_name %in% "N_obs") |> dplyr::pull("stat") |> unlist() |> @@ -508,7 +557,7 @@ pier_summary_missing_row <- function(x, modify_stat_level = "Overall" ) } else { - df_by_stats <- x[["cards"]][[calling_function]] |> + df_by_stats <- cards |> dplyr::filter(.data$variable %in% .env$by & .data$stat_name %in% c("N", "n", "p")) # get a data frame with the by variable stats diff --git a/R/card_summary.R b/R/card_summary.R index 6052407f38..06f00c1ead 100644 --- a/R/card_summary.R +++ b/R/card_summary.R @@ -188,25 +188,8 @@ card_summary <- function(cards, predicate = \(x) is.character(x), error_msg = "The {.arg statistic} argument values must be class {.cls character} vector." ) - walk( - include, - \(variable) { - stat_names <- .extract_glue_elements(statistic[[variable]]) - stat_names_not_in_cards <- - stat_names |> - discard(~ .x %in% dplyr::filter(cards, .data$variable %in% .env$variable)$stat_name) - if (!is_empty(stat_names_not_in_cards)) { - cli::cli_abort( - c("The {.val {stat_names_not_in_cards}} statistics for variable {.val {variable}} - are not present in the {.arg cards} ARD object.", - i = "Choose among the following statistics - {.val {dplyr::filter(cards, .data$variable %in% .env$variable, !.data$context %in% 'attributes')$stat_name |> unique()}}." - ), - call = get_cli_abort_call() - ) - } - } - ) + .check_stats_available(cards, statistic) + walk( include, \(variable) { @@ -226,16 +209,22 @@ card_summary <- function(cards, # construct initial card_summary object -------------------------------------- x <- - list( - cards = list(card_summary = cards), - inputs = card_summary_inputs, - call_list = list(card_summary = call) - ) |> brdg_summary( - calling_function = "card_summary", + cards = cards, by = by, - include = include, - type = type + variables = include, + statistic = statistic, + type = type, + missing = missing, + missing_stat = missing_stat, + missing_text = missing_text + ) |> + append( + list( + cards = list(card_summary = cards), + inputs = card_summary_inputs, + call_list = list(card_summary = call) + ) ) |> structure(class = c("card_summary", "gtsummary")) diff --git a/R/tbl_summary.R b/R/tbl_summary.R index a0b06a7c44..0302b41144 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -341,15 +341,28 @@ tbl_summary <- function(data, # print all warnings and errors that occurred while calculating requested stats cards::print_ard_conditions(cards) + # check the requested stats are present in ARD data frame + .check_stats_available(cards = cards, statistic = statistic) + # construct initial tbl_summary object --------------------------------------- x <- - list( - cards = list(tbl_summary = cards), - inputs = tbl_summary_inputs, - call_list = list(tbl_summary = call) + brdg_summary( + cards = cards, + by = by, + variables = include, + statistic = statistic, + type = type, + missing = missing, + missing_stat = missing_stat, + missing_text = missing_text + ) |> + append( + list( + cards = list(tbl_summary = cards), + inputs = tbl_summary_inputs, + call_list = list(tbl_summary = call) + ) ) |> - .check_stats_available() |> - brdg_summary() |> structure(class = c("tbl_summary", "gtsummary")) # adding styling ------------------------------------------------------------- @@ -386,14 +399,14 @@ tbl_summary <- function(data, data[!obs_to_drop, ] } -.check_stats_available <- function(x) { +.check_stats_available <- function(cards, statistic) { # TODO: this could be made more accurate by grouping the cards data frame by the group##_level columns - x$inputs$statistic |> + statistic |> imap( function(pre_glue_stat, variable) { extracted_stats <- .extract_glue_elements(pre_glue_stat) available_stats <- - x$cards$tbl_summary |> + cards |> dplyr::filter(.data$variable %in% .env$variable, !.data$context %in% "attributes") |> dplyr::pull("stat_name") @@ -408,9 +421,6 @@ tbl_summary <- function(data, } } ) - - - x } .add_env_to_list_elements <- function(x, env) { diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 906c11a43c..2c3e7ca873 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -11,80 +11,47 @@ \title{Summary Table Bridges} \usage{ brdg_summary( - x, - calling_function = "tbl_summary", - by = x$inputs$by, - include = x$inputs$include, - type = x$inputs$type -) - -pier_summary_dichotomous( - x, + cards, variables, - value = x$inputs$value, - calling_function = "tbl_summary" + type, + statistic, + by = NULL, + missing = "no", + missing_stat = "{N_miss}", + missing_text = "Unknown" ) -pier_summary_categorical( - x, - variables, - missing, - missing_text, - missing_stat, - calling_function = "tbl_summary" -) +pier_summary_dichotomous(cards, variables, statistic) -pier_summary_continuous2( - x, - variables, - missing, - missing_text, - missing_stat, - calling_function = "tbl_summary" -) +pier_summary_categorical(cards, variables, statistic) -pier_summary_continuous( - x, - variables, - statistic = x$inputs$statistic, - missing, - missing_text, - missing_stat, - calling_function = "tbl_summary" -) +pier_summary_continuous2(cards, variables, statistic) + +pier_summary_continuous(cards, variables, statistic) pier_summary_missing_row( - x, - variables = x$inputs$include, - missing_stat = x$inputs$missing_stat, - missing_text = x$inputs$missing_text, - calling_function = "tbl_summary" + cards, + variables, + missing = "no", + missing_stat = "{N_miss}", + missing_text = "Unknown" ) } \arguments{ -\item{x}{gtsummary object of class \code{"tbl_summary"}} - -\item{calling_function}{string indicating the name of the function that is -calling thie bridge function, e.g. \code{call_function = "tbl_summary"}. This is used -internally to organize results.} - -\item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr -A single column from \code{data}. Summary statistics will be stratified by this variable. -Default is \code{NULL}} +\item{cards}{(\code{card})\cr +An ARD object of class \code{"card"} typically created with \verb{cards::ard_*()} functions.} -\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr -Variables to include in the summary table. Default is \code{everything()}} +\item{variables}{(\code{character})\cr +character list of variables} -\item{type}{(\code{\link[=syntax]{formula-list-selector}})\cr -Specifies the summary type. Accepted value are -\code{c("continuous", "continuous2", "categorical", "dichotomous")}. -If not specified, default type is assigned via -\code{assign_summary_type()}. See below for details.} +\item{type}{(named \code{list})\cr +named list of summary types} -\item{variables}{character list of variables} +\item{statistic}{(named \code{list})\cr +named list of summary statistic names} -\item{value}{named list of values to be summarized. the names are the -variable names.} +\item{by}{(\code{string})\cr +string indicating the stratifying column} \item{missing, missing_text, missing_stat}{Arguments dictating how and if missing values are presented: \itemize{ @@ -93,11 +60,6 @@ variable names.} \item \code{missing_stat}: statistic to show on missing row. Default is \code{"{N_miss}"}. Possible values are \code{N_miss}, \code{N_obs}, \code{N_nonmiss}, \code{p_miss}, \code{p_nonmiss} }} - -\item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr -Specifies summary statistics to display for each variable. The default is -\code{list(all_continuous() ~ "{median} ({p25}, {p75})", all_categorical() ~ "{n} ({p}\%)")}. -See below for details.} } \value{ data frame @@ -108,46 +70,80 @@ All bridge functions begin with prefix \verb{brdg_*()}. This file also contains helper functions for constructing the bridge, referred to as the piers (supports for a bridge) and begin with \verb{pier_*()}. +\itemize{ +\item \code{brdg_summary()}: The bridge function ingests an ARD data frame and returns +a gtsummary table that includes \code{.$table_body} and a basic \code{.$table_styling}. +The \code{.$table_styling$header} data frame includes the header statistics. +Based on context, this function adds a column to the ARD data frame named +\code{"gts_column"}. This column is used during the reshaping in the \verb{pier_*()} +functions defining column names. +\item \verb{pier_*()}: these functions accept a cards tibble and returns a tibble +that is a piece of the \code{.$table_body}. Typically these will be stacked +to construct the final table body data frame. The ARD object passed here +will have two primary parts: the calculated summary statistics and the +attributes ARD. The attributes ARD is used for labeling. The ARD data frame +passed to this function must include a \code{"gts_column"} column, which is +added in \code{brdg_summary()}. +} } \examples{ -tbl <- - tbl_summary( - data = mtcars, - include = c("cyl", "am", "mpg", "hp"), - type = - list( - cyl = "categorical", - am = "dichotomous", - mpg = "continuous", - hp = "continuous2" - ), - value = list(am = 1), - statistic = - list( - c(cyl, am) ~ "{n} ({p}\%)", - mpg = "{mean} ({sd})", - hp = c("{mean}", "{median}") - ) - ) +library(cards) + +# first build ARD data frame +cards <- + ard_stack( + mtcars, + by = NULL, + ard_continuous(variables = c("mpg", "hp")), + ard_categorical(variables = "cyl"), + ard_dichotomous(variables = "am"), + .missing = TRUE, + .attributes = TRUE + ) |> + # this column is used by the `pier_*()` functions + dplyr::mutate(gts_column = ifelse(context == "attributes", NA, "stat_0")) + +brdg_summary( + cards = cards, + variables = c("cyl", "am", "mpg", "hp"), + type = + list( + cyl = "categorical", + am = "dichotomous", + mpg = "continuous", + hp = "continuous2" + ), + statistic = + list( + cyl = "{n} / {N}", + am = "{n} / {N}", + mpg = "{mean} ({sd})", + hp = c("{median} ({p25}, {p75})", "{mean} ({sd})") + ) +) |> + as_tibble() pier_summary_dichotomous( - x = tbl, + cards = cards, variables = "am", - value = list(am = 1) + statistic = list(am = "{n} ({p})") ) pier_summary_categorical( - x = tbl, - variables = "cyl" + cards = cards, + variables = "cyl", + statistic = list(cyl = "{n} ({p})") ) pier_summary_continuous2( - x = tbl, - variables = "hp" + cards = cards, + variables = "hp", + statistic = list(hp = c("{median}", "{mean}")) ) pier_summary_continuous( - x = tbl, - variables = "mpg" + cards = cards, + variables = "mpg", + statistic = list(mpg = "{median}") ) } diff --git a/tests/testthat/_snaps/add_p.tbl_summary.new.md b/tests/testthat/_snaps/add_p.tbl_summary.new.md new file mode 100644 index 0000000000..f2fa93279e --- /dev/null +++ b/tests/testthat/_snaps/add_p.tbl_summary.new.md @@ -0,0 +1,34 @@ +# add_p.tbl_summary() error messaging with bad inputs + + Code + add_p(tbl_summary(trial[c("trt", "age")])) + Condition + Error in `add_p()`: + ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. + +--- + + Code + add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( + ...) mtcars)) + Condition + Error in `add_p()`: + ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. + +--- + + Code + add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( + ...) letters)) + Condition + Error in `add_p()`: + ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. + +# add_p.tbl_summary() can be run after add_difference() + + Code + add_p(add_p(tbl_summary(select(trial, age, trt), by = trt))) + Condition + Error in `add_p()`: + ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. + diff --git a/tests/testthat/_snaps/card_summary.md b/tests/testthat/_snaps/card_summary.md index 1a2b6bda9f..8e6fc6a9cf 100644 --- a/tests/testthat/_snaps/card_summary.md +++ b/tests/testthat/_snaps/card_summary.md @@ -105,8 +105,8 @@ .attributes = TRUE, .missing = TRUE), statistic = list(AGE = "{not_a_valid_summary_statistic}")) Condition Error in `card_summary()`: - ! The "not_a_valid_summary_statistic" statistics for variable "AGE" are not present in the `cards` ARD object. - i Choose among the following statistics "N", "mean", "sd", "median", "p25", "p75", "min", "max", "N_obs", "N_miss", "N_nonmiss", "p_miss", and "p_nonmiss". + ! Statistic "not_a_valid_summary_statistic" is not available for variable "AGE". + i Select among "p_nonmiss", "p_miss", "N_nonmiss", "N_miss", "N_obs", "max", "min", "p75", "p25", "median", "sd", "mean", and "N". --- From f10c4782036bd44f63b3c75c95c2d565539959ad Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 15 May 2024 11:24:40 -0700 Subject: [PATCH 54/74] v2.0 Adding `add_n.tbl summary()` (#1645) * adding add_n.tbl_summary() * Update add_n.R * Update add_n.R * lil updates * progress --- NAMESPACE | 2 + R/add_n.R | 200 ++++++++++++++++++ R/bridge_summary.R | 1 - R/card_summary.R | 3 +- R/modify_table_body.R | 40 ++-- R/tbl_summary.R | 1 + _archive/R/add_n.R | 1 - man/add_n.Rd | 26 +++ man/add_n.tbl_summary.Rd | 63 ++++++ man/bridge_summary.Rd | 1 - man/card_summary.Rd | 3 +- man/modify_table_body.Rd | 20 ++ tests/testthat/_snaps/add_n.tbl_summary.md | 36 ++++ .../testthat/_snaps/add_p.tbl_summary.new.md | 34 --- tests/testthat/_snaps/card_summary.md | 19 +- tests/testthat/test-add_n.tbl_summary.R | 48 +++++ tests/testthat/test-card_summary.R | 16 +- 17 files changed, 434 insertions(+), 80 deletions(-) create mode 100644 R/add_n.R create mode 100644 man/add_n.Rd create mode 100644 man/add_n.tbl_summary.Rd create mode 100644 tests/testthat/_snaps/add_n.tbl_summary.md delete mode 100644 tests/testthat/_snaps/add_p.tbl_summary.new.md create mode 100644 tests/testthat/test-add_n.tbl_summary.R diff --git a/NAMESPACE b/NAMESPACE index 9ef0007797..288539aa9f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method(add_difference,tbl_summary) +S3method(add_n,tbl_summary) S3method(add_p,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) @@ -9,6 +10,7 @@ S3method(print,gtsummary) export("%>%") export(.table_styling_expr_to_row_number) export(add_difference) +export(add_n) export(add_p) export(all_categorical) export(all_continuous) diff --git a/R/add_n.R b/R/add_n.R new file mode 100644 index 0000000000..4ba298d89e --- /dev/null +++ b/R/add_n.R @@ -0,0 +1,200 @@ +#' Add column with N +#' +#' - [`add_n.tbl_summary()`] +#' +#' @param x (`gtsummary`)\cr +#' Object with class 'gtsummary' +#' @param ... Passed to other methods. +#' @keywords internal +#' @author Daniel D. Sjoberg +#' @export +#' +#' @seealso [`add_n.tbl_summary()`] +add_n <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_n") +} + + +#' Add column with N +#' +#' For each variable in a `tbl_summary` table, the `add_n` function adds a column with the +#' total number of non-missing (or missing) observations +#' +#' @param x (`tbl_summary`)\cr +#' Object with class `'tbl_summary'` created with [`tbl_summary()`] function. +#' @param statistic (`string`)\cr +#' String indicating the statistic to report. Default is the +#' number of non-missing observation for each variable, `statistic = "{N_nonmiss}"`. +#' All statistics available to report include: +#' +#' * `"{N_obs}"` total number of observations, +#' * `"{N_nonmiss}"` number of non-missing observations, +#' * `"{N_miss}"` number of missing observations, +#' * `"{p_nonmiss}"` percent non-missing data, +#' * `"{p_miss}"` percent missing data +#' +#' The argument uses [`glue::glue()`] syntax and multiple statistics may be reported, +#' e.g. `statistic = "{N_nonmiss} / {N_obs} ({p_nonmiss}%)"` +#' @param col_label (`string`)\cr +#' String indicating the column label. Default is `"**N**"` +#' @param footnote (scalar `logical`)\cr +#' Logical argument indicating whether to print a footnote +#' clarifying the statistics presented. Default is `FALSE` +#' @param last (scalar `logical`)\cr +#' Logical indicator to include N column last in table. +#' Default is `FALSE`, which will display N column first. +#' @inheritParams rlang::args_dots_empty +#' +#' @author Daniel D. Sjoberg +#' @export +#' +#' @return A table of class `c('tbl_summary', 'gtsummary')` +#' @examples +#' # Example 1 ---------------------------------- +#' trial |> +#' tbl_summary(by = trt, include = c(trt, age, grade, response)) |> +#' add_n() +add_n.tbl_summary <- function(x, statistic = "{N_nonmiss}", col_label = "**N**", footnote = FALSE, + last = FALSE, ...) { + set_cli_abort_call() + updated_call_list <- c(x[["call_list"]], list(add_n = match.call())) + + # check inputs --------------------------------------------------------------- + check_string(statistic) + check_string(col_label) + check_scalar_logical(footnote) + check_scalar_logical(last) + + # calculate/grab the needed ARD results -------------------------------------- + if ("add_overall" %in% names(x[["call_list"]])) { + # TODO: If `add_overall()` was previously run, we can get the stats from there instead of re-calculating + } + else if (is_empty(x$inputs$by)) { + # TODO: If `tbl_summary(by)` is empty, then we can grab this from `x$card%tbl_summary` + x$cards$add_n <- + x[["cards"]][[1]] |> + dplyr::filter( + .data$variable %in% .env$x$inputs$include, + .data$context %in% "missing" + ) |> + cards::apply_fmt_fn() + } + else { + x$cards$add_n <- + cards::ard_missing( + data = x$inputs$data, + variables = x$inputs$include, + by = character(0L), + # TODO: Utilize themes to change the default formatting types + fmt_fn = ~ list( + starts_with("N_") ~ styfn_number(), + starts_with("p_") ~ styfn_percent() + ) + ) |> + cards::apply_fmt_fn() + } + + + # check statistic argument --------------------------------------------------- + if (is_empty(.extract_glue_elements(statistic))) { + cli::cli_abort( + c("No glue elements found in the {.arg statistic} argument ({.val {statistic}}).", + i = "Do you need to wrap the statistic name in curly brackets, e.g. {.val {{N_nonmiss}}}?" + ), + call = get_cli_abort_call() + ) + } + if (any(!.extract_glue_elements(statistic) %in% x$cards$add_n$stat_name)) { + missing_stats <- .extract_glue_elements(statistic) |> setdiff(x$cards$add_n$stat_name) + cli::cli_abort( + c("The following statistics are not valid for the {.arg statistic} argument: {.val {missing_stats}}.", + i = "Select from {.val {unique(x$cards$add_n$stat_name)}}." + ), + call = get_cli_abort_call() + ) + } + + # prepare ARD data frame ----------------------------------------------------- + cards <- + dplyr::bind_rows( + x$cards$add_n, + x[["cards"]][[1]] |> + dplyr::filter( + .data$variable %in% .env$x$inputs$include, + .data$context %in% "attributes" + ) + ) |> + dplyr::mutate( + gts_column = ifelse(.data$context %in% "missing", "n", NA_character_) + ) %>% + # adding `'{n}'` to ARD data frame + # Prior to v2.0 release, the default value was `statistic="{n}"` + # Documentation of {n} was removed in v2.0, so we can remove this chunk at some + # point in the future. (May 2024) + dplyr::bind_rows( + dplyr::filter( + ., + .data$context %in% "missing", + .data$stat_name %in% c("N_obs", "N_miss", "N_nonmiss", "p_nonmiss"), + ) |> + dplyr::mutate( + stat_name = + dplyr::case_when( + .data$stat_name %in% "N_nonmiss" ~ "n", + # documentation for the stats below were removed on 2022-04-03 + .data$stat_name %in% "N_obs" ~ "N", + .data$stat_name %in% "N_miss" ~ "n_miss", + .data$stat_name %in% "p_nonmiss" ~ "p" + ) + ) + ) + + # create tibble to merge with primary table ---------------------------------- + df_results <- + pier_summary_dichotomous( + cards = cards, + variables = x$inputs$include, + statistic = rep_named(x$inputs$include, x = list(statistic)) + ) |> + dplyr::select("variable", "row_type", "n") + + # add results to primary table ----------------------------------------------- + x <- x |> + modify_table_body( + \(table_body) { + table_body <- + dplyr::left_join( + table_body, + df_results, + by = c("variable", "row_type") + ) + + if (isFALSE(last)) { + table_body <- dplyr::relocate(table_body, "n", .after = "label") + } + table_body + } + ) |> + modify_header(n = col_label) + + # add footnote if requested by user ------------------------------------------ + if (footnote) { + footnote_text <- + eval_tidy( + expr = expr(glue(statistic)), + data = + x$cards$add_n |> + dplyr::slice(.by = "stat_name", 1L) |> + cards::get_ard_statistics(.column = "stat_label") + ) + + x <- modify_table_styling(x, columns = "n", footnote = footnote_text) + } + + # return final table --------------------------------------------------------- + # add updated call + x$call_list <- updated_call_list + x +} diff --git a/R/bridge_summary.R b/R/bridge_summary.R index e7a9dc3dff..ed5d76ab03 100644 --- a/R/bridge_summary.R +++ b/R/bridge_summary.R @@ -44,7 +44,6 @@ #' cards <- #' ard_stack( #' mtcars, -#' by = NULL, #' ard_continuous(variables = c("mpg", "hp")), #' ard_categorical(variables = "cyl"), #' ard_dichotomous(variables = "am"), diff --git a/R/card_summary.R b/R/card_summary.R index 06f00c1ead..81408a1e68 100644 --- a/R/card_summary.R +++ b/R/card_summary.R @@ -34,7 +34,6 @@ #' #' ard_stack( #' data = ADSL, -#' by = NULL, #' ard_categorical(variables = "AGEGR1"), #' ard_continuous(variables = "AGE"), #' .attributes = TRUE, @@ -44,7 +43,7 @@ #' #' ard_stack( #' data = ADSL, -#' by = ARM, +#' .by = ARM, #' ard_categorical(variables = "AGEGR1"), #' ard_continuous(variables = "AGE"), #' .attributes = TRUE, diff --git a/R/modify_table_body.R b/R/modify_table_body.R index 3a42a47ba7..dad5a3fcfb 100644 --- a/R/modify_table_body.R +++ b/R/modify_table_body.R @@ -19,26 +19,26 @@ #' #' @examples #' # Example 1 -------------------------------- -# #' # Add number of cases and controls to regression table -# #' modify_table_body_ex1 <- -# #' trial %>% -# #' select(response, age, marker) %>% -# #' tbl_uvregression( -# #' y = response, -# #' method = glm, -# #' method.args = list(family = binomial), -# #' exponentiate = TRUE, -# #' hide_n = TRUE -# #' ) %>% -# #' # adding number of non-events to table -# #' modify_table_body( -# #' ~ .x %>% -# #' dplyr::mutate(N_nonevent = N_obs - N_event) %>% -# #' dplyr::relocate(c(N_event, N_nonevent), .before = estimate) -# #' ) %>% -# #' # assigning header labels -# #' modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") %>% -# #' modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) +#' # # Add number of cases and controls to regression table +#' # modify_table_body_ex1 <- +#' # trial %>% +#' # select(response, age, marker) %>% +#' # tbl_uvregression( +#' # y = response, +#' # method = glm, +#' # method.args = list(family = binomial), +#' # exponentiate = TRUE, +#' # hide_n = TRUE +#' # ) %>% +#' # # adding number of non-events to table +#' # modify_table_body( +#' # ~ .x %>% +#' # dplyr::mutate(N_nonevent = N_obs - N_event) %>% +#' # dplyr::relocate(c(N_event, N_nonevent), .before = estimate) +#' # ) %>% +#' # # assigning header labels +#' # modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") %>% +#' # modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) #' @export #' @family Advanced modifiers modify_table_body <- function(x, fun, ...) { diff --git a/R/tbl_summary.R b/R/tbl_summary.R index 0302b41144..bcf66c863f 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -288,6 +288,7 @@ tbl_summary <- function(data, # construct cards ------------------------------------------------------------ + # TODO: Utilize themes to change the default formatting types cards <- cards::bind_ard( cards::ard_attributes(data, variables = all_of(c(include, by)), label = label), diff --git a/_archive/R/add_n.R b/_archive/R/add_n.R index 4dc4034fd4..d589866846 100644 --- a/_archive/R/add_n.R +++ b/_archive/R/add_n.R @@ -59,7 +59,6 @@ add_n <- function(x, ...) { #' \if{html}{\out{ #' `r man_create_image_tag(file = "tbl_n_ex.png", width = "50")` #' }} - add_n.tbl_summary <- function(x, statistic = "{n}", col_label = "**N**", footnote = FALSE, last = FALSE, ...) { check_dots_empty(error = function(e) inform(c(e$message, e$body))) diff --git a/man/add_n.Rd b/man/add_n.Rd new file mode 100644 index 0000000000..ec5ffe4b24 --- /dev/null +++ b/man/add_n.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_n.R +\name{add_n} +\alias{add_n} +\title{Add column with N} +\usage{ +add_n(x, ...) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +Object with class 'gtsummary'} + +\item{...}{Passed to other methods.} +} +\description{ +\itemize{ +\item \code{\link[=add_n.tbl_summary]{add_n.tbl_summary()}} +} +} +\seealso{ +\code{\link[=add_n.tbl_summary]{add_n.tbl_summary()}} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/add_n.tbl_summary.Rd b/man/add_n.tbl_summary.Rd new file mode 100644 index 0000000000..1965224088 --- /dev/null +++ b/man/add_n.tbl_summary.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_n.R +\name{add_n.tbl_summary} +\alias{add_n.tbl_summary} +\title{Add column with N} +\usage{ +\method{add_n}{tbl_summary}( + x, + statistic = "{N_nonmiss}", + col_label = "**N**", + footnote = FALSE, + last = FALSE, + ... +) +} +\arguments{ +\item{x}{(\code{tbl_summary})\cr +Object with class \code{'tbl_summary'} created with \code{\link[=tbl_summary]{tbl_summary()}} function.} + +\item{statistic}{(\code{string})\cr +String indicating the statistic to report. Default is the +number of non-missing observation for each variable, \code{statistic = "{N_nonmiss}"}. +All statistics available to report include: +\itemize{ +\item \code{"{N_obs}"} total number of observations, +\item \code{"{N_nonmiss}"} number of non-missing observations, +\item \code{"{N_miss}"} number of missing observations, +\item \code{"{p_nonmiss}"} percent non-missing data, +\item \code{"{p_miss}"} percent missing data +} + +The argument uses \code{\link[glue:glue]{glue::glue()}} syntax and multiple statistics may be reported, +e.g. \code{statistic = "{N_nonmiss} / {N_obs} ({p_nonmiss}\%)"}} + +\item{col_label}{(\code{string})\cr +String indicating the column label. Default is \code{"**N**"}} + +\item{footnote}{(scalar \code{logical})\cr +Logical argument indicating whether to print a footnote +clarifying the statistics presented. Default is \code{FALSE}} + +\item{last}{(scalar \code{logical})\cr +Logical indicator to include N column last in table. +Default is \code{FALSE}, which will display N column first.} + +\item{...}{These dots are for future extensions and must be empty.} +} +\value{ +A table of class \code{c('tbl_summary', 'gtsummary')} +} +\description{ +For each variable in a \code{tbl_summary} table, the \code{add_n} function adds a column with the +total number of non-missing (or missing) observations +} +\examples{ +# Example 1 ---------------------------------- +trial |> + tbl_summary(by = trt, include = c(trt, age, grade, response)) |> + add_n() +} +\author{ +Daniel D. Sjoberg +} diff --git a/man/bridge_summary.Rd b/man/bridge_summary.Rd index 2c3e7ca873..9a1d0d6b0c 100644 --- a/man/bridge_summary.Rd +++ b/man/bridge_summary.Rd @@ -93,7 +93,6 @@ library(cards) cards <- ard_stack( mtcars, - by = NULL, ard_continuous(variables = c("mpg", "hp")), ard_categorical(variables = "cyl"), ard_dichotomous(variables = "am"), diff --git a/man/card_summary.Rd b/man/card_summary.Rd index a45383f5bb..395cbf5ca2 100644 --- a/man/card_summary.Rd +++ b/man/card_summary.Rd @@ -56,7 +56,6 @@ library(cards) ard_stack( data = ADSL, - by = NULL, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, @@ -66,7 +65,7 @@ ard_stack( ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, diff --git a/man/modify_table_body.Rd b/man/modify_table_body.Rd index 474e38bfa9..816f3f5ba2 100644 --- a/man/modify_table_body.Rd +++ b/man/modify_table_body.Rd @@ -26,6 +26,26 @@ To show a column, add a column header with \code{modify_header()}. } \examples{ # Example 1 -------------------------------- +# # Add number of cases and controls to regression table +# modify_table_body_ex1 <- +# trial \%>\% +# select(response, age, marker) \%>\% +# tbl_uvregression( +# y = response, +# method = glm, +# method.args = list(family = binomial), +# exponentiate = TRUE, +# hide_n = TRUE +# ) \%>\% +# # adding number of non-events to table +# modify_table_body( +# ~ .x \%>\% +# dplyr::mutate(N_nonevent = N_obs - N_event) \%>\% +# dplyr::relocate(c(N_event, N_nonevent), .before = estimate) +# ) \%>\% +# # assigning header labels +# modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") \%>\% +# modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) } \seealso{ Other Advanced modifiers: diff --git a/tests/testthat/_snaps/add_n.tbl_summary.md b/tests/testthat/_snaps/add_n.tbl_summary.md new file mode 100644 index 0000000000..04bbdaa885 --- /dev/null +++ b/tests/testthat/_snaps/add_n.tbl_summary.md @@ -0,0 +1,36 @@ +# add_n.tbl_summary() works + + Code + as.data.frame(add_n(tbl_summary(trial, include = c(age, grade, response)), + statistic = "{N_nonmiss} / {N_obs}", footnote = TRUE, last = TRUE)) + Output + **Characteristic** **N = 200** **N** + 1 Age 47 (38, 57) 189 / 200 + 2 Unknown 11 + 3 Grade 200 / 200 + 4 I 68 (34%) + 5 II 68 (34%) + 6 III 64 (32%) + 7 Tumor Response 61 (32%) 193 / 200 + 8 Unknown 7 + +# add_n.tbl_summary(statistic) error messaging + + Code + add_n(tbl_summary(trial, by = trt, include = c(trt, age, grade, response)), + statistic = "no_curlies") + Condition + Error in `add_n()`: + ! No glue elements found in the `statistic` argument ("no_curlies"). + i Do you need to wrap the statistic name in curly brackets, e.g. "{N_nonmiss}"? + +--- + + Code + add_n(tbl_summary(trial, by = trt, include = c(trt, age, grade, response)), + statistic = "{not_a_stat}") + Condition + Error in `add_n()`: + ! The following statistics are not valid for the `statistic` argument: "not_a_stat". + i Select from "N_obs", "N_miss", "N_nonmiss", "p_miss", and "p_nonmiss". + diff --git a/tests/testthat/_snaps/add_p.tbl_summary.new.md b/tests/testthat/_snaps/add_p.tbl_summary.new.md deleted file mode 100644 index f2fa93279e..0000000000 --- a/tests/testthat/_snaps/add_p.tbl_summary.new.md +++ /dev/null @@ -1,34 +0,0 @@ -# add_p.tbl_summary() error messaging with bad inputs - - Code - add_p(tbl_summary(trial[c("trt", "age")])) - Condition - Error in `add_p()`: - ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. - ---- - - Code - add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( - ...) mtcars)) - Condition - Error in `add_p()`: - ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. - ---- - - Code - add_p(tbl_summary(trial[c("trt", "age")], by = trt), test = list(age = function( - ...) letters)) - Condition - Error in `add_p()`: - ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. - -# add_p.tbl_summary() can be run after add_difference() - - Code - add_p(add_p(tbl_summary(select(trial, age, trt), by = trt))) - Condition - Error in `add_p()`: - ! Cannot run `add_p()` when `tbl_summary(by)` argument not included. - diff --git a/tests/testthat/_snaps/card_summary.md b/tests/testthat/_snaps/card_summary.md index 8e6fc6a9cf..5942df36c9 100644 --- a/tests/testthat/_snaps/card_summary.md +++ b/tests/testthat/_snaps/card_summary.md @@ -1,7 +1,7 @@ # card_summary() works Code - as.data.frame(card_summary(ard_stack(data = ADSL, by = ARM, ard_categorical( + as.data.frame(card_summary(ard_stack(data = ADSL, .by = ARM, ard_categorical( variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE))) Output @@ -21,9 +21,8 @@ --- Code - as.data.frame(card_summary(ard_stack(data = ADSL, by = NULL, ard_categorical( - variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, - .missing = TRUE))) + as.data.frame(card_summary(ard_stack(data = ADSL, ard_categorical(variables = "AGEGR1"), + ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE))) Output **Characteristic** **N = 254** 1 Pooled Age Group 1 @@ -63,7 +62,7 @@ # card_summary(cards) error messages Code - card_summary(ard_stack(data = ADSL, by = c(ARM, AGEGR1), ard_continuous( + card_summary(ard_stack(data = ADSL, .by = c(ARM, AGEGR1), ard_continuous( variables = "AGE"), .attributes = TRUE, .missing = TRUE)) Condition Error in `card_summary()`: @@ -73,7 +72,7 @@ --- Code - card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + card_summary(ard_stack(data = ADSL, .by = ARM, ard_continuous(variables = "AGE"), .attributes = FALSE, .missing = TRUE)) Condition Error in `card_summary()`: @@ -83,7 +82,7 @@ # card_summary(type) error messages Code - card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + card_summary(ard_stack(data = ADSL, .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE), type = list(AGE = "categorical")) Condition Error in `card_summary()`: @@ -92,7 +91,7 @@ --- Code - card_summary(ard_stack(data = ADSL, by = ARM, ard_categorical(variables = "AGEGR1"), + card_summary(ard_stack(data = ADSL, .by = ARM, ard_categorical(variables = "AGEGR1"), .attributes = TRUE, .missing = TRUE), type = list(AGEGR1 = "continuous")) Condition Error in `card_summary()`: @@ -101,7 +100,7 @@ # card_summary(statistic) error messages Code - card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + card_summary(ard_stack(data = ADSL, .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE), statistic = list(AGE = "{not_a_valid_summary_statistic}")) Condition Error in `card_summary()`: @@ -111,7 +110,7 @@ --- Code - card_summary(ard_stack(data = ADSL, by = ARM, ard_continuous(variables = "AGE"), + card_summary(ard_stack(data = ADSL, .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE), statistic = list(AGE = c("{mean}", "{median}"))) Condition diff --git a/tests/testthat/test-add_n.tbl_summary.R b/tests/testthat/test-add_n.tbl_summary.R new file mode 100644 index 0000000000..f4e45ae201 --- /dev/null +++ b/tests/testthat/test-add_n.tbl_summary.R @@ -0,0 +1,48 @@ +test_that("add_n.tbl_summary() works", { + # with stratifying variable + expect_error( + tbl <- trial |> + tbl_summary(by = trt, include = c(age, grade, response)) |> + add_n(), + NA + ) + expect_equal( + as.data.frame(tbl, col_labels = FALSE)$n, + c("189", NA, "200", NA, NA, NA, "193", NA) + ) + + # without stratifying variable + expect_error( + tbl <- trial |> + tbl_summary(include = c(age, grade, response)) |> + add_n(), + NA + ) + expect_equal( + as.data.frame(tbl, col_labels = FALSE)$n, + c("189", NA, "200", NA, NA, NA, "193", NA) + ) + + # with multiple stats reported + expect_snapshot( + trial |> + tbl_summary(include = c(age, grade, response)) |> + add_n(statistic = "{N_nonmiss} / {N_obs}", footnote = TRUE, last = TRUE) |> + as.data.frame() + ) +}) + +test_that("add_n.tbl_summary(statistic) error messaging", { + expect_snapshot( + error = TRUE, + trial |> + tbl_summary(by = trt, include = c(trt, age, grade, response)) |> + add_n(statistic = "no_curlies") + ) + expect_snapshot( + error = TRUE, + trial |> + tbl_summary(by = trt, include = c(trt, age, grade, response)) |> + add_n(statistic = "{not_a_stat}") + ) +}) diff --git a/tests/testthat/test-card_summary.R b/tests/testthat/test-card_summary.R index 6b2b43cc03..badeca6ce1 100644 --- a/tests/testthat/test-card_summary.R +++ b/tests/testthat/test-card_summary.R @@ -5,7 +5,7 @@ test_that("card_summary() works", { expect_snapshot( ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, @@ -18,7 +18,6 @@ test_that("card_summary() works", { expect_snapshot( ard_stack( data = ADSL, - by = NULL, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, @@ -35,7 +34,6 @@ test_that("card_summary(statistic) argument works", { ard <- ard_stack( data = ADSL, - by = NULL, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .attributes = TRUE, @@ -68,7 +66,7 @@ test_that("card_summary(cards) error messages", { error = TRUE, ard_stack( data = ADSL, - by = c(ARM, AGEGR1), + .by = c(ARM, AGEGR1), ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE @@ -80,7 +78,7 @@ test_that("card_summary(cards) error messages", { error = TRUE, ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_continuous(variables = "AGE"), .attributes = FALSE, .missing = TRUE @@ -96,7 +94,7 @@ test_that("card_summary(type) error messages", { error = TRUE, ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE @@ -108,7 +106,7 @@ test_that("card_summary(type) error messages", { error = TRUE, ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_categorical(variables = "AGEGR1"), .attributes = TRUE, .missing = TRUE @@ -124,7 +122,7 @@ test_that("card_summary(statistic) error messages", { error = TRUE, ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE @@ -136,7 +134,7 @@ test_that("card_summary(statistic) error messages", { error = TRUE, ard_stack( data = ADSL, - by = ARM, + .by = ARM, ard_continuous(variables = "AGE"), .attributes = TRUE, .missing = TRUE From 0e76a683f386585e45302297e13d5874da6730c1 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 16 May 2024 09:40:37 -0700 Subject: [PATCH 55/74] Adding v2.0 `tbl_regression()` (#1648) * progress * doc updates * updates * Update DESCRIPTION * Update test-tbl_regression.R --- DESCRIPTION | 9 +- NAMESPACE | 2 + NEWS.md | 4 +- R/modify_fmt_fun.R | 2 +- R/modify_table_styling.R | 34 ++-- R/tbl_regression.R | 239 ++++++++++++++++++++++++ R/utils-gtsummary_core.R | 1 + R/utils-misc.R | 4 + R/utils-tbl_regression.R | 229 +++++++++++++++++++++++ man/modify.Rd | 3 + man/tbl_regression.Rd | 123 ++++++++++++ tests/testthat/_snaps/tbl_regression.md | 110 +++++++++++ tests/testthat/test-tbl_regression.R | 160 ++++++++++++++++ 13 files changed, 896 insertions(+), 24 deletions(-) create mode 100644 R/tbl_regression.R create mode 100644 R/utils-tbl_regression.R create mode 100644 man/tbl_regression.Rd create mode 100644 tests/testthat/_snaps/tbl_regression.md create mode 100644 tests/testthat/test-tbl_regression.R diff --git a/DESCRIPTION b/DESCRIPTION index ee69c00dcb..d9ef880efd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -53,12 +53,17 @@ Imports: lifecycle (>= 1.0.3), rlang (>= 1.1.1), tibble (>= 3.2.1), - tidyr (>= 1.3.0) + tidyr (>= 1.3.0), + vctrs Suggests: + broom (>= 1.0.5), + broom.helpers (>= 1.15.0), + broom.mixed, cardx (>= 0.1.0.9039), knitr, testthat (>= 3.2.0), - withr + withr, + lme4, smd, effectsize, emmeans VignetteBuilder: knitr RdMacros: diff --git a/NAMESPACE b/NAMESPACE index 288539aa9f..2797566e3f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) S3method(assign_tests,tbl_summary) S3method(print,gtsummary) +S3method(tbl_regression,default) export("%>%") export(.table_styling_expr_to_row_number) export(add_difference) @@ -60,6 +61,7 @@ export(style_percent) export(style_pvalue) export(style_ratio) export(style_sigfig) +export(tbl_regression) export(tbl_summary) export(vars) export(where) diff --git a/NEWS.md b/NEWS.md index e397b0ad19..46f8046c90 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ #### User-facing Updates +* After `tbl_regression()`, the `.$model_obj` is no longer returned with the object. This is (and always has been) available in `.$inputs$x`. + * Argument `add_p.tbl_summary(adj.vars)` was added to more easily add p-values that are adjusted/stratified by other columns in a data frame. * The counts in the header of `tbl_summary(by)` tables now appear on a new line. @@ -46,7 +48,7 @@ * The `add_p(test = ~'aov')` test is now deprecated as identical results can be obtained with `add_p(test = ~'oneway.test', test.args = ~list(var.equal = TRUE))`. -* Previously, `add_p.tbl_summary()` would coerce various data types to classes compatible with some base R tests. One example, is that we would convert `difftime` classes to general numeric before passing to `wilcox.test()`. We have eliminated type- and class-specific handling in these functions and it is now left to the the user pass data compatible with the functions that calculate the p-values or to create a custom test that wraps `wilcox.test()` and performs the conversion. This change is effective immediately. +* Previously, `add_p.tbl_summary()` would coerce various data types to classes compatible with some base R tests. For example, we would convert `difftime` classes to general numeric before passing to `wilcox.test()`. We have eliminated type- and class-specific handling in these functions and it is now left to the the user pass data compatible with the functions that calculate the p-values or to create a custom test that wraps `wilcox.test()` and performs the conversion. This change is effective immediately. # gtsummary 1.7.2 diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R index 8ba71f0a40..5cd2eea415 100644 --- a/R/modify_fmt_fun.R +++ b/R/modify_fmt_fun.R @@ -24,7 +24,7 @@ # #' lm(age ~ marker + grade, trial) %>% # #' tbl_regression() %>% # #' modify_fmt_fun( -# #' update = p.value ~ function(x) style_pvalue(x, digits = 3), +# #' update = p.value ~ styfn_pvalue(digits = 3), # #' rows = variable == "grade" # #' ) # #' } diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index dde78c3c3f..26225f95f4 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -95,6 +95,20 @@ modify_table_styling <- function(x, # checking inputs ------------------------------------------------------------ check_class(x, "gtsummary") + # update table_styling ------------------------------------------------------- + x <- .update_table_styling(x) + + # convert column input to string --------------------------------------------- + cards::process_selectors( + data = x$table_body, + columns = {{ columns }} + ) + + # if no columns selected, returning unaltered + if (is_empty(columns)) { + return(x) + } + # deprecation ---------------------------------------------------------------- if (isTRUE(undo_text_format)) { # set new values for the user @@ -165,26 +179,6 @@ modify_table_styling <- function(x, abort("The `rows=` predicate expression must result in logical vector when evaluated with `x$table_body`") } - # update table_styling ------------------------------------------------------- - x <- .update_table_styling(x) - - # convert column input to string --------------------------------------------- - cards::process_selectors( - data = x$table_body, - columns = {{ columns }} - ) - # columns <- - # broom.helpers::.select_to_varnames( - # select = {{ columns }}, - # data = x$table_body, - # arg_name = "columns" - # ) - - # if no columns selected, returning unaltered - if (is.null(columns)) { - return(x) - } - # label ---------------------------------------------------------------------- if (!is.null(label)) { x$table_styling$header <- diff --git a/R/tbl_regression.R b/R/tbl_regression.R new file mode 100644 index 0000000000..43b80752a2 --- /dev/null +++ b/R/tbl_regression.R @@ -0,0 +1,239 @@ +#' Regression model summary +#' +#' @description +#' This function takes a regression model object and returns a formatted table +#' that is publication-ready. The function is highly customizable +#' allowing the user to create bespoke regression model summary tables. +#' Review the +#' [`tbl_regression()` vignette](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) +#' for detailed examples. +#' +#' @param x (regression model)\cr +#' Regression model object +#' @param exponentiate (scalar `logical`)\cr +#' Logical indicating whether to exponentiate the coefficient estimates. +#' Default is `FALSE`. +#' @param label ([`formula-list-selector`][syntax])\cr +#' Used to change variables labels, e.g. `list(age = "Age", stage = "Path T Stage")` +#' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Variables to include in output. Default is `everything()`. +#' @param conf.level (scalar `real`)\cr +#' Confidence level for confidence interval/credible interval. Defaults to `0.95`. +#' @param intercept (scalar `logical`)\cr +#' Indicates whether to include the intercept in the output. Default is `FALSE` +#' @param show_single_row ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' By default categorical variables are printed on multiple rows. +#' If a variable is dichotomous (e.g. Yes/No) and you wish to print the +#' regression coefficient on a single row, include the variable name(s) here. +#' @param estimate_fun (`function`)\cr +#' Function to round and format coefficient estimates. +#' Default is [`styfn_sigfig()`] when the coefficients are not transformed, and +#' [`styfn_ratio()`] when the coefficients have been exponentiated. +#' @param pvalue_fun (`function`)\cr +#' Function to round and format p-values. Default is [`styfn_pvalue()`]. +#' @param tidy_fun (`function`)\cr +#' Tidier function for the model. Default is to use `broom::tidy()`. +#' If an error occurs, the tidying of the model is attempted with +#' `parameters::model_parameters()`, if installed. +#' @param add_estimate_to_reference_rows (scalar `logical`)\cr +#' Add a reference value. Default is `FALSE`. +#' @param conf.int (scalar `logical`)\cr +#' Logical indicating whether or not to include a confidence +#' interval in the output. Default is `TRUE`. +#' @param ... Additional arguments passed to [`broom.helpers::tidy_plus_plus()`]. +#' +#' @section Methods: +#' +#' The default method for `tbl_regression()` model summary uses `broom::tidy(x)` +#' to perform the initial tidying of the model object. There are, however, +#' a few models that use `[modifications][tbl_regression_methods]`. +#' TODO: Added the tbl_regression_methods help mentioned file above. +#' +#' - `"parsnip/workflows"`: If the model was prepared using parsnip/workflows, +#' the original model fit is extracted and the original `x=` argument +#' is replaced with the model fit. This will typically go unnoticed; however,if you've +#' provided a custom tidier in `tidy_fun=` the tidier will be applied to the model +#' fit object and not the parsnip/workflows object. +#' - `"survreg"`: The scale parameter is removed, `broom::tidy(x) %>% dplyr::filter(term != "Log(scale)")` +#' - `"multinom"`: This multinomial outcome is complex, with one line per covariate per outcome (less the reference group) +#' - `"gam"`: Uses the internal tidier `tidy_gam()` to print both parametric and smooth terms. +#' - `"tidycrr"`: Uses the tidier `tidycmprsk::tidy()` to print the model terms. +#' - `"lmerMod"`, `"glmerMod"`, `"glmmTMB"`, `"glmmadmb"`, `"stanreg"`, `"brmsfit"`: These mixed effects +#' models use `broom.mixed::tidy(x, effects = "fixed")`. Specify `tidy_fun = broom.mixed::tidy` +#' to print the random components. +#' +#' @author Daniel D. Sjoberg +#' @seealso See tbl_regression \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{vignette} for detailed examples +#' +#' @family tbl_regression tools +#' @name tbl_regression +#' @return A `tbl_regression` object +#' +#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "broom.helpers"), reference_pkg = "gtsummary")) +#' # Example 1 ---------------------------------- +#' glm(response ~ age + grade, trial, family = binomial()) %>% +#' tbl_regression(exponentiate = TRUE) +NULL + +#' @rdname tbl_regression +#' @export +tbl_regression <- function(x, ...) { + check_pkg_installed(c("broom", "broom.helpers"), reference_pkg = "gtsummary") + check_not_missing(x) + UseMethod("tbl_regression") +} + +#' @rdname tbl_regression +#' @export +tbl_regression.default <- function(x, + label = NULL, + exponentiate = FALSE, + include = everything(), + show_single_row = NULL, + conf.level = 0.95, + intercept = FALSE, + estimate_fun = ifelse(exponentiate, styfn_ratio(), styfn_sigfig()), + pvalue_fun = styfn_pvalue(), + tidy_fun = broom.helpers::tidy_with_broom_or_parameters, + add_estimate_to_reference_rows = FALSE, + conf.int = TRUE, ...) { + set_cli_abort_call() + + # setting theme defaults ----------------------------------------------------- + if (missing(pvalue_fun)) { + pvalue_fun <- + get_theme_element("tbl_regression-arg:pvalue_fun") %||% + get_theme_element("pkgwide-fn:pvalue_fun") %||% + pvalue_fun + } + pvalue_fun <- as_function(pvalue_fun, arg = "pvalue_fun") + + check_scalar_logical(exponentiate) + if (missing(estimate_fun)) { + estimate_fun <- + get_theme_element("tbl_regression-arg:estimate_fun") %||% + estimate_fun + } + estimate_fun <- as_function(estimate_fun, arg = "estimate_fun") + + if (missing(conf.level)) { + conf.level <- get_theme_element("tbl_regression-arg:conf.level", default = conf.level) + } + + if (missing(conf.int)) { + conf.int <- get_theme_element("tbl_regression-arg:conf.int", default = conf.int) + } + + if (missing(add_estimate_to_reference_rows)) { + add_estimate_to_reference_rows <- get_theme_element("tbl_regression-arg:add_estimate_to_reference_rows", default = add_estimate_to_reference_rows) + } + + # check inputs --------------------------------------------------------------- + check_scalar_logical(intercept) + check_scalar_logical(add_estimate_to_reference_rows) + check_scalar_logical(conf.int) + check_scalar(conf.level) + check_range(conf.level, range = c(0, 1)) + + # quote inputs and save argument values -------------------------------------- + include <- enquo(include) + show_single_row <- enquo(show_single_row) + func_inputs <- as.list(environment()) + + # build table_body ----------------------------------------------------------- + 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, + include = !!include, + add_estimate_to_reference_rows = add_estimate_to_reference_rows, + conf.int = conf.int, + ... + ) |> + dplyr::relocate(any_of(c("conf.low", "conf.high", "p.value")), .after = last_col()) + + # saving evaluated `label`, `show_single_row`, and `include` ----------------- + cards::process_selectors( + data = select_prep(table_body), + show_single_row = !!show_single_row, + include = !!include + ) + cards::process_formula_selectors( + data = select_prep(table_body), + label = label + ) + func_inputs <- + utils::modifyList( + func_inputs, + val = list(include = include, show_single_row = show_single_row, label = label), + keep.null = TRUE + ) + + # construct initial gtsummary object ----------------------------------------- + res <- list() + res$table_body <- table_body + res <- + construct_initial_table_styling(res) |> + utils::modifyList( + list( + N = table_body[["N_obs"]][1], + N_event = table_body[["N_event"]][1], + inputs = func_inputs, + call_list = list(tbl_regression = match.call()) + ), + keep.null = FALSE + ) |> + structure(class = c("tbl_regression", "gtsummary")) + + # setting column headers, and print instructions + # TODO: Deprecate this... this was an odd choice? + tidy_columns_to_report <- + get_theme_element("tbl_regression-chr:tidy_columns", + default = c("conf.low", "conf.high", "p.value") + ) |> + union("estimate") |> + intersect(names(table_body)) + + # setting default table_header values + res <- + .tbl_regression_default_table_header( + res, + exponentiate = exponentiate, + tidy_columns_to_report = tidy_columns_to_report, + estimate_fun = estimate_fun, + pvalue_fun = pvalue_fun, + conf.level = conf.level + ) + + # adding the Ns to the `x$table_styling$header` + if (!rlang::is_empty(res[c("N", "N_event")] |> compact())) { + res$table_styling$header <- + res[c("N","N_event")] |> + compact() |> + dplyr::as_tibble() |> + dplyr::rename_with(.fn = ~ vec_paste0("modify_stat_", .), .cols = everything()) |> + dplyr::cross_join( + res$table_styling$header + ) |> + dplyr::relocate(starts_with("modify_stat_"), .after = last_col()) + } + + + # running any additional mods ------------------------------------------------ + res <- + get_theme_element("tbl_regression-fn:addnl-fn-to-run", default = identity) |> + do.call(list(res)) + + # return results ------------------------------------------------------------- + res |> + modify_table_styling( + columns = "label", + rows = .data$row_type %in% c("level", "missing"), + indentation = 4 + ) +} diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index a28f8f063c..92993273e7 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -1,4 +1,5 @@ get_theme_element <- function(..., default = NULL) default +translate_text <- function(x, ...) x construct_initial_table_styling <- function(x) { # table_styling -------------------------------------------------------------- diff --git a/R/utils-misc.R b/R/utils-misc.R index 03e879c052..0d180fbf38 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -13,6 +13,10 @@ no } +vec_paste0 <- function(..., collapse = NULL) { + args <- vctrs::vec_recycle_common(...) + rlang::inject(paste0(!!!args, collapse = collapse)) +} # used in the as_flex_table (and friends) functions for inserting calls add_expr_after <- function(calls, add_after, expr, new_name = NULL) { diff --git a/R/utils-tbl_regression.R b/R/utils-tbl_regression.R new file mode 100644 index 0000000000..2abfbdf3f4 --- /dev/null +++ b/R/utils-tbl_regression.R @@ -0,0 +1,229 @@ +# prepares the tidy object to be printed with broom.helpers +tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, + show_single_row, include, add_estimate_to_reference_rows, + conf.int, ...) { + # getting the default `tidy_plus_plus()` args + tidy_plus_plus_args <- + get_theme_element("tbl_regression-lst:tidy_plus_plus", default = list()) |> + c(list(add_header_rows = TRUE)) |> + utils::modifyList(val = rlang::enquos(...)) + + # 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(.)}] # styler: off + + # 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, + conf.int = conf.int, + add_estimate_to_reference_rows = add_estimate_to_reference_rows, + strict = TRUE, + !!!tidy_plus_plus_args + ) + ) |> + eval_tidy() %>% + # styler: off + {dplyr::bind_cols( + ., + attributes(.)[names(attributes(.)) %in% c("N_obs", "N_event", "coefficients_type", "coefficients_label")] %>% + tibble::as_tibble() + )} + # styler: on + + if (!"header_row" %in% names(df_tidy)) { + df_tidy$header_row <- NA + } + + df_tidy <- df_tidy |> + mutate( + row_type = ifelse(.data$header_row | is.na(.data$header_row), "label", "level") + ) + + # these are old column names, but i prefer to keep the consistently names from broom.helpers + # adding these back to the data frame for backwards compatibility + if ("N_obs" %in% names(df_tidy)) df_tidy <- mutate(df_tidy, N = .data$N_obs) + if ("N_event" %in% names(df_tidy)) df_tidy <- mutate(df_tidy, nevent = .data$N_event) + + df_tidy |> + select( + any_of(c( + "variable", "var_label", "var_type", + "reference_row", "row_type", "header_row", "N_obs", "N_event", "N", + "coefficients_type", "coefficients_label", "label" + )), + everything() + ) +} + + +.tbl_regression_default_table_header <- function(x, + exponentiate, + tidy_columns_to_report, + estimate_fun, + pvalue_fun, + conf.level) { + # label ---------------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = any_of("label"), + label = paste0("**", translate_text("Characteristic"), "**"), + hide = FALSE + ) + + # estimate ------------------------------------------------------------------- + estimate_column_labels <- .estimate_column_labels(x) + x <- + modify_table_styling( + x, + columns = any_of("estimate"), + label = glue("**{estimate_column_labels$label}**") %>% as.character(), + hide = !"estimate" %in% tidy_columns_to_report, + footnote_abbrev = glue("{estimate_column_labels$footnote}") %>% as.character(), + fmt_fun = estimate_fun + ) |> + modify_table_styling( + columns = any_of("estimate"), + rows = .data$reference_row == TRUE, + missing_symbol = get_theme_element("tbl_regression-str:ref_row_text", default = "\U2014") + ) + + # N -------------------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = any_of("N"), + label = glue("**{translate_text('N')}**") %>% as.character(), + fmt_fun = styfn_number() + ) |> + modify_table_styling( + columns = any_of(c("N_obs", "N_event", "n_obs", "n_event")), + fmt_fun = styfn_number() + ) + + # conf.low ------------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = any_of("conf.low"), + label = glue("**{style_percent(conf.level, symbol = TRUE)} {translate_text('CI')}**") |> as.character(), + hide = !all(c("conf.low", "conf.high") %in% tidy_columns_to_report), + footnote_abbrev = + ifelse( + inherits(x$inputs$x, c("stanreg", "stanfit", "brmsfit", "rjags")), + translate_text("CI = Credible Interval"), + translate_text("CI = Confidence Interval") + ) + ) |> + modify_table_styling( + columns = any_of("conf.low"), + rows = .data$reference_row == TRUE, + missing_symbol = get_theme_element("tbl_regression-str:ref_row_text", default = "\U2014") + ) |> + modify_table_styling( + columns = any_of("conf.low"), + rows = !is.na(.data$conf.low), + cols_merge_pattern = + paste("{conf.low}", "{conf.high}", sep = get_theme_element("pkgwide-str:ci.sep", default = ", ")) + ) + + x <- + modify_table_styling(x, + columns = any_of(c("conf.low", "conf.high")), + fmt_fun = estimate_fun + ) + + # p.value -------------------------------------------------------------------- + x <- modify_table_styling( + x, + columns = any_of("p.value"), + label = paste0("**", translate_text("p-value"), "**"), + fmt_fun = pvalue_fun, + hide = !"p.value" %in% tidy_columns_to_report + ) + + # std.error ------------------------------------------------------------------ + x <- + modify_table_styling( + x, + columns = any_of("std.error"), + label = paste0("**", translate_text("SE"), "**"), + footnote_abbrev = translate_text("SE = Standard Error"), + fmt_fun = styfn_sigfig(digits = 3), + hide = !"std.error" %in% tidy_columns_to_report + ) |> + modify_table_styling( + columns = any_of("std.error"), + rows = .data$reference_row == TRUE, + missing_symbol = get_theme_element("tbl_regression-str:ref_row_text", default = "\U2014") + ) + + # statistic ------------------------------------------------------------------ + x <- + modify_table_styling( + x, + columns = any_of("statistic"), + label = paste0("**", translate_text("Statistic"), "**"), + fmt_fun = styfn_sigfig(digits = 3), + hide = !"statistic" %in% tidy_columns_to_report + ) |> + modify_table_styling( + columns = any_of("statistic"), + rows = .data$reference_row == TRUE, + missing_symbol = get_theme_element("tbl_regression-str:ref_row_text", default = "\U2014") + ) + + # finally adding style_sigfig(x, digits = 3) as default for all other columns + x <- + modify_table_styling( + x, + columns = + c( + where(is.numeric), + -any_of(c( + "estimate", "conf.low", "conf.high", "p.value", "std.error", "statistic", + "N", "N_obs", "N_event", "n_obs", "n_event" + )) + ), + fmt_fun = styfn_sigfig(digits = 3) + ) + + x +} + +.estimate_column_labels <- function(x) { + language <- get_theme_element("pkgwide-str:language", default = "en") + + + result <- list() + result$label <- unique(x$table_body$coefficients_label) + + if (result$label %in% c("Beta", "exp(Beta)")) { + exponentiate <- x$inputs$exponentiate + result$label <- get_theme_element("tbl_regression-str:coef_header", + default = result$label + ) + } + + result$footnote <- + dplyr::case_when( + result$label %in% c("OR", "log(OR)") ~ "OR = Odds Ratio", + result$label %in% c("HR", "log(HR)") ~ "HR = Hazard Ratio", + result$label %in% c("RR", "log(RR)") ~ "RR = Relative Risk", + result$label %in% c("IRR", "log(IRR)") ~ "IRR = Incidence Rate Ratio" + ) %>% + translate_text(language) %>% + {switch(!is.na(.), .)} # styler: off + result$label <- translate_text(result$label, language) + result +} + diff --git a/man/modify.Rd b/man/modify.Rd index 4643a98215..cde14634cf 100644 --- a/man/modify.Rd +++ b/man/modify.Rd @@ -115,6 +115,9 @@ modify_ex3 <- \seealso{ Other tbl_summary tools: \code{\link{tbl_summary}()} + +Other tbl_regression tools: +\code{\link{tbl_regression}()} } \author{ Daniel D. Sjoberg diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd new file mode 100644 index 0000000000..eea720fd10 --- /dev/null +++ b/man/tbl_regression.Rd @@ -0,0 +1,123 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tbl_regression.R +\name{tbl_regression} +\alias{tbl_regression} +\alias{tbl_regression.default} +\title{Regression model summary} +\usage{ +tbl_regression(x, ...) + +\method{tbl_regression}{default}( + x, + label = NULL, + exponentiate = FALSE, + include = everything(), + show_single_row = NULL, + conf.level = 0.95, + intercept = FALSE, + estimate_fun = ifelse(exponentiate, styfn_ratio(), styfn_sigfig()), + pvalue_fun = styfn_pvalue(), + tidy_fun = broom.helpers::tidy_with_broom_or_parameters, + add_estimate_to_reference_rows = FALSE, + conf.int = TRUE, + ... +) +} +\arguments{ +\item{x}{(regression model)\cr +Regression model object} + +\item{...}{Additional arguments passed to \code{\link[broom.helpers:tidy_plus_plus]{broom.helpers::tidy_plus_plus()}}.} + +\item{label}{(\code{\link[=syntax]{formula-list-selector}})\cr +Used to change variables labels, e.g. \code{list(age = "Age", stage = "Path T Stage")}} + +\item{exponentiate}{(scalar \code{logical})\cr +Logical indicating whether to exponentiate the coefficient estimates. +Default is \code{FALSE}.} + +\item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Variables to include in output. Default is \code{everything()}.} + +\item{show_single_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +By default categorical variables are printed on multiple rows. +If a variable is dichotomous (e.g. Yes/No) and you wish to print the +regression coefficient on a single row, include the variable name(s) here.} + +\item{conf.level}{(scalar \code{real})\cr +Confidence level for confidence interval/credible interval. Defaults to \code{0.95}.} + +\item{intercept}{(scalar \code{logical})\cr +Indicates whether to include the intercept in the output. Default is \code{FALSE}} + +\item{estimate_fun}{(\code{function})\cr +Function to round and format coefficient estimates. +Default is \code{\link[=styfn_sigfig]{styfn_sigfig()}} when the coefficients are not transformed, and +\code{\link[=styfn_ratio]{styfn_ratio()}} when the coefficients have been exponentiated.} + +\item{pvalue_fun}{(\code{function})\cr +Function to round and format p-values. Default is \code{\link[=styfn_pvalue]{styfn_pvalue()}}.} + +\item{tidy_fun}{(\code{function})\cr +Tidier function for the model. Default is to use \code{broom::tidy()}. +If an error occurs, the tidying of the model is attempted with +\code{parameters::model_parameters()}, if installed.} + +\item{add_estimate_to_reference_rows}{(scalar \code{logical})\cr +Add a reference value. Default is \code{FALSE}.} + +\item{conf.int}{(scalar \code{logical})\cr +Logical indicating whether or not to include a confidence +interval in the output. Default is \code{TRUE}.} +} +\value{ +A \code{tbl_regression} object +} +\description{ +This function takes a regression model object and returns a formatted table +that is publication-ready. The function is highly customizable +allowing the user to create bespoke regression model summary tables. +Review the +\href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{\code{tbl_regression()} vignette} +for detailed examples. +} +\section{Methods}{ + + +The default method for \code{tbl_regression()} model summary uses \code{broom::tidy(x)} +to perform the initial tidying of the model object. There are, however, +a few models that use \verb{[modifications][tbl_regression_methods]}. +TODO: Added the tbl_regression_methods help mentioned file above. +\itemize{ +\item \code{"parsnip/workflows"}: If the model was prepared using parsnip/workflows, +the original model fit is extracted and the original \verb{x=} argument +is replaced with the model fit. This will typically go unnoticed; however,if you've +provided a custom tidier in \verb{tidy_fun=} the tidier will be applied to the model +fit object and not the parsnip/workflows object. +\item \code{"survreg"}: The scale parameter is removed, \code{broom::tidy(x) \%>\% dplyr::filter(term != "Log(scale)")} +\item \code{"multinom"}: This multinomial outcome is complex, with one line per covariate per outcome (less the reference group) +\item \code{"gam"}: Uses the internal tidier \code{tidy_gam()} to print both parametric and smooth terms. +\item \code{"tidycrr"}: Uses the tidier \code{tidycmprsk::tidy()} to print the model terms. +\item \code{"lmerMod"}, \code{"glmerMod"}, \code{"glmmTMB"}, \code{"glmmadmb"}, \code{"stanreg"}, \code{"brmsfit"}: These mixed effects +models use \code{broom.mixed::tidy(x, effects = "fixed")}. Specify \code{tidy_fun = broom.mixed::tidy} +to print the random components. +} +} + +\examples{ +\dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "broom.helpers"), reference_pkg = "gtsummary"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +# Example 1 ---------------------------------- +glm(response ~ age + grade, trial, family = binomial()) \%>\% + tbl_regression(exponentiate = TRUE) +\dontshow{\}) # examplesIf} +} +\seealso{ +See tbl_regression \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{vignette} for detailed examples + +Other tbl_regression tools: +\code{\link{modify}} +} +\author{ +Daniel D. Sjoberg +} +\concept{tbl_regression tools} diff --git a/tests/testthat/_snaps/tbl_regression.md b/tests/testthat/_snaps/tbl_regression.md new file mode 100644 index 0000000000..116a6be442 --- /dev/null +++ b/tests/testthat/_snaps/tbl_regression.md @@ -0,0 +1,110 @@ +# stats::glm() logistic regression works + + Code + as.data.frame(tbl_regression(mod_logistic)) + Output + **Characteristic** **log(OR)** **95% CI** **p-value** + 1 Age 0.02 0.00, 0.04 0.091 + 2 T Stage + 3 T1 + 4 T2 -0.54 -1.4, 0.31 0.2 + 5 T3 -0.06 -0.95, 0.82 0.9 + 6 T4 -0.23 -1.1, 0.64 0.6 + +--- + + Code + as.data.frame(tbl_regression(mod_logistic, exponentiate = TRUE, estimate_fun = styfn_ratio( + digits = 1))) + Output + **Characteristic** **OR** **95% CI** **p-value** + 1 Age 1.0 1.0, 1.0 0.091 + 2 T Stage + 3 T1 + 4 T2 0.6 0.2, 1.4 0.2 + 5 T3 0.9 0.4, 2.3 0.9 + 6 T4 0.8 0.3, 1.9 0.6 + +# stats::glm() poisson regression works + + Code + as.data.frame(tbl_regression(mod_poisson, show_single_row = "trt", + estimate_fun = styfn_ratio(digits = 1))) + Output + **Characteristic** **log(IRR)** **95% CI** **p-value** + 1 Age 0.0 0.0, 0.0 0.6 + 2 Chemotherapy Treatment 0.0 -0.1, 0.2 0.7 + +--- + + Code + as.data.frame(tbl_regression(mod_poisson, exponentiate = TRUE, show_single_row = "trt", + estimate_fun = styfn_ratio(digits = 1))) + Output + **Characteristic** **IRR** **95% CI** **p-value** + 1 Age 1.0 1.0, 1.0 0.6 + 2 Chemotherapy Treatment 1.0 0.9, 1.2 0.7 + +# stats::lm() linear regression works + + Code + as.data.frame(tbl_regression(mod_lm)) + Output + **Characteristic** **Beta** **95% CI** **p-value** + 1 am -33 -83, 16 0.2 + +# stats::lm() works with interactions + + Code + as.data.frame(tbl_regression(mod_lm_interaction, label = list(trt = "Tx"))) + Output + **Characteristic** **Beta** **95% CI** **p-value** + 1 Tx + 2 Drug A + 3 Drug B -0.61 -9.4, 8.2 0.9 + 4 Grade + 5 I + 6 II 0.14 -8.3, 8.6 >0.9 + 7 III 4.5 -4.9, 14 0.3 + 8 Tumor Response 4.8 -6.9, 16 0.4 + 9 Tx * Grade + 10 Drug B * II 4.2 -8.4, 17 0.5 + 11 Drug B * III -2.9 -16, 9.9 0.7 + 12 Tx * Tumor Response + 13 Drug B * Tumor Response 1.3 -14, 17 0.9 + 14 Grade * Tumor Response + 15 II * Tumor Response -4.4 -21, 13 0.6 + 16 III * Tumor Response -0.56 -17, 16 >0.9 + 17 Tx * Grade * Tumor Response + 18 Drug B * II * Tumor Response 1.3 -22, 24 >0.9 + 19 Drug B * III * Tumor Response -5.3 -28, 17 0.6 + +# tbl_regression(intercept) + + Code + as.data.frame(tbl_regression(lm(age ~ marker, trial), intercept = TRUE)) + Output + **Characteristic** **Beta** **95% CI** **p-value** + 1 (Intercept) 47 44, 50 <0.001 + 2 Marker Level (ng/mL) -0.05 -2.5, 2.4 >0.9 + +# tbl_regression(add_estimate_to_reference_rows) + + Code + as.data.frame(tbl_regression(lm(age ~ marker, trial), + add_estimate_to_reference_rows = TRUE)) + Output + **Characteristic** **Beta** **95% CI** **p-value** + 1 Marker Level (ng/mL) -0.05 -2.5, 2.4 >0.9 + +--- + + Code + as.data.frame(tbl_regression(glm(response ~ trt, trial, family = binomial()), + add_estimate_to_reference_rows = TRUE, exponentiate = TRUE)) + Output + **Characteristic** **OR** **95% CI** **p-value** + 1 Chemotherapy Treatment + 2 Drug A 1.00 + 3 Drug B 1.21 0.66, 2.24 0.5 + diff --git a/tests/testthat/test-tbl_regression.R b/tests/testthat/test-tbl_regression.R new file mode 100644 index 0000000000..772a51a505 --- /dev/null +++ b/tests/testthat/test-tbl_regression.R @@ -0,0 +1,160 @@ +mod_lm <- lm(hp ~ am, data = mtcars) +mod_logistic <- glm(response ~ age + stage, trial, family = binomial) +mod_poisson <- + glm(count ~ age + trt, + trial |> dplyr::mutate(count = dplyr::row_number() %% 10), + family = poisson + ) +mod_lm_interaction <- lm(age ~ trt * grade * response, data = trial) + + +test_that("stats::glm() logistic regression works", { + expect_snapshot(tbl_regression(mod_logistic) |> as.data.frame()) + + expect_equal( + tbl_regression(mod_logistic)$table_styling$header |> + dplyr::filter(column == "estimate") |> + dplyr::pull(label), + "**log(OR)**" + ) + + expect_false( + "conf.low" %in% names(tbl_regression(mod_logistic, conf.int = FALSE) |> as_tibble(col_labels = FALSE)) + ) + + expect_snapshot( + tbl_regression( + mod_logistic, + exponentiate = TRUE, + estimate_fun = styfn_ratio(digits = 1) + ) |> + as.data.frame() + ) + + expect_equal( + tbl_regression(mod_logistic, exponentiate = TRUE)$table_styling$header |> + dplyr::filter(column == "estimate") |> + dplyr::pull(label), + "**OR**" + ) +}) + +test_that("stats::glm() poisson regression works", { + expect_snapshot( + tbl_regression( + mod_poisson, + show_single_row = "trt", + estimate_fun = styfn_ratio(digits = 1) + ) |> + as.data.frame() + ) + + expect_equal( + tbl_regression(mod_poisson)$table_styling$header |> + dplyr::filter(column == "estimate") |> + dplyr::pull(label), + "**log(IRR)**" + ) + + expect_snapshot( + tbl_regression( + mod_poisson, + exponentiate = TRUE, + show_single_row = "trt", + estimate_fun = styfn_ratio(digits = 1) + ) |> + as.data.frame() + ) + + expect_equal( + tbl_regression(mod_poisson, exponentiate = TRUE)$table_styling$header |> + dplyr::filter(column == "estimate") |> + dplyr::pull(label), + "**IRR**" + ) +}) + +test_that("stats::lm() linear regression works", { + expect_snapshot(tbl_regression(mod_lm) |> as.data.frame()) +}) + +test_that("stats::lm() works with interactions", { + expect_snapshot( + tbl_regression( + mod_lm_interaction, + label = list(trt = "Tx") + ) |> + as.data.frame() + ) +}) + +test_that("tbl_regression(include)", { + # only the single row of 'am' appears in table + expect_equal( + lm(mpg ~ cyl + am, mtcars) |> + tbl_regression(include = am) |> + as.data.frame() |> + nrow(), + 1L + ) +}) + +test_that("tbl_regression(show_single_row)", { + # trt variable displays on single row + expect_equal( + lm(age ~ trt + marker, trial) |> + tbl_regression(show_single_row = trt) |> + getElement("table_body") |> + dplyr::filter(variable == "trt") |> + nrow(), + 1L + ) +}) + +test_that("tbl_regression(conf.level)", { + expect_error( + tbl <- lm(age ~ trt + marker, trial) |> + tbl_regression(conf.level = 0.80), + NA + ) + + expect_equal( + tbl$table_styling$header |> + dplyr::filter(column %in% "conf.low") |> + dplyr::pull(label), + "**80% CI**" + ) +}) + +test_that("tbl_regression(intercept)", { + expect_snapshot( + lm(age ~ marker, trial) |> + tbl_regression(intercept = TRUE) |> + as.data.frame() + ) +}) + +test_that("tbl_regression(add_estimate_to_reference_rows)", { + expect_snapshot( + lm(age ~ marker, trial) |> + tbl_regression(add_estimate_to_reference_rows = TRUE) |> + as.data.frame() + ) + + expect_snapshot( + glm(response ~ trt, trial, family = binomial()) |> + tbl_regression(add_estimate_to_reference_rows = TRUE, exponentiate = TRUE) |> + as.data.frame() + ) +}) + +test_that("tbl_regression(conf.int)", { + # no confidence interval + expect_equal( + lm(age ~ marker, trial) |> + tbl_regression(conf.int = FALSE) |> + as.data.frame(col_labels = FALSE) |> + names(), + c("label", "estimate", "p.value") + ) +}) From 427c38060d6bf12df959ea40162c75a9de21b358 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 16 May 2024 14:52:37 -0700 Subject: [PATCH 56/74] bridge rename (#1661) --- R/{bridge_summary.R => brdg_summary.R} | 20 +++++++++++--------- man/{bridge_summary.Rd => brdg_summary.Rd} | 5 ++--- 2 files changed, 13 insertions(+), 12 deletions(-) rename R/{bridge_summary.R => brdg_summary.R} (97%) rename man/{bridge_summary.Rd => brdg_summary.Rd} (97%) diff --git a/R/bridge_summary.R b/R/brdg_summary.R similarity index 97% rename from R/bridge_summary.R rename to R/brdg_summary.R index ed5d76ab03..399aa5c983 100644 --- a/R/bridge_summary.R +++ b/R/brdg_summary.R @@ -35,7 +35,7 @@ #' @inheritParams tbl_summary #' #' @return data frame -#' @name bridge_summary +#' @name brdg_summary #' #' @examples #' library(cards) @@ -98,7 +98,7 @@ #' ) NULL -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export brdg_summary <- function(cards, variables, @@ -115,7 +115,8 @@ brdg_summary <- function(cards, if (is_empty(by)) { cards$gts_column <- ifelse( - cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), + !cards$context %in% "attributes", + # cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), "stat_0", NA_character_ ) @@ -128,7 +129,8 @@ brdg_summary <- function(cards, dplyr::filter( ., .data$variable %in% .env$variables, - .data$context %in% c("continuous", "categorical", "dichotomous", "missing") + !cards$context %in% "attributes", + # cards$context %in% c("continuous", "categorical", "dichotomous", "missing"), ) |> dplyr::select(cards::all_ard_groups(), "variable", "context") |> dplyr::distinct() |> @@ -193,7 +195,7 @@ brdg_summary <- function(cards, modify_column_unhide(columns = all_stat_cols()) } -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export pier_summary_dichotomous <- function(cards, variables, @@ -210,7 +212,7 @@ pier_summary_dichotomous <- function(cards, ) } -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export pier_summary_categorical <- function(cards, variables, @@ -328,7 +330,7 @@ pier_summary_categorical <- function(cards, df_results } -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export pier_summary_continuous2 <- function(cards, variables, @@ -434,7 +436,7 @@ pier_summary_continuous2 <- function(cards, df_results } -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export pier_summary_continuous <- function(cards, variables, @@ -499,7 +501,7 @@ pier_summary_continuous <- function(cards, df_results } -#' @rdname bridge_summary +#' @rdname brdg_summary #' @export pier_summary_missing_row <- function(cards, variables, diff --git a/man/bridge_summary.Rd b/man/brdg_summary.Rd similarity index 97% rename from man/bridge_summary.Rd rename to man/brdg_summary.Rd index 9a1d0d6b0c..a8d3314a72 100644 --- a/man/bridge_summary.Rd +++ b/man/brdg_summary.Rd @@ -1,7 +1,6 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bridge_summary.R -\name{bridge_summary} -\alias{bridge_summary} +% Please edit documentation in R/brdg_summary.R +\name{brdg_summary} \alias{brdg_summary} \alias{pier_summary_dichotomous} \alias{pier_summary_categorical} From 3c1935f60217335321015cea10c9fa7e2227823b Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 16 May 2024 14:57:37 -0700 Subject: [PATCH 57/74] Adding `add_q()` (#1662) --- NAMESPACE | 1 + NEWS.md | 2 + R/add_difference.R | 2 +- R/add_p.R | 2 +- R/add_q.R | 112 ++++++++++++++++++++++++++++++ R/tbl_regression.R | 2 +- man/add_difference.tbl_summary.Rd | 2 +- man/add_p.tbl_summary.Rd | 2 +- man/add_q.Rd | 52 ++++++++++++++ man/tbl_regression.Rd | 2 +- tests/testthat/_snaps/add_q.md | 8 +++ tests/testthat/test-add_q.R | 37 ++++++++++ 12 files changed, 218 insertions(+), 6 deletions(-) create mode 100644 R/add_q.R create mode 100644 man/add_q.Rd create mode 100644 tests/testthat/_snaps/add_q.md create mode 100644 tests/testthat/test-add_q.R diff --git a/NAMESPACE b/NAMESPACE index 2797566e3f..8a29c84966 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ export(.table_styling_expr_to_row_number) export(add_difference) export(add_n) export(add_p) +export(add_q) export(all_categorical) export(all_continuous) export(all_continuous2) diff --git a/NEWS.md b/NEWS.md index 46f8046c90..2275a98028 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ #### User-facing Updates +* The `add_q(quiet)` argument has been deprecated. + * After `tbl_regression()`, the `.$model_obj` is no longer returned with the object. This is (and always has been) available in `.$inputs$x`. * Argument `add_p.tbl_summary(adj.vars)` was added to more easily add p-values that are adjusted/stratified by other columns in a data frame. diff --git a/R/add_difference.R b/R/add_difference.R index bd996bfc1a..92ac337799 100644 --- a/R/add_difference.R +++ b/R/add_difference.R @@ -80,7 +80,7 @@ add_difference.tbl_summary <- function(x, test.args = NULL, conf.level = 0.95, include = everything(), - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), estimate_fun = list( c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, paste0(style_sigfig(x, scale = 100), "%")), diff --git a/R/add_p.R b/R/add_p.R index d8bfbbd094..adcbdc8629 100644 --- a/R/add_p.R +++ b/R/add_p.R @@ -100,7 +100,7 @@ add_p <- function(x, ...) { #' ) add_p.tbl_summary <- function(x, test = NULL, - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), group = NULL, include = everything(), test.args = NULL, diff --git a/R/add_q.R b/R/add_q.R new file mode 100644 index 0000000000..0ea4fa1d8c --- /dev/null +++ b/R/add_q.R @@ -0,0 +1,112 @@ +#' Add multiple comparison adjustment +#' +#' Adjustments to p-values are performed with [`stats::p.adjust()`]. +#' +#' @param x (`gtsummary`)\cr +#' a `gtsummary` object with a column named `"p.value"` +#' @param method (`string`)\cr +#' String indicating method to be used for p-value adjustment. Methods from +#' [`stats::p.adjust()`] are accepted. Default is `method='fdr'`. +#' Must be one of `r shQuote(stats::p.adjust.methods, "sh")` +#' @param pvalue_fun (`function`)\cr +#' Function to round and format q-values. Default is the function specified +#' to round the existing `'p.value'` column. +#' @param quiet DEPRECATED +#' +#' @author Daniel D. Sjoberg, Esther Drill +#' @export +#' @examplesIf gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx") +#' # Example 1 ---------------------------------- +#' add_q_ex1 <- +#' trial |> +#' tbl_summary(by = trt, include = c(trt, age, grade, response)) |> +#' add_p() |> +#' add_q() +#' +#' # TODO: Re-add this example after `add_global_p()` migrated +#' # # Example 2 ---------------------------------- +#' # add_q_ex2 <- +#' # trial[c("trt", "age", "grade", "response")] |> +#' # tbl_uvregression( +#' # y = response, +#' # method = glm, +#' # method.args = list(family = binomial), +#' # exponentiate = TRUE +#' # ) |> +#' # add_global_p() |> +#' # add_q() +add_q <- function(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(add_q = match.call())) + + # deprecation ---------------------------------------------------------------- + if (!is_empty(quiet)) { + lifecycle::deprecate_warn( + when = "2.0.0", + what = "gtsummary::add_q(quiet)" + ) + } + + # check inputs --------------------------------------------------------------- + check_class(x, "gtsummary") + method <- arg_match(method, values = stats::p.adjust.methods, multiple = TRUE) + # checking input table has a p.value column + if (!"p.value" %in% names(x$table_body)) { + cli::cli_abort( + "There is no p-value column. `x$table_body` must have a column called {.val p.value}.", + call = get_cli_abort_call() + ) + } + + # setting defaults from gtsummary theme -------------------------------------- + pvalue_fun <- + pvalue_fun %||% + # defaults from theme + get_theme_element("add_q-arg:pvalue_fun") %||% + get_theme_element("pkgwide-fn:pvalue_fun") %||% + # default from p-value formatting function + (dplyr::filter(x$table_styling$fmt_fun, .data$column == "p.value") |> dplyr::pull("fmt_fun") |> rev() |> getElement(1)) |> + as_function(arg = "pvalue_fun") + + # calculate the adjusted p-value --------------------------------------------- + # TODO: add error handling here + q.value <- stats::p.adjust(x$table_body$p.value, method = method) + + # update gtsummary table ----------------------------------------------------- + x <- + modify_table_body(x, ~dplyr::mutate(.x, q.value = q.value)) |> + modify_table_styling( + columns = "q.value", + label = paste0("**", translate_text("q-value"), "**"), + hide = FALSE, + footnote = .add_q_method_label(method), + fmt_fun = pvalue_fun + ) + + # return final object -------------------------------------------------------- + # fill in the Ns in the header table modify_stat_* columns + x$table_styling$header <- tidyr::fill(x$table_styling$header, "modify_stat_N", .direction = "updown") + # adding call + x$call_list <- updated_call_list + + x +} + + +# match method input to display name +.add_q_method_label <- function(method) { + lst_method_labels <- + list( + "holm" = "Holm correction for multiple testing", + "hochberg" = "Hochberg correction for multiple testing", + "hommel" = "Hommel correction for multiple testing", + "bonferroni" = "Bonferroni correction for multiple testing", + "BH" = "Benjamini & Hochberg correction for multiple testing", + "BY" = "Benjamini & Yekutieli correction for multiple testing", + "fdr" = "False discovery rate correction for multiple testing", + "none" = "No correction for multiple testing" + ) + + lst_method_labels[[method]] +} + diff --git a/R/tbl_regression.R b/R/tbl_regression.R index 43b80752a2..c4f80418e3 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -93,7 +93,7 @@ tbl_regression.default <- function(x, conf.level = 0.95, intercept = FALSE, estimate_fun = ifelse(exponentiate, styfn_ratio(), styfn_sigfig()), - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), tidy_fun = broom.helpers::tidy_with_broom_or_parameters, add_estimate_to_reference_rows = FALSE, conf.int = TRUE, ...) { diff --git a/man/add_difference.tbl_summary.Rd b/man/add_difference.tbl_summary.Rd index d9774f8f9b..fad0bcab05 100644 --- a/man/add_difference.tbl_summary.Rd +++ b/man/add_difference.tbl_summary.Rd @@ -12,7 +12,7 @@ test.args = NULL, conf.level = 0.95, include = everything(), - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), estimate_fun = list(c(all_continuous(), all_categorical(FALSE)) ~ styfn_sigfig(), all_dichotomous() ~ function(x) ifelse(is.na(x), NA_character_, paste0(style_sigfig(x, scale = 100), "\%")), all_tests("smd") ~ styfn_sigfig()), diff --git a/man/add_p.tbl_summary.Rd b/man/add_p.tbl_summary.Rd index c14886804f..430c8d5e6a 100644 --- a/man/add_p.tbl_summary.Rd +++ b/man/add_p.tbl_summary.Rd @@ -7,7 +7,7 @@ \method{add_p}{tbl_summary}( x, test = NULL, - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), group = NULL, include = everything(), test.args = NULL, diff --git a/man/add_q.Rd b/man/add_q.Rd new file mode 100644 index 0000000000..61d08e6f7b --- /dev/null +++ b/man/add_q.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_q.R +\name{add_q} +\alias{add_q} +\title{Add multiple comparison adjustment} +\usage{ +add_q(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +a \code{gtsummary} object with a column named \code{"p.value"}} + +\item{method}{(\code{string})\cr +String indicating method to be used for p-value adjustment. Methods from +\code{\link[stats:p.adjust]{stats::p.adjust()}} are accepted. Default is \code{method='fdr'}. +Must be one of 'holm', 'hochberg', 'hommel', 'bonferroni', 'BH', 'BY', 'fdr', 'none'} + +\item{pvalue_fun}{(\code{function})\cr +Function to round and format q-values. Default is the function specified +to round the existing \code{'p.value'} column.} + +\item{quiet}{DEPRECATED} +} +\description{ +Adjustments to p-values are performed with \code{\link[stats:p.adjust]{stats::p.adjust()}}. +} +\examples{ +\dontshow{if (gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +# Example 1 ---------------------------------- +add_q_ex1 <- + trial |> + tbl_summary(by = trt, include = c(trt, age, grade, response)) |> + add_p() |> + add_q() + +# TODO: Re-add this example after `add_global_p()` migrated +# # Example 2 ---------------------------------- +# add_q_ex2 <- +# trial[c("trt", "age", "grade", "response")] |> +# tbl_uvregression( +# y = response, +# method = glm, +# method.args = list(family = binomial), +# exponentiate = TRUE +# ) |> +# add_global_p() |> +# add_q() +\dontshow{\}) # examplesIf} +} +\author{ +Daniel D. Sjoberg, Esther Drill +} diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd index eea720fd10..b07100d6c0 100644 --- a/man/tbl_regression.Rd +++ b/man/tbl_regression.Rd @@ -16,7 +16,7 @@ tbl_regression(x, ...) conf.level = 0.95, intercept = FALSE, estimate_fun = ifelse(exponentiate, styfn_ratio(), styfn_sigfig()), - pvalue_fun = styfn_pvalue(), + pvalue_fun = styfn_pvalue(digits = 1), tidy_fun = broom.helpers::tidy_with_broom_or_parameters, add_estimate_to_reference_rows = FALSE, conf.int = TRUE, diff --git a/tests/testthat/_snaps/add_q.md b/tests/testthat/_snaps/add_q.md new file mode 100644 index 0000000000..7052d59cea --- /dev/null +++ b/tests/testthat/_snaps/add_q.md @@ -0,0 +1,8 @@ +# add_q() errors with no p.value column + + Code + add_q(table1) + Condition + Error in `add_q()`: + ! There is no p-value column. `x$table_body` must have a column called "p.value". + diff --git a/tests/testthat/test-add_q.R b/tests/testthat/test-add_q.R new file mode 100644 index 0000000000..daca58087a --- /dev/null +++ b/tests/testthat/test-add_q.R @@ -0,0 +1,37 @@ +test_that("add_q() works after add_p()", { + table1 <- trial %>% + tbl_summary(by = trt) %>% + add_p(pvalue_fun = styfn_pvalue(digits = 3)) + + # check the adjusted pvalues are correct + expect_equal( + table1 |> + add_q(method = "holm") |> + getElement("table_body") |> + dplyr::pull(q.value), + p.adjust(table1$table_body$p.value) + ) + + # check the pvalue function is correctly inherited + expect_equal( + table1 |> + add_q(method = "holm") |> + as.data.frame(col_label = FALSE) |> + dplyr::pull(q.value), + p.adjust(table1$table_body$p.value) |> + style_pvalue(digits = 3) + ) +}) + +test_that("add_q() errors with no p.value column", { + table1 <- tbl_summary(trial, by = trt) + + expect_snapshot( + error = TRUE, + add_q(table1) + ) +}) + +# TODO: Add this after `tbl_uvregression()` and `add_global_p()` + +# TODO: Add this after `add_p.tbl_svysummary()` From 930fa9fdbd6b3cd17597c71693319ff9d51f64ae Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 16 May 2024 17:49:25 -0700 Subject: [PATCH 58/74] v2.0 `add_overall.tbl summary()` (#1663) * progress * progress * styler --- NAMESPACE | 2 + R/add_n.R | 6 +- R/add_overall.R | 189 ++++++++++++++++++ R/add_q.R | 23 +-- R/tbl_regression.R | 4 +- R/utils-tbl_regression.R | 9 +- man/add_overall.Rd | 26 +++ man/add_overall.tbl_summary.Rd | 75 +++++++ .../_snaps/add_overall.tbl_summary.md | 8 + tests/testthat/test-add_overall.tbl_summary.R | 94 +++++++++ tests/testthat/test-tbl_regression.R | 4 +- 11 files changed, 415 insertions(+), 25 deletions(-) create mode 100644 R/add_overall.R create mode 100644 man/add_overall.Rd create mode 100644 man/add_overall.tbl_summary.Rd create mode 100644 tests/testthat/_snaps/add_overall.tbl_summary.md create mode 100644 tests/testthat/test-add_overall.tbl_summary.R diff --git a/NAMESPACE b/NAMESPACE index 8a29c84966..864f7a26ea 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ S3method(add_difference,tbl_summary) S3method(add_n,tbl_summary) +S3method(add_overall,tbl_summary) S3method(add_p,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) @@ -12,6 +13,7 @@ export("%>%") export(.table_styling_expr_to_row_number) export(add_difference) export(add_n) +export(add_overall) export(add_p) export(add_q) export(all_categorical) diff --git a/R/add_n.R b/R/add_n.R index 4ba298d89e..c6db2ed24c 100644 --- a/R/add_n.R +++ b/R/add_n.R @@ -70,8 +70,7 @@ add_n.tbl_summary <- function(x, statistic = "{N_nonmiss}", col_label = "**N**", # calculate/grab the needed ARD results -------------------------------------- if ("add_overall" %in% names(x[["call_list"]])) { # TODO: If `add_overall()` was previously run, we can get the stats from there instead of re-calculating - } - else if (is_empty(x$inputs$by)) { + } else if (is_empty(x$inputs$by)) { # TODO: If `tbl_summary(by)` is empty, then we can grab this from `x$card%tbl_summary` x$cards$add_n <- x[["cards"]][[1]] |> @@ -80,8 +79,7 @@ add_n.tbl_summary <- function(x, statistic = "{N_nonmiss}", col_label = "**N**", .data$context %in% "missing" ) |> cards::apply_fmt_fn() - } - else { + } else { x$cards$add_n <- cards::ard_missing( data = x$inputs$data, diff --git a/R/add_overall.R b/R/add_overall.R new file mode 100644 index 0000000000..8ec5911900 --- /dev/null +++ b/R/add_overall.R @@ -0,0 +1,189 @@ +#' Add overall column +#' +#' - [`add_overall.tbl_summary()`] +#' +#' @param x (`gtsummary`)\cr +#' Object with class 'gtsummary' +#' @param ... Passed to other methods. +#' @keywords internal +#' @author Daniel D. Sjoberg +#' @export +#' +#' @seealso [`add_overall.tbl_summary()`] +add_overall <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_overall") +} + +#' Add overall column +#' +#' Adds a column with overall summary statistics to tables +#' created by `tbl_summary`, `tbl_svysummary`, `tbl_continuous` or +#' `tbl_custom_summary`. +#' +#' @param x (`tbl_summary`\`tbl_svysummary`\`tbl_continuous`\`tbl_custom_summary`)\cr +#' A stratified 'gtsummary' table +#' @param last Logical indicator to display overall column last in table. +#' Default is `FALSE`, which will display overall column first. +#' @param col_label String indicating the column label. Default is `"**Overall** \nN = {N}"` +#' @param statistic Override the statistic argument in initial `tbl_*` function. +#' call. Default is `NULL`. +#' @param digits Override the digits argument in initial `tbl_*` function +#' call. Default is `NULL`. +#' @inheritParams rlang::args_dots_empty +#' +#' @author Daniel D. Sjoberg +#' @export +#' @return A `gtsummary` of same class as `x` +#' @examples +#' # Example 1 ---------------------------------- +#' trial |> +#' tbl_summary(include = c(age, grade), by = trt) |> +#' add_overall() +#' +#' # Example 2 ---------------------------------- +#' trial |> +#' tbl_summary( +#' include = grade, +#' by = trt, +#' percent = "row", +#' statistic = ~"{p}%", +#' digits = ~1 +#' ) |> +#' add_overall( +#' last = TRUE, +#' statistic = ~"{p}% (n={n})", +#' digits = ~ c(1, 0) +#' ) +#' +#' # TODO: Add this example after `tbl_continuous()` +#' # # Example 3 ---------------------------------- +#' # tbl_overall_ex3 <- +#' # trial %>% +#' # tbl_continuous( +#' # variable = age, +#' # by = trt, +#' # include = grade +#' # ) %>% +#' # add_overall(last = TRUE) +add_overall.tbl_summary <- function(x, last = FALSE, col_label = "**Overall** \nN = {N}", + statistic = NULL, digits = NULL, ...) { + set_cli_abort_call() + check_dots_empty() + + # translating the col_label, if nothing passed by user + if (missing(col_label)) { + paste0("**", translate_text("Overall"), "** \nN = {N}") + } + + add_overall_generic( + x = x, + last = last, + col_label = col_label, + statistic = statistic, + digits = digits, + call = c(x$call_list, list(add_overall = match.call())), + calling_fun = "tbl_summary" + ) +} + +add_overall_generic <- function(x, last, col_label, statistic, digits, call, calling_fun) { + check_scalar_logical(last) + check_string(col_label, allow_empty = TRUE) + + # checking that input x has a by var + if (is_empty(x$inputs[["by"]])) { + cli::cli_abort( + "Cannot run {.fun add_overall} when original table function is not statified with {.code {calling_fun}(by)}.", + call = get_cli_abort_call() + ) + } + + # save arguments to pass to original function without `by` stratified -------- + args_overall <- x$inputs |> + utils::modifyList(list(by = NULL), keep.null = TRUE) + + # if overall row, already included in data ----------------------------------- + if (isTRUE(args_overall$overall_row)) { + args_overall$overall_row <- FALSE + } + + # update statistic/digit argument as needed ---------------------------------- + if (!is_empty(statistic)) { + args_overall$statistic <- statistic + } + if (!is_empty(digits)) { + args_overall$digits <- digits + } + + # create overall table ------------------------------------------------------- + tbl_overall <- do.call(calling_fun, args_overall) + + # merging overall results + x <- add_overall_merge(x, tbl_overall, last, col_label, calling_fun) + + x$call_list <- call + x +} + +add_overall_merge <- function(x, tbl_overall, last, col_label, calling_fun) { + # checking the original tbl_summary and the added overall, + # are the same before binding (excluding headers) + if (!identical( + select(x$table_body, c("row_type", "variable", "label")), + select(tbl_overall$table_body, c("row_type", "variable", "label")) |> as_tibble() + )) { + cli::cli_abort( + c( + "An error occured in {.fun add_overall}, and the overall statistic cannot be added.", + "Have variable labels changed since the original call to {.fun {calling_fun}}?" + ), + call = get_cli_abort_call() + ) + } + + # adding the overall cards object to the output + x[["cards"]][["add_overall"]] <- tbl_overall[["cards"]][[1]] + + # adding overall stat to the table_body data frame + x$table_body <- + dplyr::bind_cols( + x$table_body, + tbl_overall$table_body |> dplyr::select("stat_0") + ) + + # add the overall header row to the primary table + x$table_styling$header <- + dplyr::bind_rows( + x$table_styling$header, + tbl_overall$table_styling$header |> + dplyr::filter(.data$column %in% "stat_0") + ) + + x$table_styling$header %>% + dplyr::rows_update( + tbl_overall$table_styling$header %>% + dplyr::filter(.data$column %in% "stat_0"), + by = "column" + ) + + if (last == FALSE) { + x <- modify_table_body(x, dplyr::relocate, "stat_0", .before = "stat_1") + } + + # updating table_style with footnote and column header + x$table_styling$footnote <- + dplyr::bind_rows( + x$table_styling$footnote, + tbl_overall$table_styling$footnote %>% + dplyr::filter(.data$column %in% "stat_0") + ) + + # Add + x <- modify_header(x, stat_0 = col_label) + + + + x +} diff --git a/R/add_q.R b/R/add_q.R index 0ea4fa1d8c..255dc75408 100644 --- a/R/add_q.R +++ b/R/add_q.R @@ -65,16 +65,16 @@ add_q <- function(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) { get_theme_element("add_q-arg:pvalue_fun") %||% get_theme_element("pkgwide-fn:pvalue_fun") %||% # default from p-value formatting function - (dplyr::filter(x$table_styling$fmt_fun, .data$column == "p.value") |> dplyr::pull("fmt_fun") |> rev() |> getElement(1)) |> + (dplyr::filter(x$table_styling$fmt_fun, .data$column == "p.value") |> dplyr::pull("fmt_fun") |> rev() |> getElement(1)) |> as_function(arg = "pvalue_fun") # calculate the adjusted p-value --------------------------------------------- # TODO: add error handling here - q.value <- stats::p.adjust(x$table_body$p.value, method = method) + q.value <- stats::p.adjust(x$table_body$p.value, method = method) # update gtsummary table ----------------------------------------------------- x <- - modify_table_body(x, ~dplyr::mutate(.x, q.value = q.value)) |> + modify_table_body(x, ~ dplyr::mutate(.x, q.value = q.value)) |> modify_table_styling( columns = "q.value", label = paste0("**", translate_text("q-value"), "**"), @@ -97,16 +97,15 @@ add_q <- function(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) { .add_q_method_label <- function(method) { lst_method_labels <- list( - "holm" = "Holm correction for multiple testing", - "hochberg" = "Hochberg correction for multiple testing", - "hommel" = "Hommel correction for multiple testing", - "bonferroni" = "Bonferroni correction for multiple testing", - "BH" = "Benjamini & Hochberg correction for multiple testing", - "BY" = "Benjamini & Yekutieli correction for multiple testing", - "fdr" = "False discovery rate correction for multiple testing", - "none" = "No correction for multiple testing" + "holm" = "Holm correction for multiple testing", + "hochberg" = "Hochberg correction for multiple testing", + "hommel" = "Hommel correction for multiple testing", + "bonferroni" = "Bonferroni correction for multiple testing", + "BH" = "Benjamini & Hochberg correction for multiple testing", + "BY" = "Benjamini & Yekutieli correction for multiple testing", + "fdr" = "False discovery rate correction for multiple testing", + "none" = "No correction for multiple testing" ) lst_method_labels[[method]] } - diff --git a/R/tbl_regression.R b/R/tbl_regression.R index c4f80418e3..0fab4ecfc5 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -194,7 +194,7 @@ tbl_regression.default <- function(x, # TODO: Deprecate this... this was an odd choice? tidy_columns_to_report <- get_theme_element("tbl_regression-chr:tidy_columns", - default = c("conf.low", "conf.high", "p.value") + default = c("conf.low", "conf.high", "p.value") ) |> union("estimate") |> intersect(names(table_body)) @@ -213,7 +213,7 @@ tbl_regression.default <- function(x, # adding the Ns to the `x$table_styling$header` if (!rlang::is_empty(res[c("N", "N_event")] |> compact())) { res$table_styling$header <- - res[c("N","N_event")] |> + res[c("N", "N_event")] |> compact() |> dplyr::as_tibble() |> dplyr::rename_with(.fn = ~ vec_paste0("modify_stat_", .), .cols = everything()) |> diff --git a/R/utils-tbl_regression.R b/R/utils-tbl_regression.R index 2abfbdf3f4..2a6e9dcc2b 100644 --- a/R/utils-tbl_regression.R +++ b/R/utils-tbl_regression.R @@ -37,7 +37,7 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, attributes(.)[names(attributes(.)) %in% c("N_obs", "N_event", "coefficients_type", "coefficients_label")] %>% tibble::as_tibble() )} - # styler: on + # styler: on if (!"header_row" %in% names(df_tidy)) { df_tidy$header_row <- NA @@ -138,8 +138,8 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, x <- modify_table_styling(x, - columns = any_of(c("conf.low", "conf.high")), - fmt_fun = estimate_fun + columns = any_of(c("conf.low", "conf.high")), + fmt_fun = estimate_fun ) # p.value -------------------------------------------------------------------- @@ -210,7 +210,7 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, if (result$label %in% c("Beta", "exp(Beta)")) { exponentiate <- x$inputs$exponentiate result$label <- get_theme_element("tbl_regression-str:coef_header", - default = result$label + default = result$label ) } @@ -226,4 +226,3 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label, result$label <- translate_text(result$label, language) result } - diff --git a/man/add_overall.Rd b/man/add_overall.Rd new file mode 100644 index 0000000000..518da8625a --- /dev/null +++ b/man/add_overall.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_overall.R +\name{add_overall} +\alias{add_overall} +\title{Add overall column} +\usage{ +add_overall(x, ...) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +Object with class 'gtsummary'} + +\item{...}{Passed to other methods.} +} +\description{ +\itemize{ +\item \code{\link[=add_overall.tbl_summary]{add_overall.tbl_summary()}} +} +} +\seealso{ +\code{\link[=add_overall.tbl_summary]{add_overall.tbl_summary()}} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/add_overall.tbl_summary.Rd b/man/add_overall.tbl_summary.Rd new file mode 100644 index 0000000000..a902c46659 --- /dev/null +++ b/man/add_overall.tbl_summary.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_overall.R +\name{add_overall.tbl_summary} +\alias{add_overall.tbl_summary} +\title{Add overall column} +\usage{ +\method{add_overall}{tbl_summary}( + x, + last = FALSE, + col_label = "**Overall** \\nN = {N}", + statistic = NULL, + digits = NULL, + ... +) +} +\arguments{ +\item{x}{(\code{tbl_summary}\\code{tbl_svysummary}\\code{tbl_continuous}\\code{tbl_custom_summary})\cr +A stratified 'gtsummary' table} + +\item{last}{Logical indicator to display overall column last in table. +Default is \code{FALSE}, which will display overall column first.} + +\item{col_label}{String indicating the column label. Default is \code{"**Overall** \\nN = {N}"}} + +\item{statistic}{Override the statistic argument in initial \verb{tbl_*} function. +call. Default is \code{NULL}.} + +\item{digits}{Override the digits argument in initial \verb{tbl_*} function +call. Default is \code{NULL}.} + +\item{...}{These dots are for future extensions and must be empty.} +} +\value{ +A \code{gtsummary} of same class as \code{x} +} +\description{ +Adds a column with overall summary statistics to tables +created by \code{tbl_summary}, \code{tbl_svysummary}, \code{tbl_continuous} or +\code{tbl_custom_summary}. +} +\examples{ +# Example 1 ---------------------------------- +trial |> + tbl_summary(include = c(age, grade), by = trt) |> + add_overall() + +# Example 2 ---------------------------------- +trial |> + tbl_summary( + include = grade, + by = trt, + percent = "row", + statistic = ~"{p}\%", + digits = ~1 + ) |> + add_overall( + last = TRUE, + statistic = ~"{p}\% (n={n})", + digits = ~ c(1, 0) + ) + +# TODO: Add this example after `tbl_continuous()` +# # Example 3 ---------------------------------- +# tbl_overall_ex3 <- +# trial \%>\% +# tbl_continuous( +# variable = age, +# by = trt, +# include = grade +# ) \%>\% +# add_overall(last = TRUE) +} +\author{ +Daniel D. Sjoberg +} diff --git a/tests/testthat/_snaps/add_overall.tbl_summary.md b/tests/testthat/_snaps/add_overall.tbl_summary.md new file mode 100644 index 0000000000..ead3ee7339 --- /dev/null +++ b/tests/testthat/_snaps/add_overall.tbl_summary.md @@ -0,0 +1,8 @@ +# add_overall.tbl_summary() errors + + Code + add_overall(tbl_summary(mtcars)) + Condition + Error in `add_overall()`: + ! Cannot run `add_overall()` when original table function is not statified with `tbl_summary(by)`. + diff --git a/tests/testthat/test-add_overall.tbl_summary.R b/tests/testthat/test-add_overall.tbl_summary.R new file mode 100644 index 0000000000..507d18737e --- /dev/null +++ b/tests/testthat/test-add_overall.tbl_summary.R @@ -0,0 +1,94 @@ +test_that("add_overall.tbl_summary() works", { + # typical usage works + expect_error( + res <- + mtcars |> + tbl_summary( + by = am, + statistic = list(cyl = "{n}", mpg = "{mean}"), + include = c(cyl, mpg, disp) + ) |> + add_overall(), + NA + ) + expect_equal( + res |> + as.data.frame(col_labels = FALSE) |> + dplyr::select(-all_stat_cols(), stat_0), + mtcars |> + tbl_summary( + include = c(cyl, mpg, disp), + statistic = list(cyl = "{n}", mpg = "{mean}") + ) |> + as.data.frame(col_labels = FALSE) + ) + # check default header is correct + expect_equal( + res$table_styling$header |> + dplyr::filter(column == "stat_0") |> + dplyr::pull(label), + "**Overall** \nN = 32" + ) + + # we're able to modify the statistic and digits arguments + expect_error( + res <- + mtcars |> + tbl_summary( + by = am, + include = c(cyl, mpg, disp) + ) |> + add_overall( + statistic = list(cyl = "{n}", mpg = "{mean}"), + digits = mpg ~ 4 + ), + NA + ) + expect_equal( + res |> + as.data.frame(col_labels = FALSE) |> + dplyr::select(-all_stat_cols(), stat_0), + mtcars |> + tbl_summary( + include = c(cyl, mpg, disp), + statistic = list(cyl = "{n}", mpg = "{mean}"), + digits = mpg ~ 4 + ) |> + as.data.frame(col_labels = FALSE) + ) + + # we can change the column header and move the overall column + expect_error( + res <- + iris |> + tbl_summary(by = "Species") |> + add_overall(last = TRUE, col_label = "**All Species**"), + NA + ) + # check the overall column is moved to the end + expect_equal( + res |> + as.data.frame(col_label = FALSE) |> + names() |> + dplyr::last(), + "stat_0" + ) + # check header is correct + expect_equal( + res$table_styling$header |> + dplyr::filter(column == "stat_0") |> + dplyr::pull(label), + "**All Species**" + ) +}) + + +test_that("add_overall.tbl_summary() errors", { + # no stratifying variable + expect_snapshot( + error = TRUE, + tbl_summary(mtcars) |> add_overall() + ) + + # TODO: Add a test where we modify the labels after `add_stat_label()` is implemented +}) diff --git a/tests/testthat/test-tbl_regression.R b/tests/testthat/test-tbl_regression.R index 772a51a505..7947d4735d 100644 --- a/tests/testthat/test-tbl_regression.R +++ b/tests/testthat/test-tbl_regression.R @@ -2,8 +2,8 @@ mod_lm <- lm(hp ~ am, data = mtcars) mod_logistic <- glm(response ~ age + stage, trial, family = binomial) mod_poisson <- glm(count ~ age + trt, - trial |> dplyr::mutate(count = dplyr::row_number() %% 10), - family = poisson + trial |> dplyr::mutate(count = dplyr::row_number() %% 10), + family = poisson ) mod_lm_interaction <- lm(age ~ trt * grade * response, data = trial) From 2bd29cb39ec5bdd99a4d1c99a2684f60ee128b10 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 16 May 2024 21:23:30 -0700 Subject: [PATCH 59/74] progress (#1664) --- NAMESPACE | 3 + R/add_n.tbl_regression.R | 96 +++++++++++++++++ R/add_nevent.R | 100 ++++++++++++++++++ R/tbl_regression.R | 2 - man/add_n.tbl_regression.Rd | 45 ++++++++ man/add_nevent.Rd | 29 +++++ man/modify.Rd | 3 - man/tbl_regression.Rd | 7 -- tests/testthat/_snaps/add_n.tbl_regression.md | 36 +++++++ tests/testthat/test-add_n.tbl_regression.R | 51 +++++++++ .../testthat/test-add_nevent.tbl_regression.R | 54 ++++++++++ 11 files changed, 414 insertions(+), 12 deletions(-) create mode 100644 R/add_n.tbl_regression.R create mode 100644 R/add_nevent.R create mode 100644 man/add_n.tbl_regression.Rd create mode 100644 man/add_nevent.Rd create mode 100644 tests/testthat/_snaps/add_n.tbl_regression.md create mode 100644 tests/testthat/test-add_n.tbl_regression.R create mode 100644 tests/testthat/test-add_nevent.tbl_regression.R diff --git a/NAMESPACE b/NAMESPACE index 864f7a26ea..44fde3354c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,9 @@ # Generated by roxygen2: do not edit by hand S3method(add_difference,tbl_summary) +S3method(add_n,tbl_regression) S3method(add_n,tbl_summary) +S3method(add_nevent,tbl_regression) S3method(add_overall,tbl_summary) S3method(add_p,tbl_summary) S3method(as.data.frame,gtsummary) @@ -13,6 +15,7 @@ export("%>%") export(.table_styling_expr_to_row_number) export(add_difference) export(add_n) +export(add_nevent) export(add_overall) export(add_p) export(add_q) diff --git a/R/add_n.tbl_regression.R b/R/add_n.tbl_regression.R new file mode 100644 index 0000000000..99dadfbe33 --- /dev/null +++ b/R/add_n.tbl_regression.R @@ -0,0 +1,96 @@ +#' Add N to regression table +#' +#' @param x (`tbl_regression`\`tbl_uvregression`)\cr +#' a `tbl_regression` or `tbl_uvregression` table +#' @param location (`character`)\cr +#' location to place Ns. Select one or more of `c('label', 'level')`. +#' Default is `'label'`. +#' +#' When `"label"` total Ns are placed +#' on each variable's label row. When `"level"` level counts are placed on the +#' variable level for categorical variables, and total N on the variable's label +#' row for continuous. +#' @inheritParams rlang::args_dots_empty +#' +#' @name add_n.tbl_regression +#' @examples +#' # TODO: Re-add after tbl_uvregression() is added +#' # # Example 1 ---------------------------------- +#' # add_n.tbl_regression_ex1 <- +#' # trial %>% +#' # select(response, age, grade) %>% +#' # tbl_uvregression( +#' # y = response, +#' # method = glm, +#' # method.args = list(family = binomial), +#' # hide_n = TRUE +#' # ) %>% +#' # add_n(location = "label") +#' +#' # Example 2 ---------------------------------- +#' glm(response ~ age + grade, trial, family = binomial) %>% +#' tbl_regression(exponentiate = TRUE) %>% +#' add_n(location = "level") +NULL + +#' @rdname add_n.tbl_regression +#' @export +add_n.tbl_regression <- function(x, location = "label", ...) { + set_cli_abort_call() + check_dots_empty() + updated_call_list <- c(x$call_list, list(add_nevent = match.call())) + + # process inputs ------------------------------------------------------------- + location <- arg_match(location, values = c("label", "level"), multiple = TRUE) + + if ("level" %in% location && !"n_obs" %in% x$table_styling$header$column) { + cli::cli_abort( + "Reporting N on level rows is not available for this model type.", + call = get_cli_abort_call() + ) + } + if ("label" %in% location && !"N_obs" %in% x$table_styling$header$column) { + cli::cli_abort( + "Reporting N on label rows is not available for this model type.", + call = get_cli_abort_call() + ) + } + + x$table_body$stat_n <- NA_integer_ + if ("N_obs" %in% names(x$table_body)) { + x$table_body$stat_n <- ifelse(x$table_body$row_type == "label", + x$table_body$N_obs %>% as.integer(), + x$table_body$stat_n + ) + } + if ("n_obs" %in% names(x$table_body)) { + x$table_body$stat_n <- ifelse(x$table_body$row_type == "level", + x$table_body$n_obs %>% as.integer(), + x$table_body$stat_n + ) + } + x <- + x |> + modify_table_body( + mutate, + stat_n = + dplyr::case_when( + !"level" %in% .env$location & .data$row_type %in% "level" ~ NA_integer_, + !"label" %in% .env$location & .data$row_type %in% "label" & + .data$var_type %in% c("categorical", "dichotomous") ~ NA_integer_, + TRUE ~ .data$stat_n + ) + ) |> + modify_table_body(dplyr::relocate, "stat_n", .after = "label") |> + modify_table_styling( + columns = all_of("stat_n"), + label = "**N**", + hide = FALSE, + fmt_fun = styfn_number() + ) + + # fill in the Ns in the header table modify_stat_* columns + x <- .fill_table_header_modify_stats(x) + x$call_list <- updated_call_list + x +} diff --git a/R/add_nevent.R b/R/add_nevent.R new file mode 100644 index 0000000000..a673ac07a7 --- /dev/null +++ b/R/add_nevent.R @@ -0,0 +1,100 @@ +#' Add p-values +#' +#' - [`add_nevent.tbl_regression()`] +#' +#' @param x (`gtsummary`)\cr +#' Object with class 'gtsummary' +#' @param ... Passed to other methods. +#' @keywords internal +#' @author Daniel D. Sjoberg +#' @export +#' +#' @seealso [`add_p.tbl_summary()`] +add_nevent <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_nevent") +} + + +#' @export +#' @rdname add_nevent +add_nevent.tbl_regression <- function(x, location = "label", ...) { + set_cli_abort_call() + check_dots_empty() + updated_call_list <- c(x$call_list, list(add_nevent = match.call())) + + # process inputs ------------------------------------------------------------- + location <- arg_match(location, values = c("label", "level"), multiple = TRUE) + + if ("level" %in% location && !"n_event" %in% x$table_styling$header$column) { + cli::cli_abort( + "Reporting event N on level rows is not available for this model type.", + call = get_cli_abort_call() + ) + } + if ("label" %in% location && !"N_event" %in% x$table_styling$header$column) { + cli::cli_abort( + "Reporting event N on label rows is not available for this model type.", + call = get_cli_abort_call() + ) + } + + x$table_body$stat_nevent <- NA_integer_ + if ("N_event" %in% names(x$table_body)) { + x$table_body$stat_nevent <- ifelse(x$table_body$row_type == "label", + x$table_body$N_event %>% as.integer(), + x$table_body$stat_nevent + ) + } + if ("n_event" %in% names(x$table_body)) { + x$table_body$stat_nevent <- ifelse(x$table_body$row_type == "level", + x$table_body$n_event %>% as.integer(), + x$table_body$stat_nevent + ) + } + + x <- + modify_table_body( + x, + dplyr::mutate, + stat_nevent = + dplyr::case_when( + !"level" %in% .env$location & .data$row_type %in% "level" ~ NA_integer_, + !"label" %in% .env$location & .data$row_type %in% "label" & + .data$var_type %in% c("categorical", "dichotomous") ~ NA_integer_, + TRUE ~ .data$stat_nevent + ) + ) |> + modify_table_body(dplyr::relocate, "stat_nevent", .before = "estimate") |> + modify_table_styling( + columns = all_of("stat_nevent"), + label = "**Event N**", + hide = FALSE, + fmt_fun = styfn_number() + ) + + # fill in the Ns in the header table modify_stat_* columns + x <- .fill_table_header_modify_stats(x) + # add call list and return x + x$call_list <- updated_call_list + x +} + +# this function is used to fill in missing values in the +# x$table_styling$header$modify_stat_* columns +.fill_table_header_modify_stats <- function(x, + modify_stats = + c("modify_stat_N", "modify_stat_N_event", + "modify_stat_N_unweighted")) { + modify_stats <- + x$table_styling$header |> + select(any_of(modify_stats) & where(\(x) dplyr::n_distinct(x, na.rm = TRUE) == 1L)) %>% + names() + + x$table_styling$header <- + x$table_styling$header %>% + tidyr::fill(any_of(modify_stats), .direction = "downup") + + return(x) +} diff --git a/R/tbl_regression.R b/R/tbl_regression.R index 0fab4ecfc5..d3bb59fac5 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -63,9 +63,7 @@ #' to print the random components. #' #' @author Daniel D. Sjoberg -#' @seealso See tbl_regression \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{vignette} for detailed examples #' -#' @family tbl_regression tools #' @name tbl_regression #' @return A `tbl_regression` object #' diff --git a/man/add_n.tbl_regression.Rd b/man/add_n.tbl_regression.Rd new file mode 100644 index 0000000000..6df1345fe4 --- /dev/null +++ b/man/add_n.tbl_regression.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_n.tbl_regression.R +\name{add_n.tbl_regression} +\alias{add_n.tbl_regression} +\title{Add N to regression table} +\usage{ +\method{add_n}{tbl_regression}(x, location = "label", ...) +} +\arguments{ +\item{x}{(\code{tbl_regression}\\code{tbl_uvregression})\cr +a \code{tbl_regression} or \code{tbl_uvregression} table} + +\item{location}{(\code{character})\cr +location to place Ns. Select one or more of \code{c('label', 'level')}. +Default is \code{'label'}. + +When \code{"label"} total Ns are placed +on each variable's label row. When \code{"level"} level counts are placed on the +variable level for categorical variables, and total N on the variable's label +row for continuous.} + +\item{...}{These dots are for future extensions and must be empty.} +} +\description{ +Add N to regression table +} +\examples{ +# TODO: Re-add after tbl_uvregression() is added +# # Example 1 ---------------------------------- +# add_n.tbl_regression_ex1 <- +# trial \%>\% +# select(response, age, grade) \%>\% +# tbl_uvregression( +# y = response, +# method = glm, +# method.args = list(family = binomial), +# hide_n = TRUE +# ) \%>\% +# add_n(location = "label") + +# Example 2 ---------------------------------- +glm(response ~ age + grade, trial, family = binomial) \%>\% + tbl_regression(exponentiate = TRUE) \%>\% + add_n(location = "level") +} diff --git a/man/add_nevent.Rd b/man/add_nevent.Rd new file mode 100644 index 0000000000..267447e9b3 --- /dev/null +++ b/man/add_nevent.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_nevent.R +\name{add_nevent} +\alias{add_nevent} +\alias{add_nevent.tbl_regression} +\title{Add p-values} +\usage{ +add_nevent(x, ...) + +\method{add_nevent}{tbl_regression}(x, location = "label", ...) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +Object with class 'gtsummary'} + +\item{...}{Passed to other methods.} +} +\description{ +\itemize{ +\item \code{\link[=add_nevent.tbl_regression]{add_nevent.tbl_regression()}} +} +} +\seealso{ +\code{\link[=add_p.tbl_summary]{add_p.tbl_summary()}} +} +\author{ +Daniel D. Sjoberg +} +\keyword{internal} diff --git a/man/modify.Rd b/man/modify.Rd index cde14634cf..4643a98215 100644 --- a/man/modify.Rd +++ b/man/modify.Rd @@ -115,9 +115,6 @@ modify_ex3 <- \seealso{ Other tbl_summary tools: \code{\link{tbl_summary}()} - -Other tbl_regression tools: -\code{\link{tbl_regression}()} } \author{ Daniel D. Sjoberg diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd index b07100d6c0..11e37ec48a 100644 --- a/man/tbl_regression.Rd +++ b/man/tbl_regression.Rd @@ -111,13 +111,6 @@ glm(response ~ age + grade, trial, family = binomial()) \%>\% tbl_regression(exponentiate = TRUE) \dontshow{\}) # examplesIf} } -\seealso{ -See tbl_regression \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{vignette} for detailed examples - -Other tbl_regression tools: -\code{\link{modify}} -} \author{ Daniel D. Sjoberg } -\concept{tbl_regression tools} diff --git a/tests/testthat/_snaps/add_n.tbl_regression.md b/tests/testthat/_snaps/add_n.tbl_regression.md new file mode 100644 index 0000000000..0219d8dbca --- /dev/null +++ b/tests/testthat/_snaps/add_n.tbl_regression.md @@ -0,0 +1,36 @@ +# add_n.tbl_regression + + Code + res %>% as.data.frame() + Output + **Characteristic** **N** **log(OR)** **95% CI** **p-value** + 1 Grade 183 + 2 I + 3 II -0.16 -0.94, 0.61 0.7 + 4 III 0.01 -0.74, 0.77 >0.9 + 5 Age 183 0.02 0.00, 0.04 0.10 + +--- + + Code + res %>% as.data.frame() + Output + **Characteristic** **N** **log(OR)** **95% CI** **p-value** + 1 Grade + 2 I 65 + 3 II 58 -0.16 -0.94, 0.61 0.7 + 4 III 60 0.01 -0.74, 0.77 >0.9 + 5 Age 183 0.02 0.00, 0.04 0.10 + +--- + + Code + res %>% as.data.frame() + Output + **Characteristic** **N** **log(OR)** **95% CI** **p-value** + 1 Grade 183 + 2 I 65 + 3 II 58 -0.16 -0.94, 0.61 0.7 + 4 III 60 0.01 -0.74, 0.77 >0.9 + 5 Age 183 0.02 0.00, 0.04 0.10 + diff --git a/tests/testthat/test-add_n.tbl_regression.R b/tests/testthat/test-add_n.tbl_regression.R new file mode 100644 index 0000000000..cd39a1f2f6 --- /dev/null +++ b/tests/testthat/test-add_n.tbl_regression.R @@ -0,0 +1,51 @@ +test_that("add_n.tbl_regression() works", { + tbl <- + glm(response ~ grade + age, trial, family = binomial) %>% + tbl_regression() + + # total N added to table is accurate + expect_error( + res <- tbl |> add_n(), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_n |> + na.omit() |> + unique(), + tidyr::drop_na(trial, response, grade, age) |> + nrow() |> + as.character() + ) + + # N added to levels is accurate + expect_error( + res <- tbl |> add_n(location = "level"), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_n |> + na.omit(), + tidyr::drop_na(trial, response, grade, age) |> + with(table(grade)) |> + as.integer() %>% + c(sum(.)) |> + as.character(), + ignore_attr = TRUE + ) + + # N added to levels and labels is accurate + expect_error( + res <- tbl |> add_n(location = c("label", "level")), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_n |> + na.omit(), + tidyr::drop_na(trial, response, grade, age) |> + with(table(grade)) |> + as.integer() %>% + {c(sum(.), ., sum(.))} |> # styler: off + as.character(), + ignore_attr = TRUE + ) +}) diff --git a/tests/testthat/test-add_nevent.tbl_regression.R b/tests/testthat/test-add_nevent.tbl_regression.R new file mode 100644 index 0000000000..ee0c9aeac0 --- /dev/null +++ b/tests/testthat/test-add_nevent.tbl_regression.R @@ -0,0 +1,54 @@ +test_that("add_nevent.tbl_regression() works", { + tbl <- + glm(response ~ grade + age, trial, family = binomial) %>% + tbl_regression() + + # total N added to table is accurate + expect_error( + res <- tbl |> add_nevent(), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_nevent |> + na.omit() |> + unique(), + tidyr::drop_na(trial, response, grade, age) |> + dplyr::filter(response == 1) |> + nrow() |> + as.character() + ) + + # N added to levels is accurate + expect_error( + res <- tbl |> add_nevent(location = "level"), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_nevent |> + na.omit(), + tidyr::drop_na(trial, response, grade, age) |> + dplyr::filter(response == 1) |> + with(table(grade)) |> + as.integer() %>% + c(sum(.)) |> + as.character(), + ignore_attr = TRUE + ) + + # N added to levels and labels is accurate + expect_error( + res <- tbl |> add_nevent(location = c("label", "level")), + NA + ) + expect_equal( + as.data.frame(res, col_label = FALSE)$stat_nevent |> + na.omit(), + tidyr::drop_na(trial, response, grade, age) |> + dplyr::filter(response == 1) |> + with(table(grade)) |> + as.integer() %>% + {c(sum(.), ., sum(.))} |> # styler: off + as.character(), + ignore_attr = TRUE + ) +}) From 82ef26bdb7504ce8b68ddad21c3084b2a83a9fd7 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 17 May 2024 08:27:37 -0700 Subject: [PATCH 60/74] V2.0 adding pkgdown (#1665) * adding pkgdown yaml * doc update --- NAMESPACE | 1 - R/default_stat_labels.R | 5 +- man/default_stat_labels.Rd | 4 +- pkgdown/_pkgdown.yml | 190 +++++++++++++++++++ pkgdown/favicon/apple-touch-icon-120x120.png | Bin 0 -> 9602 bytes pkgdown/favicon/apple-touch-icon-152x152.png | Bin 0 -> 13309 bytes pkgdown/favicon/apple-touch-icon-180x180.png | Bin 0 -> 16417 bytes pkgdown/favicon/apple-touch-icon-60x60.png | Bin 0 -> 4421 bytes pkgdown/favicon/apple-touch-icon-76x76.png | Bin 0 -> 5679 bytes pkgdown/favicon/apple-touch-icon.png | Bin 0 -> 16417 bytes pkgdown/favicon/favicon-16x16.png | Bin 0 -> 1602 bytes pkgdown/favicon/favicon-32x32.png | Bin 0 -> 2363 bytes pkgdown/favicon/favicon.ico | Bin 0 -> 15086 bytes 13 files changed, 192 insertions(+), 8 deletions(-) create mode 100644 pkgdown/_pkgdown.yml create mode 100644 pkgdown/favicon/apple-touch-icon-120x120.png create mode 100644 pkgdown/favicon/apple-touch-icon-152x152.png create mode 100644 pkgdown/favicon/apple-touch-icon-180x180.png create mode 100644 pkgdown/favicon/apple-touch-icon-60x60.png create mode 100644 pkgdown/favicon/apple-touch-icon-76x76.png create mode 100644 pkgdown/favicon/apple-touch-icon.png create mode 100644 pkgdown/favicon/favicon-16x16.png create mode 100644 pkgdown/favicon/favicon-32x32.png create mode 100644 pkgdown/favicon/favicon.ico diff --git a/NAMESPACE b/NAMESPACE index 44fde3354c..8f065bb571 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -35,7 +35,6 @@ export(assign_tests) export(brdg_summary) export(card_summary) export(contains) -export(default_stat_labels) export(ends_with) export(everything) export(last_col) diff --git a/R/default_stat_labels.R b/R/default_stat_labels.R index f72e75a432..2d7efcbda6 100644 --- a/R/default_stat_labels.R +++ b/R/default_stat_labels.R @@ -1,10 +1,7 @@ #' Default Statistics Labels #' #' @return named list -#' @export -#' -#' @examples -#' default_stat_labels() +#' @keywords internal default_stat_labels <- function() { list( # standard summary stat labels diff --git a/man/default_stat_labels.Rd b/man/default_stat_labels.Rd index 32fb65b045..f4483c8b86 100644 --- a/man/default_stat_labels.Rd +++ b/man/default_stat_labels.Rd @@ -12,6 +12,4 @@ named list \description{ Default Statistics Labels } -\examples{ -default_stat_labels() -} +\keyword{internal} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml new file mode 100644 index 0000000000..3702959890 --- /dev/null +++ b/pkgdown/_pkgdown.yml @@ -0,0 +1,190 @@ +url: https://www.danieldsjoberg.com/gtsummary/ + +template: + params: + docsearch: + api_key: fd7c21cad87500b8877c475ed3a4cece + index_name: gtsummary + ganalytics: UA-145876596-1 + bootswatch: flatly +development: + mode: auto + version_label: default + +authors: + Daniel D. Sjoberg: + href: "https://www.danieldsjoberg.com/" + Emily C. Zabor: + href: "http://www.emilyzabor.com/" + Jessica Lavery: + href: "http://www.jessicalavery.com/" + Joseph Larmarange: + href: "https://joseph.larmarange.net/" + +navbar: + type: default + left: + - icon: fa-home + href: index.html + - text: Reference + href: reference/index.html + - text: Articles + menu: + # - text: "tbl_summary() tutorial" + # href: articles/tbl_summary.html + # - text: "tbl_regression() tutorial" + # href: articles/tbl_regression.html + # - text: "inline_text() tutorial" + # href: articles/inline_text.html + # - text: "gtsummary + Quarto/Rmarkdown" + # href: articles/rmarkdown.html + # - text: "gtsummary + Shiny" + # href: articles/shiny.html + # - text: "gtsummary + themes" + # href: articles/themes.html + - text: "cheat sheet" + href: https://raw.githubusercontent.com/rstudio/cheatsheets/main/gtsummary.pdf + # - text: "FAQ + gallery" + # href: articles/gallery.html + - text: News + href: news/index.html + right: + - icon: fa-github fa-lg + href: https://github.com/ddsjoberg/gtsummary + +reference: + - title: Data Summary Tables + - subtitle: Standard Summary Tables + - contents: + - tbl_summary + - add_p.tbl_summary + - add_q + - add_overall.tbl_summary + - add_difference.tbl_summary + - add_n.tbl_summary + # - add_ci + # - add_stat_label + # - add_stat + # - separate_p_footnotes + # - subtitle: Cross Tables + # - contents: + # - tbl_cross + # - add_p.tbl_cross + # - subtitle: Continuous Variable Summary + # - contents: + # - tbl_continuous + # - add_overall + # - add_p.tbl_continuous + # - subtitle: Time-to-event Summary Tables + # - contents: + # - tbl_survfit + # - add_p.tbl_survfit + # - add_n.tbl_survfit + # - add_nevent.tbl_survfit + # - add_q + # - subtitle: Survey Design Summary Tables + # - contents: + # - tbl_svysummary + # - add_p.tbl_svysummary + # - add_q + # - add_overall.tbl_svysummary + # - add_difference + # - add_ci + # - add_n.tbl_svysummary + # - add_stat_label + # - add_stat + # - separate_p_footnotes + # - subtitle: Custom Summary Tables + # - contents: + # - tbl_custom_summary + # - add_overall + # - continuous_summary + # - proportion_summary + # - ratio_summary + + - title: Regression Model Summary Tables + - contents: + - tbl_regression + # - tbl_uvregression + # - add_global_p + - add_n.tbl_regression + - add_nevent.tbl_regression + # - combine_terms + # - add_glance + # - add_q + # - add_significance_stars + # - add_vif + # - plot + + # - title: Inline Reporting + # - contents: + # - inline_text.tbl_summary + # - inline_text.tbl_regression + # - inline_text.tbl_uvregression + # - inline_text.tbl_cross + # - inline_text.tbl_survfit + # - inline_text.gtsummary + + - title: Output Types + - contents: + - as_gt + # - as_flex_table + # - as_kable + # - as_kable_extra + # - as_hux_table + - as_tibble.gtsummary + + # - title: Other Functions + # - subtitle: Merge, Stack, Stratify, or Split Summary Tables + # - contents: + # - tbl_merge + # - tbl_stack + # - tbl_strata + # - tbl_split + # - tbl_butcher + - subtitle: Style Summary Tables + - contents: + - modify + # - bold_italicize_labels_levels + # - bold_p + # - sort_filter_p + # - remove_row_type + - subtitle: Style/Format Numeric Vectors + - contents: + - style_percent + - style_pvalue + - style_sigfig + - style_ratio + - style_number + - styfn + # - subtitle: Themes + # - contents: + # - set_gtsummary_theme + # - theme_gtsummary + - subtitle: Advanced modifiers + - contents: + - modify_table_styling + - modify_table_body + - modify_column_hide + # - modify_column_alignment + - modify_fmt_fun + - modify_column_merge + # - modify_column_indent + - subtitle: Select Helpers + - contents: + - select_helpers + # - subtitle: Custom Tidiers + # - contents: + # - custom_tidiers + - subtitle: ARD Constructors + - contents: + - starts_with("card_") + + - subtitle: Construction Helpers + - contents: + - starts_with("assign_") + - starts_with("brdg_") + + - subtitle: Data + - contents: + - trial diff --git a/pkgdown/favicon/apple-touch-icon-120x120.png b/pkgdown/favicon/apple-touch-icon-120x120.png new file mode 100644 index 0000000000000000000000000000000000000000..603861f79268c8c965f85351130bf28976958375 GIT binary patch literal 9602 zcmZ{~Wl)?=&@Q~o;u_pxae})AcXzko4vV`i5E2M337X)60KtOm;_kuS0t9zk;Nz*U z-c$9~sZ;mN^j%X|Up+O`Jv~13yZ-q*0<=Me%jH|aoQFV6R>{RC;&NTs1GRt2owkV znunURfLJVSEbe@?>zz}AY|Y5+hW0{{Sx1OV<|UgbUj zpp6Ou5*h*kBIy7CF=XDDI_VXQY^9p=fv3E$UA z6mKOpIh1V-5H2e~``XbA0HEbnl9kf+UpoF4;B9K~ZBOEKwqUwrsq)61aZvEt(4+QiVkwB53n>$Q;Eps>f&H4HC4h5y}zYsdXiKFgIG zn*h82y4szFgZ5fg3f2NpO#U8$;$+NE!!B*1#L(01TWX-d2DurBJIP&g0Oc0#)C4gf z4CrBs(?;lVJaQfm0^VA0ybq83`+FCLk~~$DZKk8b63s0rypaDlNSxgm;2 zUAY?NDG8nd+;Q;Q9dVd1mr?O{a}n1t{~(3Fi@v%LO#V*QqAAs}0T9^ukR%89u%Qt| z&Y};Ghc!YaxDw9!x=C7*NUa5v%5yd7R32Ml*x;aiU`Q8$0#JnHPwmb$N#_5Nts3Kw z>P%&WKF6dDx$+&3Khv4khBjY}Ilua5i_HXKaBdluDE4&TkB6|oD3rH<6d>t(I z$OPtJ1q$BAAsEm+1(R!1I!xohsSfr^!Z#N&FDej)U~10EDwl2+p?O1GXKY(PK81^u zq-VQa<`hd3x+5#@dW5My&eQz#;LmcQ@>JiBx84q_w_349Z#uZJ?Zz@gPL3H5(suRG?-4&MSx|(xecLEk1I-9(O9Iih%K`o}|sb?NSU!K(F2tl){_?p*f>3i`RT|Oui zu5b(S9X2nqFnYccFSWI03D5R6zkiRK==O zU^@5hc)s&FlbpG{;Rb050XZi5voU|C_>;eH|fBe*`3d2mu6D9^8YM7>Uy1imNsNNlO303$+s4jaS)W1HdLhW zWV<7>Vbqc;GMM3oBrFH@djzW6ernaQ3wjJ%Nl;yKm65lwim1sb?Y4R2PjRrv#0+)H z;)a57wn@n$)^#-=;?8-)(65SrjLnv9IE|{=OxsKODV&Tcew58I8ap-TCrMJqn!<*p zod)Z-%#0H1ZH3_4c6WDOs`dr*i!rpug;1(O`6C@gjYK|_(D;x04yBE5CP6` zMq`20eA0biVZ{d0|EgzrNX&-A>10OC?r22#qlISYqu9hO(rr$-3a`c203PC$NDfLA zo}1V(GIi>uZ{j>@?zx~P5*cp|&0SJ&oMk9Af&?&Ov{y)tbVKr!^Eu@+>!8owax&*5 zCqXB+FnR?udt;@85uu~e^!9D-pa^2o|6p1`&^T!>-t5cW4P6aP zVV4(9*>b-u-+e2%SG8{t$fO{G~IPg`gY7DLU$eZ#xSz3KJiq@%_` zOp~Pgni@1C0h;CRS~iLShC?A6Gn4_}YC7y1<@8~Z*sPClzVHi7WgrnX1$+==!$<*f zWK&UWMaB0l^E%$*_T$de^%D@d1_`3CSN7Y(-qStWS=3sSeb+rSMMtkIfoc>k9Nwc= za01*aD{9i`Ct?@G6lC05c;$7>NJsX*Oa&Xg#kywDHIQRw#lnwY`XEj86)6FfSs}xd zSuBy9U+$c-&GgYh;%nZMMMSu2O6>#Nn2OAw2^?JZ8b-chQ(~)KqWLzOe$DQ7@7uqd zO^3C~Xa)A+P7~_%_f&#m5DM!GCOI7>{~fGb5T{2dj2*=-LH=09yg7fU`Pc_zMUS=I zp_DVfO;nZM#hTRPFx<+>{caFIIe^^!P=@Sc5;4m2(!^oIgB=n=n$UoA);&(ua4I6R z+<1Ho2prbm_p3L+8?vLE^LJCYHqRFNvkxVE;7LKd&Q`nU zypaY>f#0@OExZXo|FE`c$07yhMgM_hMBs9Pb^!LK=^(S!pOKtL(YF$pE19))$C0~w zdbq9m;_^Z+d(e#*O*2ZGZyo{gm{b=-0~I!b8%<1{cbHhVKP%#@y&aJZ%%&8*Tp3y$ zv8H@2lF9;O4Ht!oGLiVP1lsL$%J3CxBM0+_?So}X&o(_TGdl{9>VF_5aGDqwBD zxp^fyxHekqZm&z0eUB5E1R%#{q9Jxo!R9)nW##dIWq-0^5V5n_KUNBrs52S0{s{bo zB-7CM)pgY+sN++8dAWyKv@F}#x-_r85pt4$*yk%h%%zL5_3Eu7DLxyf=`Z*`K702~ zLW7dLNKA>*VS0bxRRwyy9qzGX^e8`=d^5SWoGo4#Vy_XnjIqj}8Aoo?RvmY7ac1=D z7Oq6&oIYWFNIBlW57I|#;Yj=X(a_J4Jzj6uC6H~r zI{QbZW89{9e%ml(=+fJFq0BRhZ!Lrd?#4-AI%hW*1(;>UWb&!`DO-m@#6sVOniAWa zT5pM8&NMiW;oUC_-vj?G&gcsq27dgKJtRcPq`@#By8S%_>*?u$g2T^jU!&+}8M^gi zGga}SGWv>p2!8JKpz+qDRoyW~E14ic_!n~8{9&>n!e(H8gibzyN|v`CeOB7T{ZJg{*>NUJo~F6FH%M5GvvC zkp@!D@U9mZ`Qp^SV_3aINc?KfXx-{9!igTC8%$FX@P5PO$-#H{p& z_4i8OujC9$tDlENRk~$KR=;r;Vzd7fG z&ggqCje>1xV^4{+dlWYo0Ym^ zHqZL_y3(HLdL#o@A~AnafiiAGMMW%^nxa!%NA0-@{*h0hcVge+;SE{#?&4myAR0y~ ze+W(VoL1TxVg724<(~H|tdF>(E<{RXS4hJ})KTo>(|F|zoO*r@Vx-?z!BzxLxAnMF zjCiEl&ubJMd*=qR>}er$S?>2SGbMI%DrnpFVGrI*Z#AqQrO{`kUh&C)P2=U{N7L3Q zKl`?J{(zG1b@JJldBb0B_ol?H&0`05;mBzb6eD(qXmF4*={cWrgg5xaot2l=FRzL-1h15X9cxiWW-(lrHnm=c$hMdU`4f-m^Nx~$SjcCrL#O-6 z$8;SN{5}uU6)4=-EPX`qPtDPghzPd#REv0^zJ3%Pk)Dq)Nom3tBYG6{#4{Hxy+Dz9 z?y%p{vE|9pIR7^13)6Nnm<8K;&sKR$BhKwM0_!9(z1pktF7jUhaP~5zXWHseDX)W% z4-a_G%a^M%HF(P+-u}>aanBsp{!P%SS%22-ETa}T8F)Ubw)TynnP4up_(ER_KZj*u zEIavdxyv%PmJz1Ar7!4c!$5>WM&1B143|_&M&K$|h) zVjcyXno?*ofG6Ool6ae6#h7K~t7qQY+Bg|^aDnUA2KN`fdIhoW64Y%KO0>C{Rd1u;@FuHCAupY;?DyGU8eihkTW z5vK~MOSR!q@zQx)ZeUR3WXqry&#kOXFKbHtno#hS6_l`rbagRiT#!v~b5!i@;_TkR z@TaVH$m$W^%RtvZbaL8~d2DKE>FxO&<(xMiU~gQ)>~-Gm8DxJKpCwN$al0E`EoV9P zw~x)H@ZCS6u$ovC|1VkhQfp`%;ab`{GdSxT)YKK{v@9|66LRCVqp>)-n1a7}n=y@W z$qm;Lf-J}-pt!+N$>W$v$cue`Uq0fZFpa$^JisnB*>7kz$OrkIcyjgVBys2@0t>n* zMocdnLNg#I+W-^44iXLclYw9RgZKP!e`AM7a;sGU66;q3_mQzNZy%f)U#_kbv3B?) zXQKPIk6PQmj{$shU#C}>OU|+|WY7l2idMTA%IQv$#T?PqqL7;~?@KNRu`~kZQycR} z$ZasxP&or_vwhKQlumnYOWr|=wb*ag!Ga|yY9Gvt8eNNGQAj&?`Y_sh2l++VXCyRU z-oZ{@?=$3%n`^Pg-tC`#r>)jMP0Yy{32HOu39Mfetik(P3ry}<&B20>h7a5Q>JxVP z5+^p{9XC%=D8%SE?yPvlCS!R_$@^DqJK(0S@Org%D~-u3$AnL{6R+%0r6n)U}osk$^F{1$-~18tN2Ymp{@bz z#^#qbeZ9BBmPVR-qztQ@fm@6Jjy<&{SKg)&anQqP=s9kAmn6p0AChweQH!Z1Vw!x@ z@5N(;MtNLsX(hE$i=vptpO6XO+*7bPU`&hG3G5R(6o^JxEi}@0-W78{_!Kk>K4nus zE$7c;V%yBEJjJL~JUpcQ*7u%N;9$i{9y2tANmj`~(osiN zl3AmVL>tsv6c6cx+G~-V39bY$YXCSgq9+r}DOQUaC#}qp8^P2ArZ)SkVk0$aiNq=h zl=&$v^mOXVeYp9E*RQHJo6Nefz{FfE10zTLdp(}V9-sBmlNR%<9W_M)zcE<-za*+K zq8N2foh#yK=gw&QK1DL=a^%`*8HnV^nJ!${j<^Ez`GS}LOpgmjMuEwPl%XT)lh)2v z4~n^$>-X_kJkZo|YZTtaO`68`h9ULa92WIvV;Z126!y){cvOBdZ(9*wDce$uxQ;r~ zIOojv4QF~*LOQ#AQITmcR?@;FC+!YCM99CZs!rVKs?9 zhr+jtju|P5StRPhiBAvt36$$i_PMWNS*+J3-*Em$b zzrfq@=fgWt#m3R7A#c`YhGxHEQf*8LW8ldWLCF2q_1@w+q$qMd9)64k?is?@amI<_}$n0vEobh@2V}Xt<#y$O}~4t==^hm^qI<& zMXpt46%@mEzmr8zzs&cHl3-zDg;#|oW=V0%tZc}Ya7BLOuSyFDpcx`~?$15WAUpvo zXPjE!1z8nM9#OLLngxnF*CBUiQ?*)GYU z+j*GLx(qJS65_WxNoVF{9l0dBpBnXa=RvD=H$bMMcQrS6z=LzyEVQ+uZEO+m$c@S* z(sLRU+Wsx2AUymfCBFcf+GusaYe!crARc^=ceGgF>K9|{LAvC{Ygn5mSN0>UH>iw- z^|CEEl&=tAUu*P+I7j~7L9g&FvXxY|wIUxxQvbqG>4ABxArtj)VBi_L*I3CL1*E=n z8otF!8LKczM-NbRuceNTlDvp5fK4_VEz5{bg}ViHI;eezX}Zm9heuI$05@81yAC3| z!FbVhBdePj!EpJ;;T?%YcOCW5tnzbw>U&LMUi|$`p0NsQwsp?PTwyXLhMkj+6E!YK zr`@SwNm3~e3q2=V4N1&Y-2Gb6$I|ATK_%z-CSNpTvvbC}v5mI`ePkG>RpPCf%@(fA zWcs}Q_0~HlA-0KA{n&7J^f6`>@;z}&OoAL?;?rmcNnYBdt0vEywcbW@C z4h>#K_jE;tIEbLT4wttH5Ra4HXw}s0U4Fa}dVPm!?cn=m9Cj|&1(Ae5H2xT?QVsj4 z7FNamWcXQk)V%IR5dlfV_|0vueE-7nkJZLepY>0j@#h{px$klBj!J%15o5zPHBooa zKaA!Dn${2;5B^4O7CYsOgk$oQJ>wm8?~O^efrOt1M)Pj+CHt4va;p?pv}2qqACeDs z6Kds^bcvSZf_M1uIFzuo>737fUg{N1srf?6P@b81D!=o&J|iy@=PJ~j=kkGZ3N}DAS*yQ-)MNiq1gnMhLOJV4q zr3H=0N#_BuVVb^hd2(ls0m8^Sd-)?F&BoDmOJ|YvRD&URt^2NWrdx!~ofd15KEHhF zADlr+U3;{Xp>dttkA)5|qme(JkbB#|t9T<2UawN_$40F*4xGmi+9ySa5ue>ER!P`Y zzPGDv1$tar|81P%$Ga>bMG_(tJIo4{!k)l$lWzqC6aL~D1fSnpdNzt*&Ee~99(qhn z8Ye(jiUxf;+m1BOe&;#={jx3!dH8Glh38I+m{_fVU-2l6lvMW}uHks}q1!;?k5=3g zw*i+`$l7}Bp8@A&W94k;G1WX_9F{bGziH84p3Aj&DV4}EtX1-hmyVy_IK<)(zzz7M zSa1z0xaZIGMJnXC{+Rr#M(`M99pkO164R+cElHJTE&Pj6~YVB zO1Rq4cvGz~Cb{-GE* z&8QD@QVo%uyamn~SrNw#*t&|;wj!YrHo~Gy>4~RiI8oU&w&KN$*S@BXELKW%B+on7 z*|&FAph<)O{5S@6kyH_QaX`M_wF3wglEw$@PtYbidaeBv%?)S8%(P@OvyT(IP5TNA;Um0u5Si+|>PwK3_O;5<1zz{7ve5B{EX+ zWzF4a-vn+@{wO1(0Y6auHqpM$AKy_VXB!+FN{Qe>LK<3r*0|RBr;a@f@{TkMs~iJA zuG4GWpFo;pn7e;3g>7q1E_!>s9uO=l64`s{M2Mw62NDdUqc^dcC0%b!n=jx{3` zM5;EAFa+S*0!m%s`qB zn9?**NWMwBNjacHDIh0R#z-=x)L;^%83`%U&47d+>iPKl%Am2#iuLXcdrVB1&FMo# zv!?=d-bLW7{qHxR&PNQeniVFd^Mqmn5UAg zCqBJ!j{V6z5kOIO!85Y2hgBT?h(pUwQJ0oZcle-@W1_dC30OcUpuR&#|Aox!UNY&K zHBsoJts~;(XN)u_U)MV*rd=;OS%mVUIO|Gq1E<%}h%Xs2$V=M#&0OolQ9BjEAG_l4 zwei;$*5E>5f>QJZEI_FWCgId5Flhr_DfCU9A^n{xx>Sk%N-#1sd#Z4jsOwr-&6F2k zqQc(WXOJg)yy+!IwpD6>J`bL!O?M>4TQnJ*5kt@MZ$Nk{U1bPoBu&%4PFOnrcZ0UfQYheo=1qR#YD3^vuvWRZTuRju5niU4BLSTiRGSbHLpnpoPj5ZfmY| zgOX#O5%Ja>q)>@>Tj7}K0lLrQnW&2;zCsG8(`($jcegeg(xHI>@0HW!MWIa|RLW?9 zU-Ih*7Xr|Xh64zfQ5f$7;f22B2x=b(#hm=!a3p~W2K+TOBQ}r!TFxhvdx=Mf75&?k z7TYJ;(ethl3?Y$Dos>2WK?JVLecv3%RXFaTZWbRIdeueA`g3bFhyLDOp)K)pgJ?Qr zExC+6oY4`E-j9;;H@Pe|__Qh(|DSGU>yUu#Y`!bJp=V1E>>9_-So^6LV?rekD$t}>(aPAB6;fiM{rh~3G<0o zYafyj7dS)8pM82_p7z_`l#;Fj+)NjPpMfdt^R`xGlb`hMfT#khKWSNeDAV*N6;@%> zwV+lWEl^G(x&982NCHkWx#Xw|?lo}*Y!!tl7CjMcPZRhYi0?_gA!KsG5AzEcEqg%iAKaoxi!b^G`@P?5LUDJ+$O?3QDinW8!heqItO>+_U!GPC^ z0C5sWxhBsBHbKYLU@FILUdqCOayn^=5mL1R-PKA^^1k`dLg2|>MthZ=lLhGZR-Y-s zmikDcpvmy2E6qV4;YbUn-A;gYVfgi*jv}A>vNmN;cPEBiLx1gA=O^j(zS^@A+23Rq zi3lBkvFKNJdCm$^U)69 z(0CG;hZnen^(WSjDUwwgdUpYiv;h0X%xjNQKi-^vlg)v@*W!3QGn~&n_U-~6O-09z zF-_KHB$H+{B`b<$*Ptb(AGBcn(xb{eXu&ByzZml#Q*N;Ue$;Xt$|jN63#8t1fM~>} z(1e5a-c)S z$h2;+XyB_sq8Aq}T~5<S1w%NwpI9xxSdd&u*pFI%0eMD^kb~*#P}4&*#By( z(=RB_^+^L~lxOy@6(tPba)#bEmfp4^)}FSn0>Hz?EzHi%&CbQE%PlCv$1B3c#mdF~ zI;wgYzx`hdt`HkXyMX_~yV*jZY8`*_-V{$JpTq^Q?gCIH$00YhwTUH&hWH@VB?E6N~H z*U($r^0lDB6JqD+Vhi>TaJL1&F5|TZ%0FlO0u$9kpP6}BV`NlmR~rDL!{D&Sz^B7k zNhJW`gJq$7JvJb^-@4$Dg+GJ6qrDWpC?inCJY^2RKVn?(3u*rUHVL34r!HG5Z4vSR E0kcH{aR2}S literal 0 HcmV?d00001 diff --git a/pkgdown/favicon/apple-touch-icon-152x152.png b/pkgdown/favicon/apple-touch-icon-152x152.png new file mode 100644 index 0000000000000000000000000000000000000000..5b88f47df7f0e14aca52318e7cf4717d7e7f125e GIT binary patch literal 13309 zcmZ|01yCGK)GoZRSa6qMiv+je?(XjH?(Q1g0we@?2*KT1e1iukxNBJ4<>#%xzFT$c z)>qRqHT9hC)2Dl;`%FI_tEw!6hWrs3005xL$x5of=b8USB!u^rupdML0KkyiNl2*L zSy%u7bg34mrtGesZthmtrlybyMtWp-AN81+1a(u9Dey3O9Doq}dk8)W21XdHhvo`sG9W+o(biSAP~FOh8tOiHeiu{r?PCI@I4Pi+;k zOe}g@lmfB=Jt3t`d`CAkfvHaeozjB5v8HiEZwXQ!J=wBjfsW{r%s}(+CEB5%03HK-PVWXnHDi9IszJdl7{fP+i z582qxRit8m60x%(9dfXpW&;8JjViCYWO91%_5xYRsw)8i{+|GV&C-Z^1)SB&jSEpq53bv_?C)zzduCu zlv9#I+(7|iF#^D3z?%X6WM$2GvW@bTKrq&yb zvx3Xl0;YtXM((N?> zgLZ>4LOa8Np#msP&zvZAB$uJ^s%VCYj<77SMSRg^p$DN8Unl>1(zla#9sF%K5DF_3mJiqf22WK5 zBjjuWP+|s#z=&bVKpU9C90?6D2a+HN)41QX{s>SD;{$sKi{@$_Kf!@*3S+7Ty9nC~ z`+d8U0+kO;Rx-T-B)RS}L0(P3ebYikuw<=6JF@A8{ku61_m>Ef4a4v=T!j)iAT&-e znwuik2eB?U6oL{ncLSzPm93ueNc7(PE-SKvaGh@l60iX5hfzjKZjN9gRsv6RBsxP! zLZJW^z#3cT6I`3=XIH*+yG>G2yUCjdu-PC?NT_6mM;YK>6QV9SpNrfr%OKPP6A@Yc zqc2t)={=t-tTes@Ou+>FI!Yk&5|X4l`UF5A6iPYio5KMP@zw{9XFs!V=E{;751R^& z!QaA&z@5R~0+;KRyL?!Qbk<*z{eCDV$ALG zUBhi_`+&|evJNc+?vf~3Zsi8&_xJg(sn0>%nXIl^$2R47VAyTfPcx0e3F1QS(B+8h zUr<2u=0huuLpad95w7jykU3;Rtep8u>R4pwk@PXt9m}4X~KGow+Xx%GfmvZeKX7G8jxM2w9R{bHDvGrXBgu3zU)*^>%R6fr9sT<=Z@HaWgpzJ>Y zlt`aRG5-a`6sd0tx!?iY^L$J9K=~`IR?n`JyQ0lDtW+T+#V_(HOWrAsE#xs&lZ(HR z3Q!JhTqNQT*LJ6*1kj%ek8A`ox6I0kKGcQY>xOGzk3jOJXQOfNCXh_ierV|*t%<}p zP%x;ScaZqK26!aZN|9i|)v=`8VM!FMLX8|s?hxo-q0-9R3Ye-9mNVhOp}e;g))jA# z(lAVHU_40w-^d0sbG~Tn)L&c5uy&kjf?#}P!_NEmhY?Jh03a(88Hh@qW8ICrZurS$ zIAHxW#)p&_T|rItbq6w(>HxVeW=dR1DP0wY-(lMl%fZ@3vnTOIQQzE9dgaWr0IR4? z-)oi8ddx|K8D#u*aDYR_6pRN?4Pd^tgjCqa<#veNld!2+p2P|k;s&Z9+Vuo(3Lc3m zpB*Q;3}rpbRHIj6-J}zpt|1bwB}-_TM?#!hT`&%^$X*$IJ00_(@!+zJq`qn&03Q>G zl6o18G8#KI-#Bw`{W!%pG=BZNh=eCm4y7Zd&x{sv9xjl82q;tNy2JGkfP$*YSNXRc zPfxi$%oOp6|1DNr(1op$G!d(W5ud_YAM=g6EJBXk8bxG z3wpO2wH(28JW+A{6Ie!WJBwT=$}lE{q`OEZW6i=YLqi>?Lxf>HpRwLv^J(<(~bR8Kc4B3rKAIixoGpIpa}^)pA8%Bg>@?3`3W8!A`1mBmr@VE*kC&E?Rti>ReIToFt@VM(K#}Xx(1zp47o$(v=ASFhR0frra z8?_zMEOL2I+h~(`k8Z8Y8(UX|wmVM6YNDyB4g=Shz7?6i(LimS>qO$2{&lJy+BNmP zewa;%W!jv|if1Y?P<7?!G2)BJuW=XQU^N<&#{Y-BVy)%Y-d*7BR?+5cHK^alq-a(B zk0#DZ9BT@hFpH9qBF`f z$x8KdT25CXT>9Eb56rxq`2^OowK5WWA6h_Ls~~cCADgdvR#fE&dZ`s&+7r*ytEDIX zsdy(vXE{<7Jm2c-9J_}qM7dCjSiZ}(=LqICd-rCVPmTS2{YG<8kiEw@81`j;7WS+8 zCuD)3nCB1Q*TDGH^knc~HMsWE(Cb3;nqiI*pr1nIbWo0u>WF;veq^vaQY1CAd~BVp zsYaPFYW)0BKiGS)y5fUbw2-J$>Og-3*sb6v#lS7?Q?(FlxqyF111n_^C*RCNSlw)t z?BWX$p&UN!*-u2K<7`YZESTHwzv*%h((pj{5Ks1a9#0lLF+SV44L(-QOlTS??Y8yeG>bQvyK&EoX6MyPA9(LX?i_w-dNh^aLrQ#n9?CX#53TFUy&F4NQ*2jw`d(rsfLE;SKiL4`Ydt`75vB!1!Kkt}LD(wp=Pd?kKwo{%ubua=UR0OgBz$@pui-@xB|*i? zi~6xW?ZAL!Hk~-@hu?SchtsWY%kMZ%;G)Rj}sKuGAagg1;UCmp;=3ML`nCX+ZvlI|L8ObBZKIom)Nl>HlnG#C56a$(u;M%vM@h{wGmu^SF3z_1o5jb)(f!i?cKJ#qKuP6Z;HZ7@MI67m*^S$|!hC>l-m_U(u(vrrDTx!0i~G+##M*|= zTutB3<1|#`o8y%CPJ8e$J7yywTi^XprN~yt>507cN0X55S^xd^Z(oZ?{EM~l)P9xG zNb@=#z$?>P)?2!LRuNuPRB#YEnfeKCxC9O~6x2>_rH*{0XF=D{#vk%B5~qmI%Hk!S zsx@COa`*088kqbiC(k%EA?^QIq)trx?+XU>H?9pS`sd;C5)Nso>ZT&i(;+S|63ikH92zoXU@R6q-^9WnS3#v`a9Y{6 zR1j(1ctEhJX0dtg8q6MPXNh!-AMzS9tSii_!S_AB@IJNuHrh^6WtREFN=z>5ADKW3 z{h94=nv2K&q;JYRp%W7H0{Amw$Evn=gAFxy)QGljM(9mGB?cyb&DFk7Nw+hqkOl%4 z*%aAGL;%Fg%-AU>DXHmcZ~^D+%T0#1+=Z!{ogO}I*3-jU8g1KlL%XKV5CZ8=hpImI zR+k4OeVnA7fo?zL{K4PoJ4 z-DQyq;h~1;8kq5?=50A^_srvFZd{I$h;+^BdC;Z0ti*B#L+Z_kqOZgb1sT+(F)<#F&78db& z!2t9+&nD@9&uLE)d4W*^mF-28tig^S^8dgsNt4$=457g5dDfRT#vq@-kY2B%c8sxb z*(L8*VK4K^-j|Ve5#FWgmmc!90NV$~m6g@N?WSLhO4Q~!$Ef{$!VGq&BW* zC!QMg_VVt+qYeT`9bH{-qV8j@J>5@T1Sa;?-FwO34P4qwXacT%UF-}DDrdabBCXVJ zi=WUN+G=9>Jhp*>Hn~Q2+x3|Bhme!M4NULjk&(6b(~oi25ur}{YDk@_9&c?DK@xa| z3oE#{I>gMR)gbJ9lb$UD9GHZfp?Doy7NA6r+;Cf5_2p&2kSc7@o~K7o_{S%!QaaZ+ zBF&tyH+dIq=ZWja2j7#O?N;ktLKgMN+x_gCx~X3FU#3h8qRQtLv_gT|5Y)Rx8^JXDkre zQ8Fn2jFC-eVtiX8Sc}IpKdI+!ziy*$Y%(WZjvuS_#YAOARrO=E&|)qUIiN@Iy#}T; z5dnJ=&An6#6jP^wLp5Wp=w!#Q6YrMmJhH(cb(n!2 zF$^0nZRAk0lZ#Y^e4Lp%JsmyYdBV85aXB+zJRxmk8ML5q4t_KLrmb`Fvx#?k4 z&^B&NiBiZ} zxb^jl3CcHlGf6MK{U`{1$_Iud8!{~VA81mUmWLS`{Z?#X{GqpHGu4;^L_NTu{QIO1?zjG!%0}Ub5DJ;!v`PE+F?)e_`AF18zVOeR{&CJL5j&@uq z?cg7d7HLZedDJG5!LY3OHHDSI5=n*cani3%ot2fQ-2P!$O-XoJlP>gz;$kVD#uHs$ z;D}_XT?oP!Q$)E+SNRZMfL%?Ob;=o$Mizl9vvL!J08@z^Hq%ECO99tm4814Q%z8uE z&I*YNZC~mX=?!S`8#w9A*IQjVXq%vYT7J-vZa%BJEDpIEYF_!e_T#lfN=ou4QC=7HgMKOkV(?roo#M4OK_e#UY0H9od+fx>iL&#V>3K&G;xo9f0oSZiR*+25aI4-w;2>)kDX(4H06 zSOYaW#}B5d-qrrKJFb)o>xbPD9oGx^dCB5izz$fI+T3HU8O8503WsDl-}<5BP_%kB zszE;6Hx*B%MPn51qcWY)_svrAkMi< z#dr^%ThUc0Yr&U(o?>B)4M`S!iCWmVB!7D*DSrbbuATs(E@5&Mc1Fe@M?1R`3M`CI zPmiR(s+hv9^hgBO2Y?u4TMq;VZP!H~YkHk2-q#M6jn2ldVQov>9hB?A7lJKkys~TZ zKBASFqD6z=@$#ogyrts+23#;rd=?g>0!4kM*eYXuWq3ly$DGf^ZuxjI5w9Yf#Heu3 zSWS;mNy8HaO-wgVS4FCAXNq0;UQ)fB4H>Y&2)f?)no8E{)3e`}!8Z`M*4inGRHTc+ z1)8%5H{eCvgbh#i?(-GHhp1DEFuW4irTw_pDXTFK89u*Nv)AqO&=d_`np z2cq+?sICWURi15ag>wN#=v|KrC14M|u3lUMiMkgQVrxZP8LWR`6ha1sL4d8>S!0cd z&Yr-v++15GiCjJZ9xMJcy}cIDd0IJI5pWlT*3?|y_Uz>0H^qfgQI&u`*6dE7?WNaK z6*;fKXt%UB-qjJNL5OTH7|&#pn7uy)Urb~+s+?lTnd!8?G2E~CRYYWTi2NE=;y{%s zB)5IvbvaKvZ=(_X`uchrVPtfq)6p^W^UJ{60>@PDF6sBh%RC1HRW+=>Lko*SNx?xW zVh3BkDtx%Uf-oyFUi&bYQ`~fAFLZ<~$c}9Ov8AO#6G6sQX^O=iEEH;p-vE9hhx7~a zO&$ouX5F>4vkIjL z=R`}o|2=Xe(0}Z!4!PT*UZ@gwGlkBOE&B?U?8vbw{$@S}rlS-IV}fK6eI%sFh$o3X z_*hKnY2{I4d5kHZ?|pIh{`K8DdqUspP;IS<@tCaHteUqP|D~j=iR(X``+3O$sxH7Y z+5cBPE4k%!h#l|2+oRehAB-}2Xy4%~$xwynN#lL#^-0*9Xmw&zArjbs&V(!cx(>=# zzhsLC>lCrmhT**N=QU}28!{vEGA@tLY&hJ*)3MZ3oGU}-vKxkop`k%)v!=I~(_Is8 zr4Wb6YlF5K7biZ)%Di_Z#B530`#R&*r?#CofC^YXf~)&8-3$(q+WZ@y{)`5hI9~_5 z4KLmzolnVbk+Vi&7KkJ=E!38(FPjL~Hy<^8`}W$L|Hk^OU&mPc#MoU8&B(|Oo&2BK zK@Gb1+41IYr-{KG3T^+QreG<0uKCYJYQ!rIx-CtSBgRd#H|>M*f&goZd1!|$Je@D) zfg+r49ln1>hb_;!N0XCmku6npdj;&ll$t|HhU}t#ykuE~LF8LPXW-OVQQ?N6 zdx2`MPL|&F`bMFLjM{&Ky``V`P1`3Q8S?SK~T z-L+Wjr(E~C31nH-9SVp40Es+2`Hju0E}xs`c68#Vq_s#i(I-ylPzcB6r2ukZ`vS(i z$YYJHG6J#_i0ttv8lv`nOV5RbkL%FdR>_QY29v9w`>?SM|FCxawGl%V-}gI>#$Zse zvyi%OPgTNau{ZFfxwWO`=6m4oeyOvaTxJ!@pNff@PoJ0!^!v4R7G~D-wi93EyiXm= zyQ!qOQRXw$%(vKtZ1YL@qOLa z5rDC7ZIScU-)S#G8|^_Gd;k6&RT{YHZ7pbyAlwg&w@4{@CGc^%vGmksIck51eP0I0 zZDaX&zBJEedmbru*bS@x6Uum>(X>FJq!NW0&YVm1fd^KqtGhLW1&5qDv|-{h9x38M z%*XgwoWeZ*xc3IsWE*k*mk0b797wLrkl0Qr+&#oNN!MiNJ%L0or z8_v+@9VA_rp6xfhIe`;v1n8-C#RrkPz*3(L_FbDNKpXcS;HIR)c>G%A%|OIzlS9K>^UZxCx_qGZi_SXGZR zLlY@91Eg@qHQdH^L1;^#Rfmwy+==0qZ=i;*i(sYt%(yN1Ai1GEM+g19=^%R=jD53c zKgGwL__3Aws-}1KDYR|JMb$KrbMkL-($4E~J+qRI4f|PK?`wSX!YJM+3IE%@1bC*y zGfz9=W6Q25+*K)*H zce3->o5UoA>v7sTD4MIX2PpZav{bh~l(SNmg*8~7xc%*$Mv4&SLIH3G2U#e9h=XQg%$S5sfYk2h1o%Y8Im(yT4fxz&KvSs6$OUt`Q z0_AzV;X)@-M2B>_l6-#+j+UJ(D&`tX4f?@ZCxSbfO<{hFfe$*5HajM@nw{v2Q!{iX zPphShOht0&C+IDU3natV@}Y8hg-urpA^VE}^|D0DJY8}he5jG+*J5VS>%?)H%C{@A z9&sc0dyXx0r6kk8E$uaocQdnOKdvN<*W)}@HegOvMsbDw#&DS3UDBNW4vYBpx22Aq z-0yUuXHVd`<{PI{U-Ng+_raa}o-$#$9Q%@JA=GD;O;${T0P>mIzZczaX1h$)q9~M! z-V_fubKc#UbLkTu$s==k|aw{@_&_X+Mfs=e`HrO zYOvT+v6vtavL|tro+TV1ECq6=rcJ=drPkVE0B@3+W^VSWrkjcv@>nVU+<6cFWWcm( z?)G?0^$q$6KNOP0yXo8ROsM3!0axSJB$5$y8itr`sH1`N>tVe7crA}Cx<@nXb%5yP z@Kup`d$4^mKLRzEvyz@p4CDy+S0OHbc3AHoImzRjUQ6@aj=m%5vOfB{{nbiA ze)aa2vl`8=wVbgt`gy@3*+*m+!!q$sxE5BKTCf>2Q#mxFNNzQLgLpi!3QU_nZ!LKL zP=OyiVgt#4b(9o6Q&*zGRElbA!7AVep)ZH=Zo|_R^d`DBbzTpf>sPAr-d-==(IcCl4`5y*W1d*&FC-AnG5(O4frJ)aF`BCGVAAJ+UDl$dx2E=#@`7}vGwHH5^Y8;`uI!= zcvsz3O-?qYc`co@Z@c&Thx#Du-5!c7TnaP2JhfY(=daFvRcQD>$nk z?Ucq9DW!>{ajSsgs2~3syojWp$12Ic=1_qVL@X>5JQPqKf8Od$q%yC~J|Hn^v9?ojA*CW`>ddobiZ>zpun7}SL{agYnFuKi$AIym(R9~eP=4GF& zrTteV=;TvaJ+?nl)3A#5fQ=HSNWI|j(mXkuX8k#<3Cq&UP)y7E_mFVnMLyR5kdF8+ zDqO=Raf18qfRq;zyTP^#aQoja#kCE)K0Mi_OQ|PREjg#Bacj#{NmxnGdiq@^-e;d` z|By*_))F3kQ*tO*rV$BLkN-;GA{N>~Zl#(~##=%VR*z=on1HLsYh~BLn|Z;Em)e`N zCT^D39y7p28N?VNnIu=syt~H!v{Jb`^GqgkxL>2 zLgjAaU~%?PL2T#32Su%ktyWKa#GwF`^O;PdLK z8e9p6?_Ch;J;Tfzx8F{>SlIKw^{b83#MH#=t`)WOZqxTs>LB*(53e9vHQX!AL&C=t zWq07V_ppo?_qlQtLnGuPqYO@(DC0ttu#t( zij*(fYoy7kQ0JDtSH+GpSFqbCHdI(3l?umFE0`$kgbnuGYF$7JHeYmjidOA#)N@EL zzSmd2>%b4oZOh?&KD+6zi&VCp5hd^qb<~bg_hQ7;S|dji$2jBaMSqZ4J%+%0LYRx+1{bIxoeKSuZ&w}gP`e+{D-w;3 zOMY|4HzIK7Jos7h*Jw33zo089#lu5sQ*Q?1V{_fax@ptGB2(GtP0a$8BAH+c|E}uN zkan+p1T7MMF@t_YRD~JyQL{za^?A~mJ32@>s+pC4Md%e;zrzDZr~KSVP)`VnqdCOP z3Z0^;)0L%tz+kYEkEkxLq0+C%yB zrA$Kv+)KQRCbXefc}GU;Tnm(Hwt+@(q_GDybCsKcP_p5FU&X{8x51qyslHDi^wU4% zI*P`GJP)fikOrI0eZlyjM>PKWt#v z3mz@9fE^v^Kx=_iLDM&ln{IirMop7J8=s$z&vg6gK$vKd*;o=;7)f;aC3UbCUN=c{ zb8Ow?nZlJmID0a1Cm0*%z6|X9Pe$~u<1SZ^EvTYyFDRz5XW~f@O8Vwt4QLxLQ6#YX z12^wWK5c4phBmB|D*h%!{dY7>L^KEXnXoiU`&VMGzgW(Mqo`^GIBSBBrxkZH&^?*z zytPocM5GzxB6wdHF}4C8$uM7B8XQP1Es{KF?`nwpZ>ZIG_MRn~GorfhKoxF4oMhq9 zg%xBvg_L#XnOkf-txZ|(K%%F^L*aI>B8!`ql7dCCX`lqq0g%hY-C;uoG*BK2?q2xr zt*o0XK*cC}p_?|nA9WCrs&qikp4fVh()kUkGe%pvHd$TsRK+`n&!euz)4lLSte~U^ zgWciGgCL#AgiwS*G*)pEvcVwMi}klp2+%Jx32jRmbaAHg_rXKwxy|JnWyGdNwiz|z zMYXKwsEZVT(j-j*v8b~IH*m0fuq6Y5#MQ6DoPQMF|M|il$wCJZ58x|679zn@wOX>V zJpM$o9^-s+PZ-ipe`xds@cjCVq_CqA#@5mkd87^K1m zlhC(r^iN^)##NP0QCuu0Nh%XyH`36NNfZPinCD?RNK);UZ zp_wdDLSj944=m9ENYn*MaHv3BZR8tv*pP2Wqiog3J(2A-o~UDrjW2_fZqTk0AE(8D zGhEp6EjFUSf=}H~UQ}mxm;G5OzFnk8+Gy)u!UskiiGzFm(A-1?%E-T>K`?r`AtT@x zI1w}Zh)0Vualp9Lwj27TVQ+$Vu3fgLWu^y*Z5_rz;Kt6&RAe-n_2FM|m5(Av58ZDa zdR!^P0|2rqV#M`B1HqS3TU${>maw)~wS`W?RUan8l#O`LfdVaJ>7pPq>=Q0ol@p1m zUX`Q(?Xno;`RpQs*yIf=k5?MY(Ox_>Q|1{La|_>L%94C8wr2#mdB_1C(Uw2g`pqrd z1!_v}`coC*fL|#@7l}PA_?-!JJ-qK^>lO(7i6dmu_S&RM@f7jtPuxlrQ@NDv1|LCh zqB;gPYxnvHoEO?bJytor6u%Myw$=d5Hg)lenNPjXxEYOd?s`C8l;pCkpT0**;Wm4l z=su6Eib4E76s<|sMv^tokij!rqA^jCV`gmIwp535s0%f=oBdgP+dI!8^E8t7TtY@d zO*mh@$4zh3$fIGj1AQ|(HIKHp)F!9tz}KQax$o=)V(i~VUigY>0Ls_p=>lStLA`q; z_wDq~@+DV8s&M9Ir&hu&S#p3e znX=qHc53NXb}v%Da7);+wA|kH7~F@9`ydGR`UcH-<51__3Kqyl@_Ww3j3%rjdu|Zz z58i0@q1Gpv3&-x5047V*RnH>JN`Ds7VQKoAF(ykTa_NP0eYl37bU(*rH1;!d85n0G zwZwm&oY3z0SIf3$A%VXf>*glUK>Tx}ugiXy;KVQ*C8A~xK%RmDA{IWCGhK)&JUkSf zIvU|oKetWI(vvmeR=eM~OhKDx>#Z*01i7HZX7Xhi>KT^vNu{KV=Ryc>O^)bj@YgVs z5;!74#2-uh7!qF*nNXq@g(HuV%ivJby#55fZ0Qu~{%rWE1 z8g@a2gCE@<<1^V8`{_35;6@#TuOo9q4#wx-MT{V&%C5T(JR;I|0bsH>Gz`nGUrYFX z2Yf%wJ|&H_4XbSV?tl~`=z^Fuuc>9FuU}pi=V-{81L2gyKcIpSEQxMO6*CV%Z^xA; zsV9wU-v^0&SKF1Ki?pUXBuOzrS=3!uw(7P8 z<$)?9{2WxAKpa{Y z!g~Tm{;Wm`OK;_={rM}nb5h!~LKSnzUS+0SiJ~4UzJG_NSAWxO5m4lMP)n^!cTBP4 zM%jv47=LMdT$YuDis7t{^7874+E85ViaE) zEgZ{haJIlignRu;CZFeE`TVHI6`Yp-XIhXN!Nlyo={pkal5|ODmu#@IHO0WDBQ<_9 zm2(5Ko{Jl`vyU&7&zjai4X~CUgvGIy)jEOz|(t4#KTI zTRk}J+pxQB^;Mqyj4q4Xi!)_A(r@lr-;0DTaZntKVmlQl#&$0(r4D?d?DbqTl5|sS~(K9NsLU-H$d2R!gD_VB-57MME0iptJ z3%y0%^F5H>XNwqqX)FJU482WSiI?1J>o;Csl1df%r%}=5;+!XuovP(4u-yRv#|fo_ zv71M?l#b=j&T{xbUw{Q!^^I0P%7yLaaru2)>b1L-lBJVWFH(m}c_}8)CP1~!$ywL7 z%EF53JQ&x>$%5BB#s7k_h|KKkv))c=I4mkc-4p!1|6n_6wajYLbqo$0)#}ILMNbO# zssk#v?r@VILT9+e;QMi@$CGkG{g5C$lMo?poZ<3K00*vaq0N?oxEHE7s`qEb+?W*UXG5pxCkCH@%LvOx!br@!69wM9+9xWM0)$oYOS&8qBbPt3> z5HGXWzKHV)sn&g9TSk@`W&(m4#JQ4MDSNf0CJR~Qk?%jlE-EWyWo*9FFDYEav2EG8 zDK7NB9jI~;ZAfuNOj0Wk3l9EBVsrZ>94YwHy2+Ylcr0l?&6KsS0i*jxnLe~HRLdlB zLo5KyfwRsSsWCgEYnC7r$T>JqWp^Q^jTMOEB(p4=Md6Gh5@(mMYL& zUfs0l8^z0MG7&$sE%D40nf11vm|BTv^3NGM+Qj{}cUtf0v>oS$jQ;`*vdI*iGrtv# zHC;h|wT#&H-Ok-LvbsR9{xo;lpAw8VW0oP6;-3%?TO9YV>tRK(<&k+@B)OLWj$I}5 z4{TUB?j6GE6Nt3RzeWjbRk9GZUbLB!NETOqV>jr(dZY!qsB*aRd*MMe!F zg#V($wq&-P$ke!!5>SjYT$>MnUB$lZycEf_zB-}WNN4+&561YR2lFgfI*V=krRziT zW_inMXw}r}op9_s(ePp>-1J%$1u$0fXElzbjEgTii=i}ss~l9SBJ-|X^?UPE@ICRi z8Fbh@-PbYRNr9}zn+!0{?buP?!sF9&=?0jsf$6a2e-sIFu>cWbc49n~@v}{280sHI zy6<7$8Aq}rD2I9;z{M4|!5d>VLl^0i|FECm--S)yU#U>X3fNd@O~MP(bh2~bcWrJJg)!vtVvp(y=}l&p>bh?a5PpiM_;f~tAuG7`X~l2hZuOo4*x5ewF@OHd%*LVlnTMZ~gP)C!k?r$)s_3Rq|9=TM zxmem+`~B|%LQLBk?*csk)$o2)h2O%()z96|#?})c@jrK<&wPA*ATdi9b1RUBpNFTF zlLtu7*}}!$)y4f?8OzU(Z%*$;fc~clODhixcRN>4I~Qlb|1YI3BMzc_FNK%BuH*Rj z9ZT^)SSK@QFKaUkPcL^X_x}eRo)R_l4*vLmz%G_nj{gtJlh|?k9i`*1sq3k3<^ytd zcd@o}v;ukhxmtnV)p$RC;85Wxq~QW_K$4-H v1C~IlMorMz(i~)Pe2`=iaV%7}K%NC~On~KiDbDqukpOa1%91tWrs4k|+|6G9 literal 0 HcmV?d00001 diff --git a/pkgdown/favicon/apple-touch-icon-180x180.png b/pkgdown/favicon/apple-touch-icon-180x180.png new file mode 100644 index 0000000000000000000000000000000000000000..11bb2796c95a199149820fa5f5f42766dadf0306 GIT binary patch literal 16417 zcmZ|01yCGc@ISbV2X}V~?(XicL4vzOa9<#}2X_k++(Yo-&f@L_2n2R=4Vf4j005vVD#&QPw=Mr2NC@v|(J2Hj002m4FDQ<>=IrohHj%765f-dJE9iCco?M^BF27+5FtudJ{Zncww5|E%4n z*(+JbRc078Ia*p;blgR8wmr&#r%lgiWVOrz{dEQ+eYs)%+BR5&VRNvd+- zf?csYc zNB|(7J^&z;2>=kdE*nxLztbXED9g(L-u~N)x+_xO?|g7mFz^5X*l7McfWBqo-tRXN zJrz}D5%*DGv6z8$mj)96fXJMpjHHh5+F7?x7U_}K;ZyYqkEkC)IL~MwC1$7@9QP3A zDsH$8lRg*YH)=W~L*=IK0LbI{7TVU0N&WI^Ymjw)*^P;!N(r{CmIc0SEbi|-AU5q6 zVoY-mLGPN5kgl6z2jWdp?!K?&MKf2E+}vbU)zw>&K#0$Dz%-&Yv(f6fURzUot<(R0 zsV3fB{s^aLZL~TEgNcygk8y^;weEeMccLw9U5k4BfdgX{;1QY&GU|GRAd(}X1Jgo9 zU-b~K1q=bBH+^`0pF$@>i6IwaJMcRJeOD6v@7)Feb!Q_U61tJQF}uNnKkxiO43!V1 zfN=$kaaE3tjDy4!uRu<)6QFIx9wZj|jbB;TAhJGn5Cv=}paS(@YBN`nI#`6#sLyG~ ze`liam&6buMmk^%<{W_>HWA=Lv_fxVEs-<}Bk~L3;=m|WopLL0CKB|syLSe-2XC^B z_DtN4ad9ffaCO>fNCdXzz?jrDBXdLC8@s~#Guq11KqkuR!`pc&){S`S4D9fxuK3oL*?hcAHj|6PF=y1xkX3Fas86Ra0}B0o|W z@&>F3d<%Tir?&lf^THg4)?>HB`7NjeRN+ku;I<@DI^{L@zVGz2H5BE=iQHs{Hfyf1 z7q-&;ryw?mK7v;;Gpx{vNP{e>H5&3t&XLr=U`7yp>`cEmP2)cc`iTx?y{GE6#x3Wf z0E$a@JqJ-5Biy<%!>%=hmOp>>y@b&87%>zC5{e6664R%UexS8x1N40Dy3K=OpP@8) zwH&O!(?q`_Yn~?u1Jzdn&*&utnSe$3tvL)QnZKt;AT|L%lUxt-PbDo6)--t|%F&S` zq9#Y2n`bQuEr=ydJApfDJE?uBm!_Gtm+^O0p|g@7`?wKoVr^)hI`F1&AMRUGJOS!3 z;u7}Pq4Puw6?8?S;IAOw=%2yp7b}6w1Cr*=h*&-^$%@G!gzpu$lx%MXxO|f%e~bsW zLlWmRsFLxOp)=#B<$C}z-C zb!CRu4EsJO0ceJCId?7)_!DU^Z6j<6fHE2)o}jWgSnuP3e08dg4i*%75aJOnl-_0e zj0iH4+PTaEUSZ4$tgK9iPW8ngk$AqqedRZFqRC_Tfi8)NP-H9B3B`<3O!A z5%4s2p}$i138L{Y59nnSVQ?KkK>cK7^-@gBPpGp`Xc(xQVzgz-g=&HM1F7OsUD})l z&sfN|o8kRNjD(*cJSh6nC8&4`ForRpyc?7GICgqon^K^D6hglyB+&Wb54YWKp`247 z@rG^5?;x5S&e)67C-9^B+SRH3hvPi^TOqgu6h^Tr1nc}D9MAbfN;7Y&6AvWo=O&~g zVa&y`R>K3;DT#Z4`<9K)Ub+OgqDB02B|-$FtL$?}Pv1mTvdWFvV0}fc3a{s7RF=ql zOq9~Lq_Ly&q=SaQnj-3@ihHKZ>{j(6ykae$t6D{PVf!rzz<97;)^vh*l=oSMJSL?$ z50xMf-jF92InE1*1Jx(_0BW-Qd>&rDa*f4FIUY(I|DzP)a9K>A8 zhvkHXgy~QG6FOB%Fvv8%*GiHfapR)vW?xnm?tRixU(#_1I69z27bW@dc8cY5&I;{m zznf2Di1|TVf0d~FueST>Lm0OF=b?{pU0tD;}SHj_>s`yC>!^1EDGG> z#}56NoYkL;B?qdLD(+AlZrh2Yl%OXJ_hGZzYORszmUfZ$bY_cqxUmV$J~1hm%&NBn zlI@HoC@ekT4W`D8F&4^KH6JlfFkTs|5x*eQ!nTL)E#K(wJSmi~eJBesR>lSc4UXU$ zIKQ9`O%!g)&hJYzC~2@Uko|^<=xxRd>ckU>+p{)PFCLt9OsiCBwE~bqNzDTdj*ez6 z=nAdoMukEmX;UdU#xE}WO7yrv{u3p`O)=|j zc&#k`8L~*qcjI2}pEGMt+Zjiwc7?7>8>~9-<|8Bu$R=XoV#D~0SWdlg3-GiVh_0k@ zd&N{@CS$dck4Xyx@p@{StNM%{H98)jDv|w#E)N)Bpe$xR)|~vViczBVp`^vf9pjyk)@sC z_8$7ECv1YP(>FE5ClaTe&<(hcBJA?WzBt;h=;#^ASl|~oL^uk^za`4DpC(A!@dzsu*PM?Dpmh*SF8N;`?7(zm+l|m6xuIcFTRvY43p)> z8M~<_zywO5aI#YSwWk2-MrxyXZ{cBIor*)ljJ*e$7_`om-|}ijGp+p*yGNxJ+>Jc0 z^HXoJFUDJPiWSAPr0f#XOq%JF zWDM~_S_^;K7F4~YVq;K(-^T7SAtejc1%bJDo%&DJnHSdiXB^HTQaM;}RR*V8yBtS; z7Gr`|!zI}bgDYtnX3t+EIDItP)*n`C*XN!58LiK@GsqRte^C?-wO~mm*a6M>cPDh% z%YBVnwu|7FT|rx8?NK-g$E1Ij4eb6rGkOl7SeLi?5$sS6e_9fpwJAm#5)vL9pf%42ywXc5)6d;kNf*r&ixhnwwd(k|IY#yD}^-s#5Osc zX`y{imi!S5H^o2m;*$XSTOE!&nAG5i0F=vEM`i~f9K(K^r^Z^x6q=qf^~)>4`zp4% zw3wGbZZmtzTncMAUn?)(0N;um+(9$Ntp2fPi7Y$OX*lQuBq!;Qekd0QjrI!7=KL3_w9yhnYYS#vCG4udZs&Ze~ysQmlE= z@UBaxOQ0tqJmY+i!QotsWPNc8gFLWh3m%Xl!k9@m>FHCnKBAcbvAJPBdJ8JtUZ=^c zyxlQz>G>JYy|JCs4F18rrN<0zn)D-MY>R>f)VOwou)a_;Vsf2OqR2jcc zyS`5M-IvR6o^z_DZGD#GTnLY*6#ezOT|^O9R~M&pUsEtGzYEc<$^eKj>+>*5zmL8s zEM=pb#M_%G@#ufnS~p`i?xrF(X%gB)zZU9xJ*DbcC&TXEDR;KmMbf=M^5WIBS(f|Z zn5dymR@}s;A}brMu+rc5$AfHyF5g{&mh=&E?)s+e@44cs@4(qV}s(}rh%?ZZyO0^Mr-der@SR#J!ak(ypxi8U<1wYV7M{ z`EZuUZI#?o?GIa7W!5-+ow)^E8gdMr7=8T=JWA{x;=8}GG)5T{8q^a@&Owve#=rAc z@kT^yoWq@sWT>&Ks;MU(!ZNHEodkMQJlD#4#Z^y3srY)ghm0Vems{MTPO<2muD_<{ zcr}S_A`~iqWVphXBJ?26 zqTPQdpD3<%x-RtO|Lqi0Rd+C{1O=rjSa~-8IF(|-r%v_qJ7`R@bBJwpQk<&Xa@@iY z8tyt2u&sAB8xZ8St4VD3Q2uteMQUX?THH4K5ud`ycd)J4B~tZHlYTCk!zla`mi}Lv zsK^RK>AicTcH;6ZOEQtVNE%R7$OD`piuzBfB7dp$Z0z9huG6BvYmHodE(1yTQ`BbU zBVkIkXo+nLi=9iN$FW=3k*S^K%NhbPiKV5<#;-aCrFT7ft54f^x;|D};yL*TfzFH~ zqje;lEst0B+C*tZ`_B+5U zm?Uz#4vy3{#@ZttylB@g!d*R$Nw2Rg3C;g3g}z};MVtub{uWynYvI>E6C&M%TNbO} zE~2@2ZYYlvtgMx&ejmM=JALgr*ypA*x04BbtcKUtJ1-}PBSV)^;l>M#$%2YJV2{Rz zZ%DtbrQ;ZJtxa})7VhmdK-fM9%hFGI%H3qMiN$87YA5d|foDMv`Z#QI3sD4f2+QbB z9ouO#z@;zpJ^i$0LU`K1ohwXYFT9QfGkbsJ zQ%P5NJIX7HIarJc+)r#HPBb}(TaKG_kwND&*u$cByXhC?!m;!xg*JR&tBNTc9hF7y z`lO$dUOV4fVxB@emK`7p=IcwGeeag{@nL#isK=-i@U??BA%@I$SnVsz$8Dwdgz{v- z>n@hYwRf?+aNqhU{8%jVhqX1u- zF3qkwvX?|oA_xI1-el*-bItE~z`5J?WmDXV?0F{Sq2OlR@$CCNTbnZ$vcWlttJie< zoqRyuN>4Lnysb1w8S=V&e)3Wq?$RS$b}D7+nxn8%&P7h_Rn_lal31-kUzGQ*Y_+uxtPRQ)=w>0(q{PUz9MtLZ|Wng$m@Fs(n-JgqJ)M($IG0w$&VM zayry%&zBt2{}JEL^DX^cUQ{rrYotV>j!0I!9T=#=mNH{QbrFOy?rjYvDD1x18QvJb z026&idM=E1J(uU2R9Yasuz6S_M7KY zh&N=uCmj}p&k6g-ek1OG&s8;b@jeox;i)#Sx5+a7flimB2VY*j@GQvR&%4%?lz*Je zK0Wz$7N`6$y=k<{%|3N`GaEMYL7pWiQ_dHXt|QH~%eQ+Y#i+|nhjB)!dGECFgFF1| zUfir~jm$!}(np&!OD!37DyQ8gG_ArLW_i8`b6Ee`Eib>EQpIX?+F9m-5Z|Cow=(NTA*ryIGM+uMM&-n3yV;@_uA+vFnP z^eY2C`@QBejm*hG+SLgD=|D9T2nAF6Z2!#deYw?pk7{B;n}JNs1MPJMy(h7&pL@*N zAia6zKdS|9vIN;>bZg1vS&5VkQ?;4Mi4T4gLqqKbxA8{j$)P6vTA*#oMa+b)#&32z zk=;kA3E2tdU|eE=Frna~ah$-VZYA-EPTk!eMw)YFO$|XUte$WE*pAOm5-cxUi!IsD znWsA1Z>#qc_2l^hOWA0}?}g02k;2DlUy(rrTRtnj+R8Jus54K~kVsjSYNV(n_Nyl6 zI4iD+ci)1}7eY#_g@=w@4EyNoa+Ke*L{^25ab;a1G@FE=!Csl(Xj|pW)*_yt@{eEt-7D@7!Ow?}sWA#*k>P736VG-(gFp*A>> z{dH^C=C2>a)6M^_7p13hbrgp}j(b9kr>HYT7km(6((-$d0sJ!_(=%GBfd$3hxIGUZ zyX^IF7e3scYf0#@4~(}}m=z}ZPgHeryaHLZ#HcD#(lIRWyRgsQ)X85}qp`I8g+-af z2d#;)-^DB>rcV36P20YWwQsneYKeKTvN%)?$kNrep?xytjIs?0$Rf*q%;w~eC)*Q{ zB0!c5N=+auSsTL^k9p$S)l&i?ggS_5Z-MUOgqd=IUtGs;_MTbo0 zJR0N@wPUxXzb$j3LePL-ta~#QB~subI*sj=?5(F94TVXk>0j%l+@x*))^ehAl>}k0 za+!UE4VD!v$g10h@4%hjcUR3(w^vI>WS<*~V`jG6L1oGwSqKh00;erq<}bPI^2sK zDtICqLIBP5CCe9alnvVVF2>x%Uif-Ryd#Wy=V!3s`v-ndz8>L~92g*8!du%nRGi#> z`JSCi+MLTU$cU5z8(I-3nkuW~!0VZZe@!X&cI7cJ<5mOrPnp|~!#?g^K;5rPvR2!M zh6wmB2Imo1I=!NYS4V8ySy7m(SxY#X4H2#v*3D(Ot1dqMMNC;nps0+fO3I{JgSjja zw-Crmum)$is{=y5_GT*P?Q<7o_i-9t2-^4Fz47gsab=4hE%FOZ=Zn`j)m6~{@%B8n z4!A{wg4vDyT$TALIz9Ocd(6eIj_l<-8$m=e@;SNtc|NzO1wkGZ)iWMHD%&E_BnhI2 zSoyJ=Rm4wI`pdO#DqxGq;L>d1@_6>ZQBc1CDsE>t)uLO<%aRC|(0)&%gCJWfKs;Xr z1)L%UbbQCG+~a7vN4X)(qeawyaY1GyB|LCUVs`+V`Y$2sDPe_akQ*6 zUmkyWMaUD@SriwGesI?wJ83JDd?Ulg*B;uMv^_A6GkWl|UyIN7S3m+{?RV&50p*Nt z0!6i|#}~&iTxidJN0MM-=c4K_XRVuMtz0d5I*Bl? zZ!nR!>b`dY=A1d}aFGN>N#mdDEnf{@@pT)cUsUbRCR#vP>4ftEXqK>Fkp6P_#P~N7 zbrRm&>NsCe!Tgh2sDY9OP6vvwee)HW)W}AHw(Ylz3VYugVSv~KWqAvx(DYjm#TfUEAV6k z;GTZxkIL{_h>!O2pOC9N3YPAxHtXAj!kn44#hVS^ph)ScsFjZH%)7Qx5AlZuNn+xX z8bgDL_f8hqALfUXgq-R-R)DP)OzY`MfqZAt5n_4b2^*?hcVixq^3tbFVE#5W19LlY zvui{%@E5{R0=v{$GSeUK=w}Z@sfYNGGW`0atn4Qe?3tkKQ{bE5kY-aG2@cNRc z=SP~Kf#!|EmU8hK*1Rn&)w?*Kri#01h6=i0x_ZlUSt)KW_a@GC2AwiktIc1sZ)!{o zd~_%TG<3sr{y#7@|{ zpH3-P#z$o>e;#8tS~%p#zENl8JTUzGJ-2wUI$8+}oX$Y^Ib6hybaRpr`Il_h6(3CS z6;2Cf^!&YW9Xd6c6#Hdm(1B@78Puy6k0E~()cfO4aO_Cwhy_ug3GoJJTk@YTD`GoC zudkCk;TS(nRyOnNo`#n{wNGT~V$8eiXFPh>2$m);+Aequv|hcJv(e7$0Ux5ArP>}Z zr*epBa+?&_Ym@>ZO_fmJ|N5k=C{@LpTdaNKk2pxOOzZrJ^t=Bv}R*nSy(CNS?{X7B>hILB^xukGT^-xUN=rC>+{L z_N6ZS)xX?Y>Krv0utlh3g;@A_^Lyg)ab7j#S)O_G=JW(8?s?P^TrnSuoJ$v1ZP4+Z zc-h@uB;PYA2$v++s=xPp9c;I8V!C2yc$(;SmJ>X7e@L{583jz{7!)2TqIIRuZHn-l zOunEOD`Mv`pzsd;n>T{w3(K5SAc~^AtK2$Y?iI(OFN8z_*G%|Cun`L_Bc;s`DQwVA zc?(U1Lh9Q>*4=88G1J+r#HEe!VZVkso^(UHXuJK&z_zWt?&s zlHWdm+@D)K+!4Cw6#8+NX21ySfT3esn_WWK#DNn1?in$sMe0DtYdV)UM6;Au(9DE? z75x^a=k^@T$@aQq5GfVZ8-?&Eh#_!U?;x*ZRu9uLW$A#4hw!oc=%_ftj&KUF9!tuM z^3RQw|K+wb|I_o$c5nk!y{B=m<9W`&4+Z9O>uW6Lu12&cQz^T(CY)jHy{5(;iO$q;;t*EL&uCy>A@u5_fw7qn#jI(RNbaYDf8a4 zE%!H)2Y6NABv&b-VWgZ7a|#Kc61+1z<^s-a7OqOOe)X9w|M~kq?>^t~hrI1J$#6|T zK8yNTX>^|aBKWXwHFw_lxBlluqrXsIi%;EtN5r775hKu_ZLghvY~DH zKQx#C=$?JIQlIR3&HG%HNh#8g1aib;5RW=R?+t6SyMG&z-Qe!Q?0iRK1 z_*LxO#G#@GQ}SE{x-ZWTBXvF1ujlJVpJ-DPgI?&5uwrl#Tb+$osFdC9AYRV329b}O zl7SHxV}?HfYff|`gU2o_zF7%#t3jjE(-LuWd@{1Z6rn^qewVfiSD#1cwjRV0yP|wA zD5x~Hkwg^CCAuOF$)7(kZC71v*`|f%fKe5S!kh`Oej!Gr?YkP9O2f ze*Iy$OUY8||J_Z*W&aap%7)Il4Ca{WfGTOnVeU3#krW46dg<6$XA(4^X;N@T@Usa zZ8`DZ4@uDZ>Ezr}j+b#}xXM zV1*g(M~+Yep5}nGAJsh6kFy`cV+{~tc>nJwAR9podVG91cQ0zwKw>}jCn5b^9Ax0X z*8D-Oq3qnsh*1H^3P+3RcRZ$0%_fU$$$gn9YWLd~?qTzOp#nc$ih@o%It6Whg`<|xe)5=*ObPzj*NInWd&h=t z(b)coh)F42`*C6B^sp%O(um}-E!CFAlF4oIKyZ0iZ)S1s7eZ%p`!=th>442U&G>eL z(5c_*{#mlSLM{B;wint*Nm|5YQ9__2Lk!flx2q6m@zN4%tDxs`!2v!(rH}B(ZVM$> z(F38IL?fMgL&tJ-ITw){aFzJS=urbN*^^c(?LFx*MXI&i!NayBjTSaEE>2Vq=J@&s zaL2sSucWe^$BPV3dJ!e~6w>C+wWF3d`^v($rGsE%2m}-6b+d1VG5>D|tgp*m!Rx4a zu&t4@uJuaCK}or#Iy$P&sDMF#3T8mt_u4udHU1p)%lzKi+3y!L;wZDIi>=nDOH=f>{4Hqq108bplG&1u&%RHOVTlC;~fNN5?@3UVfaasu*$o(nn2>cgMXgpKwcqa&2MMDCi`rk zH55Pj5Ibcqk=a+DNwm#8i9O71w%YM2mr8C$Em4+lkM+$B#nE?V+oi_@w?-fD9FwIrB3!LO*SPVCf%3hR9SpL#^uH+9_BR? zd{~`?zZFV+>UZUDdpYkq9A9${4*Ipen*F_=UwT9{Q>TAZ*<5!QKwP8g32{g{q)V`= zP@xrhfaW+zkQ9TdK4ysXQ;Kzk_jknN!a%4!QzI`$wxQe5bd+*m6H`W^wbVmQFB~SfhVINWYK! z!>F93&Rax+xqTwH!Zi8r7;g;ecI+N$)AH?@E|J9h z4e=Gi!A!7>Lobf=J=EvD;NXVzxZVk^w<*wlCa`z7{Uhj) zI^|u?*-f+)9xdOgQcUey1r){D?2=4-Y$L1-ncjmX3;zks_dmsd zVl>&eb@@8Az@y!WnJ$Pj^-&R$w=G{V!&CpvyT%9k0_j93<)wEB>N^d%Lz`@5IrLpV zBfGo`q0x%v{7iDD1+(||1I`nEjyhbc$Hw$8?SQCLk5>fHZS*Oo1cg-Iqz9js�^S zCwB)j4vuz#Q?<r(2EML95waGUW(y|r`Whj8U>7CNO+(*-5D2n5GXb6DeqrsYEZF{& z-}ynY+j_&0;|7YU9Y-q0+{g@_DIGepWMEktI2J98+xyF2tg%OD7aC-^uA`O6Vz@BK zh;BDe38oe1x=%0;qYfxlo7h|(*D;tZcN?9Ox`~ieaIMmSPS27ux0_AYvQCN?OhDV3 z<$nJ}_Ohsw3m=iOcalrg&ysBrbRn)4cffM~D~B@Xnc~3_bQgxpa+hNu`-_FR884hpMnblUK_h2OpEeP7;+ zUg17aQ0aGZGgPx3fEy=?mmMC6J z59WDu#e%>^Y`g-+;WscuVi4B-?pbk9G;t3R;J)lX1Y?w~g~UT@Ew=<;8H4w4P+?5) z(dI(JbL5w(t#@p@W_Yj{qPkB5>3XgNP;_@U65D3_0=gBO#iQ^G-iDu8nq6u8wgDlM zf061ES9QJ|^Tdh`j?K7!0-DOAl&jHRKEQWW+5k|gK-ZK>*4W%~ci^bT-1iQu($ zx<1R&geP9CeH1iFROIiQuaR5l9gic?Y zys_@ELPTNh8bS!}u}`Ee{y9T73ZTI%YCBXsJCJfXOEAYxcE8&588tPkY2`IFSeM52 zMI5tI2(0?V8~ktapYpeLz#+|Z*y3jotha*ntCiAd3mHxKQz6K&imnmk!Lk`iv)cYU z@CVvSL0D73V#Ho&Qb2t-reD_!5}_-l`V&0l0U-_3f99!%oCoS%99k%)vn%uru5ec| z;91GRWapcy=$Z+Ex2EY#=HLEm(^!#m)ee}-Q0}rs^;;H;N0?{tx=XM5&u>!*vZL6n zz^N`$1dnoXpsTJzR54vYM8A3qJ(eee-`l2`a7fK}N=Uu)<#FW>+SrRp2r89*7vV8c zX+D!bp}cg5oh03(fLB1Y-}V*Rfjcv}|2FU$UF`<9#|M_7JjiB;_r(s2KN{gr>ejX- zViVSsj!oQAGfW{Gabqu7iXvW{`ejR|~Ku!DX#^bb?JLuEOR()3!Kb#^#{= z3k|L0@1SJXwjYDv4&!Ed5`CWi?)S>e?(w#NEz_=4 zEg#EGUZwP%hBumD_4w}Gy#=0t5&e zCch3ob%{%aj|LtF%H#&0kPUpVBq%ZC>PhhXk3NG=DN!8LaMU)j0adT6z6$^geK9m&-ignuaqc){kL z;iwJ!qjB9a_(GA0=hFNhA7M&YyDH{|%V#}4CxU`-fgaL3pILAnw;~WmI{G{aXf`9T zHc5=a@!g-ms&5Fd@u0h3At3zb<$YI_<*y=U$gD`!|IO2(`%?y``Pf2`A>6a=voY*i z_dbiv1(azgq;zyDJJh36iu?1D@RH*Jfg@Up!lde!pHcLw_}IO3J!i2VG6;dS-J4py z8SO_mAC2LK(O}_>Jm;Jq+#zIt9;0jI4IyGf&p+u*Dz1nLZUJtu#FYwsCNqBt=*Z^X z;`M{yoV4v4p|Qj4{>q?5lY)j_;uBD^ch3vEU`~47vm)_PFZl&&{KFxuJ9y=V)CwC8WP>F_Oe`0<`l zhRAS<2W`&*l{uPNijpSHN0Eq`p!Ke0kyukAOP=>7hs(^-0Wzs#S(4B)5;P8+f*J|X zsk}s75zy9eCOaQttFJ<)_MVjh-FG{Lh8Q(Jx&y6vDsfW6BPGy`u7vh?r3PU;nl+WM z#$*p!2rKtjgpnS`!QreL9RM24mgDiBX+qa0W*F75S?B&#syA;ed$@w+JHgDIk*K)8 z(TLr5RvwAE3MTeclyu2HQ=;C*-UvgF@^?if^&6MR&?j zo3CC-9HoqjwK9&O=)?Sjtpu!WGm-_qHS1DVn5~r)ej=fE!>xAsU1X-Nmt4?KcDGr4 z|E((ch4Eumm?SVLpajc$SKQ4fh@4ZFGOu#gcBm+Ws0Qujt1QO2+9Y`pS?5e_1BJcH zvFM(@`n={6idM9CI|>x;qae;z9<@d+fVjc&Q0z6oolVX_HAVd&Kw`M*?$LqlwLZaU z`Dxkt(hF*$$WMVJY)&0PIrr|UvKS}H1VPA}Nhwarv)elJyrbZPizOjX%9DoSPQKD? zP9|^|L`ufzQnMi3uKP0Rpe(9uhUss&4zd9w%vzSByH81$6Rxq_{CS_#lU_vcog&(Z zYr^3UKMns-(-Wa6J1HxNrGg`8O2TiSA_GU>61a$ySC#|k8M)~q*eSvYDc6sp;%BvK zKr$X}nk*{;eHCWd`HTq>n?GI4I(Av3gECnu4&)Ylu})FRnOh(P^&WU|%Ud-`;JTley-P@C6nYW$B2RW}ix+`9wuj2MNo?$p?CHuLgES z&X!+t#?*hPek`K@;?7wxg6<;jMBEiWJgL^25dEr>mdO_+z$P(P>EjPRm4gqL=(`o_nfEM>=-p z3Jk)OoJ|lb{~am5Z=PD#);ud^LuFR)WG^^2KxX^vLwG7DqUy{#5s8-@n5R&(s9-b$ zMw-FG9epmtNp|gm4Au1C5*3DXPP2NB-`$GbT_A7j*VeI1Fh2I)q@-$JNNZDB8IIZd z^tZV6T&5J9M!qy9ag3q3ZEK5iBNEov+tTa6V&YyKnGkdiMKVd)=_)MU+l_H($Ha%$ z7=ULniGD=b-BFPq%r@ed{^}eT9NmY1IE^eyAQqXFXz6<+&ZMQVAP!^$QNw@T``vAk z`##$VlvGQUshHnT0D_5J-KLVD0$Fp8q$jh&X#2i}*0TfOS9^bykPp_Cuds&cQS_il zm2@vERVDaud3s5^-K|JphdK&#rj_NUmg6m^e-+tFJwF0)CJVa*2;}ZAw@U+_=sfE^ zW+t3W@7QoKQ;_qYsRA7xoZ#MzX(?D6^6_c-DJkYF6tG<)AS#!bWwne zg%-{_n^pIgYVXvRduR6y3ifm2A(C996h&HvCJc(i z7KSj_9ABgdm>`|(QXMC(@nR7s@omOuLAP?qw!$QuoKgrtyU)4o2sZPEkic`9s_qUL zS0b70sZQ`-Yf#Dg*;nkFJ|!PuRew8Pt?!lU54Pa#m;g;ACLkT6Q||1~)clxwEAEax zoIeTXgA+%^lBT1zi^bz-x^|S#VlgwMHbBZxMG+8ZyB*xi(Q>M%ph|EFp4-REV72ja z?!LyQQm*G2%9(V?m8$evVX;s*nMB*5gebmI82*5?9cLgl3eS8L#OXWEcK#7BmZ$2B zd{GF&kHcZQ-}{>bn8-N6ShBTx$%Snlc2F_6XQbJgNvn+k#Zx^B!p%hmBRBeQ(tNnS z6PQX)8{teci4tRer?WD&lQxCR{@c6ma-V82Tj1@Kwj-%YBzs7u;_7dZ%3Jr@3@|rkuV<$YHfFf|0!ZK4P7?9)&tuE@C26Tzo~73t zaIx-<*Nn86Pe3yc6`_Gl=_mCHg5_G;DrQ@rXmoZuGE;kfZ?+)koINvg z*Nj8Q*4gD#%d+=HY%T58k_DV$4o_MP<{k(olo>wptP1Pyb8}!&szJOV^Ts69CQZ@< ztOCU}yzY)8h|C>d^-y|`kPr*K(qLj!$*p?A-e9tb(1O8gG?CvZf~&@VOOX}`N?7(h zNbA2=%N2By%Q8A()@H?&-)>eO?;`CVrAXo)rZP-+gzkwv_@$k_u!2ota4{LEBnBE$ z9I2*8ZWvfR$%74o>by!ue|O(&e_@24rm)0*qag@5dd7BePadw|l7o=SoA-JTrufio z1Bk@^`)^B%{GpB1C6s4!RE(aUFLgI)6E+-n&gv!MK=pzWzGpVc^< zV)xTHtSoo}8qDoTWY?e{t;jqp z^Fy)hJZrQiJC%6vH1$iLI_BFGNKxr`VtDo@P|f#(AeppAZqukYS}HiAZjl^Uxu>uX zpJM*NA2^Q+mb`Mwm?hngz4zj*ze0~S6^~y&Zush&mJ%YD@{<%N3VqV%3QN6*=&wZV zl#P0k@8yI<$=7;S&D=In{p)R{6<5ui=QSBJIaxs% zk%!NNsr3~NHSeA;58s(fT;NBT6svR{yfK?ep(jfst_gssGB?3?x2TTV| ztMUYQ7Janu)t`zzTT{Fa}-bz5?#MB=q@e6^=8X^g=Y-`+5 zth9U*S6A!Z3E_~b(UR}8!Rk08uW5IpGbO$qkBpFjo=MsXA^Hh5K?xF+4X7Ngb~jl> z?K^hpNCRf~r^JlF_CJJY(Q);0>45E8^uH$OGVTu+B7zL3{|<1A2_F8Xy}QMKAK7E| ziiP)QH-@8T{wOy)5j8M7jN$scWY2du){2VFv6(bpSgx}qXy82#yOxC*O_=lOYJIP! z{wqT=@3Dem;b#)#0vlWlYaDcc%w}TmGk5ra&_*P;d$-h_KEjdK6FxZ1qSiW$m_MJ8nWD0C{< zKz^mu%$6FDrhhGno?w{Wh9Z?#4FM-i-Qw-2`_mH875c;J)Sg(R_>6}*mpBig7DJC@t9~xtbF;G?B9_SEX=U}s2KzG;!(%_*|@h2 z&I;o0^>=U13ZJwpF@HOSK11gt<_x|92B32&(i zo^ihGPD`vZCoR5XU_V^-8AnuEsic*-$4C7gO#0RZgPJB8xc3e~RWwXgxgj2`j~mlT zATl_@z${X?H#o8~AOi1O0nJFVParf(-;_CFj^`}OyK7-~9CS$$6{b5Cm_%P-dN4SHpcv?GqP%64ux_)tU{qnAi6{pji^ScPj{}Ewj?P2-F-p$kA)dleX zaB0a)Q8K(s5nycSIJteNrTQOQXLA=X8*@ufuP@eL{tx1?Hnbe zByj@2Q+@K+(f8Cc_n~zA;%Z~>WKHSm=Vnd$uEsk=-#2gn5*5i^kAY!aePUAaj}`!y z28GQM1&0PlITaTchf)T_GhhWv)2u@|v9d5aI5|iH_lq9@fVkan-n`}R_4kr2d-?{|76Pn+Wlw zjTeWYvdV5pZ=*3|*Pn|G8;%Q^O0>4NT3`%^O!O^b^B%C*tAt|Brd9aY~XDKJt~ zpBZqlTc5%E4MREDS=S{bh$h;&Dh??L*t)dDb}j^X(_(UF&4avip%>gq&&&t_LazWo zbQ}O2pI^jv05F3AAQtNjIkNzO&1d>9Fa82chBDCA0?z+gMXxI}E;1Aty*vH@a1HT~ zfr87`0xy!}Sfr6Q`3e<;K@>1Mbho{@rr$^{4GXu$otzNty~BV(wVtCzPtN2k$ufIa z=ia1yaV0rjMhV{1L(YG!pc*Ph8qA7KxVXCs$qy-b3456s8xL)yrzeydxifN753KbY zO*RjFau_umocR@Ngui0boLm>t>M?a>cis_H@=)Y4ht1WzCrb+cGCA2tCkwj^yQj9n z{;yv~7C#M9p|klsOSuee9hO4Wo9aqe*r*!8P&be&#eCWM5_ve2JS{O4=y@IuQO_VG z6YA7O8+Fy9lqNvoG{G=Ed(Y+H+GLlZi;($by+9ZVOk|@ZiZxP@RG@`q#4C z(owq(hB{ar$q_`Lr+ivF?Vuw-SKj2L9)?jrWCh6~3fdV+Y5L0{MG{neIuwQE&N0Z- zB_TI9Urg`5CczR%b}CXLyL72LF8KJ-r!Fx9sEA_uHDQOKxD5Y>KVxFAIl#c3sS~T? zEp0L-KDRk(7HqxBSUDs0KbKn#OJa9=Bx-Y4-_^dswPCuYhx%`0dW$_1CVIpQVRtYc z&GUUPVyzeLq$IF*-S@VbXW(74$2)IxLTf}g79?_$8b*m;)JRh!3W)>fc zXFZ$}vt_BS@o25Zd?LMFUh&AAycxlpk$+$mq&iM&?o(2 zWArMQRzfQ1oHi-n^{>H|HSOHR0PU851=)S0YQ9aI8`f_z%MH; zZ}DZRhicpC5My;IAD8?ofc1 zpv}@Oa5U(~TTgDiN}5}#Wl`D@nJ<*b#|Ke?;~6GLZQNVzmxr9^XWv@LbYqe8+mUSz zH&pI9Xd9F~8wu%Z^ueP?s;f+NI%;K+jxwW7ObCn5$Lvlx!6cQO-~1Okc6;7oj_8ph z+*Y`B(mh_d6d7i0S$;b^jrzGU@^rjPztY$QJgO8NygvNu?96SUa5029I#wCFN2eC} zdzPGMv&$J@6Fyc0o^?=d%nLCGm&4Y7G88pvi{U;xYz3? zcv(?tur$Sqf%1-X%eAoIw9V%P__Sxvc=}AZ&PN_HH)}UtPF4k@T%RN>>JHCb>W6*s z<6U>HeCe1517Q^7JH)1J5;NH@RQ0iZ4{H%qVwP>h>6hFXXqY{F?P3%>V(3F5E$^TF z%TIY!147?$DJ%DvBv^V{XYn&Oz4SI`I@;A+nPPdaZ(Y&0sPA?DXJ&kORDqnUp<1(d z)s-}BKJfxalPt=|&`%f6OJXz=R)HmfA4c~;Zo4%99Lvd>7!fp1vTxeTRy`R$M4nf- zSL(@X5tVtz_wRHG>G(GnEPn7teP(TnM+%)LJO+0pS*lY8#l7`_?jmF{VADf*+UaoK zVp`f81OkyTW;nIb<%#U-Zt<8e%o9t$kE2hXm2Vr^{C{ec;I6OufZ?bw&7z%MAH)T|-{Ba`5^<@zVq<)O)53?Q>$9WAzH{V>ZhV_$1W# zz7B7m@qu#9fO;5_)PD)*bpugcwVD|hZQI{;2!aswmstc1#k2%E$%SbQ#)CVpV8KyM z>r4B@QrGsmw!?y4wdU}E{kd-k2k4ER_l<5EERuqTs#yr>uSRAXZnf;h^%-^os!Zi$ z`NNPd#Wgx%>H1s3s<8q`L3|4|kiVeGn%UwoYM>|H!a-I&b?dlv>Ex{Hp{~wewn?Pt zz#p2eO~d_3`GhXrehNvMACfm#%iDSE)+5}!g0!PY+G6PLMXBJ}ernEEmEul~);+kI zzG^@xVc~#$((217Sh!})V(}6r{Icnx3Ey$(tF_~qw(Q_e;(U{k|>wDf$js)`=TXq0^5qegPDh*G;TXOb3rDF3Y}9oNaq5Kt)GGMD#_-~cO)Tk|Smyffu0Ts6n41=tE-JUNgc?@|swWXv?G*?^|!v**Biy)Mcf$P^q1@>?*L7_To^x8VM(6-YNOhO>QncL z$?!^W>W-SmNd^hfGf|niNPTgW`IBQ@D@J&Vj&Zgs(62kltL*=N=tJ4`Irc1yal=qd zXInZBt5*@Wf2omcBOsaoeFBOCE9SBmxV;@Y>}$AC)v`k4n)2#l(#t-x#ydr~%+1a9 zBd&8{u4T0_kHXB~->^VQRy5awDx@0IkKTg>T@<2()1P*is9V8ppJrj{q&TuLGn{ix zEhoa`rJz(*s2ruC-3#ARwP(gwS#jlJgaplAGvh!whb1$G>6IbQ2;S)<%Rk-B-l$<5 ze|kiS-t9KKCAG>E9sIv5MMBoJ>1Qi#`?1d6qWe=8>+uWkly4qH>peiFEddFQwgpC@j&W7pGv7` z{IoQ+DyeN`rcF@3QcvbB>84Iv*!97YNGDoUkj4u}@#zf0tlW z_tQT4plX)h-#W2>AAxfh`|x`1i6l#1Gw^ECYfG1F8Z5x-iWeQDfJP=n_K-F8l}HIU z^dR}~=csQVJ^>F`xB38!#f(NmBs0UM#OJ4{!|MiV&+;qZSU%N%Rc|8#(@#);#dt_f zG+%b??>oDdSO5fWt&9sh1tGpWas`|Aa#>a=mr^f0bQ_e++?%f)4m%FqvI`W6$Xa2N@tGUu2YZ_~(2QR-vh;eUNh zDH8AOm5gKM*7(`t*Etwc=Le9B^3#vc)if~Te4%UP(Q|sFoM-5U4G-pDXCsHlVkO_o zpR`nh6>I*Hqd>2sV$g>uf;L|4d_#$uWA@{8rWg7UhG zmx~0;W$I}qBHzl|-s@JiotKrKQyCIPAgn<~xk=>BggtwlnEX=IeH$Wm0 z<~-rhk{=r4j+P!CjhW#pevgBhP+Rsod4=|Y_MsB_6@1wTY26>4D8r?R8Ug}c;Dd`t zJJVT#)!a7C%+)_y*r*v_V0AY;qDpm|GXcU-nBnJZ)uW2c zPASZ9O0V6^w8IVJZAjvJBzN5h!)?Ddi<`4&D?h4H@!fgWu$xPNxbvas*xgkyP3KJ= zu39ZMzLK{XI+Aw}R|pA)lq?qNC~tZ@uR01E+WKWSc?ww8-Yh$=#3D zNAN6H$ak>Hb%HctA48oPaVhQWD7t}v1(td5sS=Kp4*I(t-}Fcgw3w>*>(x7qO<1}5 zbr?}*nbyqEQ)9N-y{zw-c&qxe7zqPViq!Wi?xIH2v7gw;-Pi+yYRdCH1n$q-GpfAq z{E^<)4)7wli)JXPJ2r{YxJOS;4>oK(S4t+#?|t(To{f1O;pX<|C2d7MgcPndpq3zC za(=s{(B*+?B4PcFQs$l9w8kS79Ocm%bV7k#nMU26{YPq=BRdtxgJVuJK4{-(G;ZxR z!_XKH&^_isUD@Rbm_T?mbGB{pn5j7V{F4J$IX+__5To5svV!uYU!`(f%YYj_`Jt+S zZ;0q5Cm5+p%a_11*>h1b#}y}6`lOh7XgrxkW>(tloXecwvd!ll#y1HkPwxS zyzqv;cZL5C!OO?l-6iDzC#Z;h%e)}S{d2;_$gk++g9-6-cXh)8H~-ziB^4AD;2O?8 zC^XzW#2<_H@`oe6oqYT-K7JR?I7@n-dtH=(|69Tt?eFC0j={S7cmw~#GSk(B3td!^ z7jEp_{C$Dt`xoow=pEqV=!6aML;L*~I2NBUc>(79U$Boe+Vj6q*vp<17bvSx3u~;I zV-OtU=i}n;iH2iCFlhKi8yDXg!Felt)G*)MLPEnPBcsUgW&i|1bnbN22wL^sfP%Yz){vP1%1$0+8CqTJ@R^vHt;y_yW-Y literal 0 HcmV?d00001 diff --git a/pkgdown/favicon/apple-touch-icon-76x76.png b/pkgdown/favicon/apple-touch-icon-76x76.png new file mode 100644 index 0000000000000000000000000000000000000000..a8538bbca7020ded533a9c4580a60c053dc2061b GIT binary patch literal 5679 zcmZ{o2Tar5*T;Wt*+VEpHnc1mWg|;vl-05=$QFT8mSEXK_L4G`vZsK^5Jf@1$=b^1_=7GfmfLJ=#(NW$fz}FAQ;^^2jASq7g7mOhgQZbGigXAu9 zKR}iA=_BPM5J(*sf5E$3Z*_kS$Dt zcwLH@f;i`vTSjl-d_K!OL-ZOAirthYkw_LkMxRU#Zqd{tq|pOXmRtRXpJgO^WDF2! zW6<-27A6J?IGq-}67w~iK2LNfI ze+?8;p%HWuqz*tE>ryY!L!goX=C8+X0AQI#>u6boO#Uhg4Y2AUSU`bgkKSoQ9w5<$}Vf_whV60zcfH`6mzac z^5mIK9nSaL^<{9UhU)*;+qLLwM9lK)e18Yd0uqU!Lzz-8(J`Ydl(I}_6=bWJx5oM` zV^Mj)08?9N!KvrXbnoC_6AW7tNQNO)T;y&0e-2seY$JXC+Ux8|B$!lF#TV%MjxAtKeUUmEK8z{#t zqgo$|`Z01uYsI&ey+NSA22fxWNA~95;^p~f1*s#3S?`PM;?N1VG$Lwm;E#CUHk3_r zAS7OgzXvBgzG7@5a#aXApqZAremyUhw1IAF`ek}AMfb0RaQANIRV(wg`|9p@lAxf9VMh4a22 zQ69E(ylu50H@*4;{#5ZT#7Tc@WFr^l@y(~~oe@R7M5mL(KZ_h4y>8~_=J-1Ma3{x2 z5_gFoi$V9(Sz)Ox^<-$y%U5v)j+}IK>@lSY4Vu@ulu0l@ofi-5bf`7LCHLlI(kCBy ze$ASw8csfEM9r>q*O~57sIdc;LYMwtL%rvTDca?xSE=(Xh+3L3Oip&=NGzheT`DQD zD=u}3S)%@?SXNTfhjiigQ#rLaiEHjWWz$K-JH=&QZxS?0A9+3wDlIizOR4=VlbW_F zWAUO=D5g}6jVGOzdw;Vc^6W%-OL_~6q&Ru8hMm=USWM$s+ZjCrNk{he>YFt9oAV4hv`N3fEm9AHg)(_ z;vK^L8`2m0URG1~3&jyyFAIvQW^IRwV2t$BR~JSUr;Gi=QPaxQa~mC?>vSi#6bsgm zKGqcq&?av5hWzu&(={7VVo@pw+ks*Up4KFgaNTGar^)kb0_2v}?g|ZXTs> zHDY-PR=&FKw*YFYobAcV9kl>miRy*A_Tk~(Y#!GRQn<&2&-J-yOp!AmHrwM6*Xptc z5fWVuvyFWc<0ED!QNhX;+3GuBgIr6SkD5;~I)Rtea_Aj}Qh#q?m(Q9&pY=|P>Br?~ zBjY!YUx7ACVmkDC$PPL@Zk_|vr>EOhCy|C%GEHvXy(_F6s8X6${1>XUUc zpz+W(4|m>{#W>>|PjbEyYKzkciwc;RaG;aO;TW@?%6qP~VfWLRrNJdkSqZo$mB0uI zAf+(PYMuGp0y9!Qk`Zm{HT$+_vD+HM^hH38Eux}2bakXLH_M{aS^V_dwa4y^qt9de zAG12U27+EUCXc_H7}65=!IWdrei`;4NzH>-Fy#4xiV~LzSG^$0f=|zA$KHkUqttS< zE{b^~KEGv)&}Y-q^oN=(^&x#RaIhof*%f~O+IK(qC>yQp?JM5C#qzpyEkAu3p(w!X zde4}XZ+}juAe~^+g;guC!=&>#!d=?6*?iAvg`MAgX%PIiRmI~ImL40dFyDAaY2(GB zyq}*?Pi2Q1M864is6LdIhh0G!zJB+|;QO1in9f`KQ>~8gbvZ0#BkmKI4Es>Ryj0Yg z2P9*8s8!sl3B!PyU@?z#D`5H1XGy?l>%=*}+FR?ymP1}(C{{;XV195DIOEG_9YWQ+ z>l!t4!$Ehb1e4<9aMhdpO8k-P+{O;A>)+{f?cX5h6K3$~xo%E&mtQ@zJiT2FaumzW z60{;q80(8lh!7rR3)+9lCO1bbqpUz$vjWUV$CNHN4P=m#)0E**C$vBi-ji-eNWlA7 z*kR%ep3G{tmD;u%gP1QFITf6%zN`0wCshs$_Mf>twiM1pH)9WZc?P;N>p`A84dvC$ z!_QQn<{IVS-%@G_Su&(*d(=;# zcxJJKv(tSyM(c0fm(#kn`uhg9Ooi#3DAb7I&o2!>*Fg64>=REA(JJSZJ@;Q3ndzl8 zdBk6}&Pm=FpE#e?PTOqKhKHeVd*?lwD-SG{8_p;Eyu8q{13kApcx{L0+x9tQ&8WGG zSW-9TrmtK2 zcE=9KpRi$tO}|&IsQ0=sFOM_6%e)bd8Yf}7S%$U3eJnFxKSGy1x%~iMJ!t&Rj9lZ!_o5FC(JDa$2hr+z&;sONIj(Xk!&Grna}Qj{p96 z7ZSSr-reQdo!?UjeqZ=jIayrj#_DWXPv8EIz@SpBeQ&^@8}YCjUA?pLQ4l?vqgGqgrUOrfqd@C6aWW@E*H`rXBk3`5k*srz zczMk#<~w5yCsJG2eK=`FH8gixGIMI4F8=)829fv7UN+Nku53(){)ov^=C)b?;!0Hs z+E%_zp2@qUkKAp74|<%;@GwJWd-@Hzv4#mWAOE%Q^d{V~ORH)3@z@yTag5SYGY#V%26vN$ z9_V}=Kt*OFleak6?C~_dt4=Nn*dcoXt;<>ApY3@R$80NaYbbbM`x_lv&dT*ZvrBbHl!5zF=LctL`QbGb7L3fzb^|Dxn7misAg zI$hMDzr>OK)imP%Q!esJHFtVkl#b-jWHc44)3$M)fEv%-$dsR3ZRj^>XLyNLY_Cpl zvpE%KrPhb#I8cA!yQfJ=BTtp53ilKXdl0(USae)rhgK}xaTg!;9-30pjvPzIkslo$ z?jAe!FPX&g+R+(X2oll?QpztcpjqVFZ98-KU|MClwEbRToXISsRkJ!gs_7)bWZ~jX zijTIP$`swDdR>xb(=*iQw0Caaa7I+86i>xt%Hs1~X15>ldG*F>lO_~3rE4E-N3VSU zvmM_!&uY`os%4N17cNl~_;hzYIw!fIp*FceJ|e@g6ww*pe$uWd|2OE7vAooXi1AC+ z=C4H>9CEwUSVqg!lS7NFY#Y@3vm5aQd#~a~?t?2v!hCfy69~GX{Y%qvi|V>4{zd5p ze(&EyIv?Lk-+@yGbE1vq=}$aRBU91tli+fbDWm&BI6hUpgQ= zb~WRYTD~TG=8w}L^|A^cqWs#`27A$xzODza_B3ksGWv#de7~nU^tJw!Zd=YubSFJ@ z*HlNYv~Z8b9n>#86C9L3G)zzE$ZYD6AA6}lhqj;QYZ^uWu8*KN$eRl4n{<_Rg`2c< zB$axn%9qS~j5@o(ruo|V%7eEy`znkxU#s>}si&k?_T9SB1CkMOUWu7|cse;rfs6@( zZd@oSk_rhw6eA!$VoFBvwTScBUer%_C zZ9!)1SaFtUmVJv?Yh?``MN=aA)p2U1!dDSV2?sUzeBMn}$=C}QM0{~8eg2`iE+*{?(V}xY(lW7}rWpop zU^-xLxP_-y_0m220_1?~fhSg*+M-4$sD|Tbs=rKxX&*xBgqDw$GV3Q!&8hRK6^Y#2 zY0$=Ni2)K$@T|XaG+~oWRr`U~CFLBoF+NUFG4*sXM9&~`;8zv9nAL?!)H?qp{j*YH zlY(wtysD7f;)Swwp0*RE`+ObY{pLZ{h5RKFplcoA;uL^W!}{Sa93U?%rz#~UCnc+3 zA*ZaSsGue*D=8~?u^ai?ivOSC8y$crpAJ*IHUZATJHXzUs=l6f$SYpD+18edB>v0l@@e)JLsfC$k` zW9eCiSPe7TAgnN*XvGgM5TQm3Sl{@Up3eSG-cIViXjG|zG_cMA4cI|m{dY(JTGvFU I7U>xKUxYd;WB>pF literal 0 HcmV?d00001 diff --git a/pkgdown/favicon/apple-touch-icon.png b/pkgdown/favicon/apple-touch-icon.png new file mode 100644 index 0000000000000000000000000000000000000000..11bb2796c95a199149820fa5f5f42766dadf0306 GIT binary patch literal 16417 zcmZ|01yCGc@ISbV2X}V~?(XicL4vzOa9<#}2X_k++(Yo-&f@L_2n2R=4Vf4j005vVD#&QPw=Mr2NC@v|(J2Hj002m4FDQ<>=IrohHj%765f-dJE9iCco?M^BF27+5FtudJ{Zncww5|E%4n z*(+JbRc078Ia*p;blgR8wmr&#r%lgiWVOrz{dEQ+eYs)%+BR5&VRNvd+- zf?csYc zNB|(7J^&z;2>=kdE*nxLztbXED9g(L-u~N)x+_xO?|g7mFz^5X*l7McfWBqo-tRXN zJrz}D5%*DGv6z8$mj)96fXJMpjHHh5+F7?x7U_}K;ZyYqkEkC)IL~MwC1$7@9QP3A zDsH$8lRg*YH)=W~L*=IK0LbI{7TVU0N&WI^Ymjw)*^P;!N(r{CmIc0SEbi|-AU5q6 zVoY-mLGPN5kgl6z2jWdp?!K?&MKf2E+}vbU)zw>&K#0$Dz%-&Yv(f6fURzUot<(R0 zsV3fB{s^aLZL~TEgNcygk8y^;weEeMccLw9U5k4BfdgX{;1QY&GU|GRAd(}X1Jgo9 zU-b~K1q=bBH+^`0pF$@>i6IwaJMcRJeOD6v@7)Feb!Q_U61tJQF}uNnKkxiO43!V1 zfN=$kaaE3tjDy4!uRu<)6QFIx9wZj|jbB;TAhJGn5Cv=}paS(@YBN`nI#`6#sLyG~ ze`liam&6buMmk^%<{W_>HWA=Lv_fxVEs-<}Bk~L3;=m|WopLL0CKB|syLSe-2XC^B z_DtN4ad9ffaCO>fNCdXzz?jrDBXdLC8@s~#Guq11KqkuR!`pc&){S`S4D9fxuK3oL*?hcAHj|6PF=y1xkX3Fas86Ra0}B0o|W z@&>F3d<%Tir?&lf^THg4)?>HB`7NjeRN+ku;I<@DI^{L@zVGz2H5BE=iQHs{Hfyf1 z7q-&;ryw?mK7v;;Gpx{vNP{e>H5&3t&XLr=U`7yp>`cEmP2)cc`iTx?y{GE6#x3Wf z0E$a@JqJ-5Biy<%!>%=hmOp>>y@b&87%>zC5{e6664R%UexS8x1N40Dy3K=OpP@8) zwH&O!(?q`_Yn~?u1Jzdn&*&utnSe$3tvL)QnZKt;AT|L%lUxt-PbDo6)--t|%F&S` zq9#Y2n`bQuEr=ydJApfDJE?uBm!_Gtm+^O0p|g@7`?wKoVr^)hI`F1&AMRUGJOS!3 z;u7}Pq4Puw6?8?S;IAOw=%2yp7b}6w1Cr*=h*&-^$%@G!gzpu$lx%MXxO|f%e~bsW zLlWmRsFLxOp)=#B<$C}z-C zb!CRu4EsJO0ceJCId?7)_!DU^Z6j<6fHE2)o}jWgSnuP3e08dg4i*%75aJOnl-_0e zj0iH4+PTaEUSZ4$tgK9iPW8ngk$AqqedRZFqRC_Tfi8)NP-H9B3B`<3O!A z5%4s2p}$i138L{Y59nnSVQ?KkK>cK7^-@gBPpGp`Xc(xQVzgz-g=&HM1F7OsUD})l z&sfN|o8kRNjD(*cJSh6nC8&4`ForRpyc?7GICgqon^K^D6hglyB+&Wb54YWKp`247 z@rG^5?;x5S&e)67C-9^B+SRH3hvPi^TOqgu6h^Tr1nc}D9MAbfN;7Y&6AvWo=O&~g zVa&y`R>K3;DT#Z4`<9K)Ub+OgqDB02B|-$FtL$?}Pv1mTvdWFvV0}fc3a{s7RF=ql zOq9~Lq_Ly&q=SaQnj-3@ihHKZ>{j(6ykae$t6D{PVf!rzz<97;)^vh*l=oSMJSL?$ z50xMf-jF92InE1*1Jx(_0BW-Qd>&rDa*f4FIUY(I|DzP)a9K>A8 zhvkHXgy~QG6FOB%Fvv8%*GiHfapR)vW?xnm?tRixU(#_1I69z27bW@dc8cY5&I;{m zznf2Di1|TVf0d~FueST>Lm0OF=b?{pU0tD;}SHj_>s`yC>!^1EDGG> z#}56NoYkL;B?qdLD(+AlZrh2Yl%OXJ_hGZzYORszmUfZ$bY_cqxUmV$J~1hm%&NBn zlI@HoC@ekT4W`D8F&4^KH6JlfFkTs|5x*eQ!nTL)E#K(wJSmi~eJBesR>lSc4UXU$ zIKQ9`O%!g)&hJYzC~2@Uko|^<=xxRd>ckU>+p{)PFCLt9OsiCBwE~bqNzDTdj*ez6 z=nAdoMukEmX;UdU#xE}WO7yrv{u3p`O)=|j zc&#k`8L~*qcjI2}pEGMt+Zjiwc7?7>8>~9-<|8Bu$R=XoV#D~0SWdlg3-GiVh_0k@ zd&N{@CS$dck4Xyx@p@{StNM%{H98)jDv|w#E)N)Bpe$xR)|~vViczBVp`^vf9pjyk)@sC z_8$7ECv1YP(>FE5ClaTe&<(hcBJA?WzBt;h=;#^ASl|~oL^uk^za`4DpC(A!@dzsu*PM?Dpmh*SF8N;`?7(zm+l|m6xuIcFTRvY43p)> z8M~<_zywO5aI#YSwWk2-MrxyXZ{cBIor*)ljJ*e$7_`om-|}ijGp+p*yGNxJ+>Jc0 z^HXoJFUDJPiWSAPr0f#XOq%JF zWDM~_S_^;K7F4~YVq;K(-^T7SAtejc1%bJDo%&DJnHSdiXB^HTQaM;}RR*V8yBtS; z7Gr`|!zI}bgDYtnX3t+EIDItP)*n`C*XN!58LiK@GsqRte^C?-wO~mm*a6M>cPDh% z%YBVnwu|7FT|rx8?NK-g$E1Ij4eb6rGkOl7SeLi?5$sS6e_9fpwJAm#5)vL9pf%42ywXc5)6d;kNf*r&ixhnwwd(k|IY#yD}^-s#5Osc zX`y{imi!S5H^o2m;*$XSTOE!&nAG5i0F=vEM`i~f9K(K^r^Z^x6q=qf^~)>4`zp4% zw3wGbZZmtzTncMAUn?)(0N;um+(9$Ntp2fPi7Y$OX*lQuBq!;Qekd0QjrI!7=KL3_w9yhnYYS#vCG4udZs&Ze~ysQmlE= z@UBaxOQ0tqJmY+i!QotsWPNc8gFLWh3m%Xl!k9@m>FHCnKBAcbvAJPBdJ8JtUZ=^c zyxlQz>G>JYy|JCs4F18rrN<0zn)D-MY>R>f)VOwou)a_;Vsf2OqR2jcc zyS`5M-IvR6o^z_DZGD#GTnLY*6#ezOT|^O9R~M&pUsEtGzYEc<$^eKj>+>*5zmL8s zEM=pb#M_%G@#ufnS~p`i?xrF(X%gB)zZU9xJ*DbcC&TXEDR;KmMbf=M^5WIBS(f|Z zn5dymR@}s;A}brMu+rc5$AfHyF5g{&mh=&E?)s+e@44cs@4(qV}s(}rh%?ZZyO0^Mr-der@SR#J!ak(ypxi8U<1wYV7M{ z`EZuUZI#?o?GIa7W!5-+ow)^E8gdMr7=8T=JWA{x;=8}GG)5T{8q^a@&Owve#=rAc z@kT^yoWq@sWT>&Ks;MU(!ZNHEodkMQJlD#4#Z^y3srY)ghm0Vems{MTPO<2muD_<{ zcr}S_A`~iqWVphXBJ?26 zqTPQdpD3<%x-RtO|Lqi0Rd+C{1O=rjSa~-8IF(|-r%v_qJ7`R@bBJwpQk<&Xa@@iY z8tyt2u&sAB8xZ8St4VD3Q2uteMQUX?THH4K5ud`ycd)J4B~tZHlYTCk!zla`mi}Lv zsK^RK>AicTcH;6ZOEQtVNE%R7$OD`piuzBfB7dp$Z0z9huG6BvYmHodE(1yTQ`BbU zBVkIkXo+nLi=9iN$FW=3k*S^K%NhbPiKV5<#;-aCrFT7ft54f^x;|D};yL*TfzFH~ zqje;lEst0B+C*tZ`_B+5U zm?Uz#4vy3{#@ZttylB@g!d*R$Nw2Rg3C;g3g}z};MVtub{uWynYvI>E6C&M%TNbO} zE~2@2ZYYlvtgMx&ejmM=JALgr*ypA*x04BbtcKUtJ1-}PBSV)^;l>M#$%2YJV2{Rz zZ%DtbrQ;ZJtxa})7VhmdK-fM9%hFGI%H3qMiN$87YA5d|foDMv`Z#QI3sD4f2+QbB z9ouO#z@;zpJ^i$0LU`K1ohwXYFT9QfGkbsJ zQ%P5NJIX7HIarJc+)r#HPBb}(TaKG_kwND&*u$cByXhC?!m;!xg*JR&tBNTc9hF7y z`lO$dUOV4fVxB@emK`7p=IcwGeeag{@nL#isK=-i@U??BA%@I$SnVsz$8Dwdgz{v- z>n@hYwRf?+aNqhU{8%jVhqX1u- zF3qkwvX?|oA_xI1-el*-bItE~z`5J?WmDXV?0F{Sq2OlR@$CCNTbnZ$vcWlttJie< zoqRyuN>4Lnysb1w8S=V&e)3Wq?$RS$b}D7+nxn8%&P7h_Rn_lal31-kUzGQ*Y_+uxtPRQ)=w>0(q{PUz9MtLZ|Wng$m@Fs(n-JgqJ)M($IG0w$&VM zayry%&zBt2{}JEL^DX^cUQ{rrYotV>j!0I!9T=#=mNH{QbrFOy?rjYvDD1x18QvJb z026&idM=E1J(uU2R9Yasuz6S_M7KY zh&N=uCmj}p&k6g-ek1OG&s8;b@jeox;i)#Sx5+a7flimB2VY*j@GQvR&%4%?lz*Je zK0Wz$7N`6$y=k<{%|3N`GaEMYL7pWiQ_dHXt|QH~%eQ+Y#i+|nhjB)!dGECFgFF1| zUfir~jm$!}(np&!OD!37DyQ8gG_ArLW_i8`b6Ee`Eib>EQpIX?+F9m-5Z|Cow=(NTA*ryIGM+uMM&-n3yV;@_uA+vFnP z^eY2C`@QBejm*hG+SLgD=|D9T2nAF6Z2!#deYw?pk7{B;n}JNs1MPJMy(h7&pL@*N zAia6zKdS|9vIN;>bZg1vS&5VkQ?;4Mi4T4gLqqKbxA8{j$)P6vTA*#oMa+b)#&32z zk=;kA3E2tdU|eE=Frna~ah$-VZYA-EPTk!eMw)YFO$|XUte$WE*pAOm5-cxUi!IsD znWsA1Z>#qc_2l^hOWA0}?}g02k;2DlUy(rrTRtnj+R8Jus54K~kVsjSYNV(n_Nyl6 zI4iD+ci)1}7eY#_g@=w@4EyNoa+Ke*L{^25ab;a1G@FE=!Csl(Xj|pW)*_yt@{eEt-7D@7!Ow?}sWA#*k>P736VG-(gFp*A>> z{dH^C=C2>a)6M^_7p13hbrgp}j(b9kr>HYT7km(6((-$d0sJ!_(=%GBfd$3hxIGUZ zyX^IF7e3scYf0#@4~(}}m=z}ZPgHeryaHLZ#HcD#(lIRWyRgsQ)X85}qp`I8g+-af z2d#;)-^DB>rcV36P20YWwQsneYKeKTvN%)?$kNrep?xytjIs?0$Rf*q%;w~eC)*Q{ zB0!c5N=+auSsTL^k9p$S)l&i?ggS_5Z-MUOgqd=IUtGs;_MTbo0 zJR0N@wPUxXzb$j3LePL-ta~#QB~subI*sj=?5(F94TVXk>0j%l+@x*))^ehAl>}k0 za+!UE4VD!v$g10h@4%hjcUR3(w^vI>WS<*~V`jG6L1oGwSqKh00;erq<}bPI^2sK zDtICqLIBP5CCe9alnvVVF2>x%Uif-Ryd#Wy=V!3s`v-ndz8>L~92g*8!du%nRGi#> z`JSCi+MLTU$cU5z8(I-3nkuW~!0VZZe@!X&cI7cJ<5mOrPnp|~!#?g^K;5rPvR2!M zh6wmB2Imo1I=!NYS4V8ySy7m(SxY#X4H2#v*3D(Ot1dqMMNC;nps0+fO3I{JgSjja zw-Crmum)$is{=y5_GT*P?Q<7o_i-9t2-^4Fz47gsab=4hE%FOZ=Zn`j)m6~{@%B8n z4!A{wg4vDyT$TALIz9Ocd(6eIj_l<-8$m=e@;SNtc|NzO1wkGZ)iWMHD%&E_BnhI2 zSoyJ=Rm4wI`pdO#DqxGq;L>d1@_6>ZQBc1CDsE>t)uLO<%aRC|(0)&%gCJWfKs;Xr z1)L%UbbQCG+~a7vN4X)(qeawyaY1GyB|LCUVs`+V`Y$2sDPe_akQ*6 zUmkyWMaUD@SriwGesI?wJ83JDd?Ulg*B;uMv^_A6GkWl|UyIN7S3m+{?RV&50p*Nt z0!6i|#}~&iTxidJN0MM-=c4K_XRVuMtz0d5I*Bl? zZ!nR!>b`dY=A1d}aFGN>N#mdDEnf{@@pT)cUsUbRCR#vP>4ftEXqK>Fkp6P_#P~N7 zbrRm&>NsCe!Tgh2sDY9OP6vvwee)HW)W}AHw(Ylz3VYugVSv~KWqAvx(DYjm#TfUEAV6k z;GTZxkIL{_h>!O2pOC9N3YPAxHtXAj!kn44#hVS^ph)ScsFjZH%)7Qx5AlZuNn+xX z8bgDL_f8hqALfUXgq-R-R)DP)OzY`MfqZAt5n_4b2^*?hcVixq^3tbFVE#5W19LlY zvui{%@E5{R0=v{$GSeUK=w}Z@sfYNGGW`0atn4Qe?3tkKQ{bE5kY-aG2@cNRc z=SP~Kf#!|EmU8hK*1Rn&)w?*Kri#01h6=i0x_ZlUSt)KW_a@GC2AwiktIc1sZ)!{o zd~_%TG<3sr{y#7@|{ zpH3-P#z$o>e;#8tS~%p#zENl8JTUzGJ-2wUI$8+}oX$Y^Ib6hybaRpr`Il_h6(3CS z6;2Cf^!&YW9Xd6c6#Hdm(1B@78Puy6k0E~()cfO4aO_Cwhy_ug3GoJJTk@YTD`GoC zudkCk;TS(nRyOnNo`#n{wNGT~V$8eiXFPh>2$m);+Aequv|hcJv(e7$0Ux5ArP>}Z zr*epBa+?&_Ym@>ZO_fmJ|N5k=C{@LpTdaNKk2pxOOzZrJ^t=Bv}R*nSy(CNS?{X7B>hILB^xukGT^-xUN=rC>+{L z_N6ZS)xX?Y>Krv0utlh3g;@A_^Lyg)ab7j#S)O_G=JW(8?s?P^TrnSuoJ$v1ZP4+Z zc-h@uB;PYA2$v++s=xPp9c;I8V!C2yc$(;SmJ>X7e@L{583jz{7!)2TqIIRuZHn-l zOunEOD`Mv`pzsd;n>T{w3(K5SAc~^AtK2$Y?iI(OFN8z_*G%|Cun`L_Bc;s`DQwVA zc?(U1Lh9Q>*4=88G1J+r#HEe!VZVkso^(UHXuJK&z_zWt?&s zlHWdm+@D)K+!4Cw6#8+NX21ySfT3esn_WWK#DNn1?in$sMe0DtYdV)UM6;Au(9DE? z75x^a=k^@T$@aQq5GfVZ8-?&Eh#_!U?;x*ZRu9uLW$A#4hw!oc=%_ftj&KUF9!tuM z^3RQw|K+wb|I_o$c5nk!y{B=m<9W`&4+Z9O>uW6Lu12&cQz^T(CY)jHy{5(;iO$q;;t*EL&uCy>A@u5_fw7qn#jI(RNbaYDf8a4 zE%!H)2Y6NABv&b-VWgZ7a|#Kc61+1z<^s-a7OqOOe)X9w|M~kq?>^t~hrI1J$#6|T zK8yNTX>^|aBKWXwHFw_lxBlluqrXsIi%;EtN5r775hKu_ZLghvY~DH zKQx#C=$?JIQlIR3&HG%HNh#8g1aib;5RW=R?+t6SyMG&z-Qe!Q?0iRK1 z_*LxO#G#@GQ}SE{x-ZWTBXvF1ujlJVpJ-DPgI?&5uwrl#Tb+$osFdC9AYRV329b}O zl7SHxV}?HfYff|`gU2o_zF7%#t3jjE(-LuWd@{1Z6rn^qewVfiSD#1cwjRV0yP|wA zD5x~Hkwg^CCAuOF$)7(kZC71v*`|f%fKe5S!kh`Oej!Gr?YkP9O2f ze*Iy$OUY8||J_Z*W&aap%7)Il4Ca{WfGTOnVeU3#krW46dg<6$XA(4^X;N@T@Usa zZ8`DZ4@uDZ>Ezr}j+b#}xXM zV1*g(M~+Yep5}nGAJsh6kFy`cV+{~tc>nJwAR9podVG91cQ0zwKw>}jCn5b^9Ax0X z*8D-Oq3qnsh*1H^3P+3RcRZ$0%_fU$$$gn9YWLd~?qTzOp#nc$ih@o%It6Whg`<|xe)5=*ObPzj*NInWd&h=t z(b)coh)F42`*C6B^sp%O(um}-E!CFAlF4oIKyZ0iZ)S1s7eZ%p`!=th>442U&G>eL z(5c_*{#mlSLM{B;wint*Nm|5YQ9__2Lk!flx2q6m@zN4%tDxs`!2v!(rH}B(ZVM$> z(F38IL?fMgL&tJ-ITw){aFzJS=urbN*^^c(?LFx*MXI&i!NayBjTSaEE>2Vq=J@&s zaL2sSucWe^$BPV3dJ!e~6w>C+wWF3d`^v($rGsE%2m}-6b+d1VG5>D|tgp*m!Rx4a zu&t4@uJuaCK}or#Iy$P&sDMF#3T8mt_u4udHU1p)%lzKi+3y!L;wZDIi>=nDOH=f>{4Hqq108bplG&1u&%RHOVTlC;~fNN5?@3UVfaasu*$o(nn2>cgMXgpKwcqa&2MMDCi`rk zH55Pj5Ibcqk=a+DNwm#8i9O71w%YM2mr8C$Em4+lkM+$B#nE?V+oi_@w?-fD9FwIrB3!LO*SPVCf%3hR9SpL#^uH+9_BR? zd{~`?zZFV+>UZUDdpYkq9A9${4*Ipen*F_=UwT9{Q>TAZ*<5!QKwP8g32{g{q)V`= zP@xrhfaW+zkQ9TdK4ysXQ;Kzk_jknN!a%4!QzI`$wxQe5bd+*m6H`W^wbVmQFB~SfhVINWYK! z!>F93&Rax+xqTwH!Zi8r7;g;ecI+N$)AH?@E|J9h z4e=Gi!A!7>Lobf=J=EvD;NXVzxZVk^w<*wlCa`z7{Uhj) zI^|u?*-f+)9xdOgQcUey1r){D?2=4-Y$L1-ncjmX3;zks_dmsd zVl>&eb@@8Az@y!WnJ$Pj^-&R$w=G{V!&CpvyT%9k0_j93<)wEB>N^d%Lz`@5IrLpV zBfGo`q0x%v{7iDD1+(||1I`nEjyhbc$Hw$8?SQCLk5>fHZS*Oo1cg-Iqz9js�^S zCwB)j4vuz#Q?<r(2EML95waGUW(y|r`Whj8U>7CNO+(*-5D2n5GXb6DeqrsYEZF{& z-}ynY+j_&0;|7YU9Y-q0+{g@_DIGepWMEktI2J98+xyF2tg%OD7aC-^uA`O6Vz@BK zh;BDe38oe1x=%0;qYfxlo7h|(*D;tZcN?9Ox`~ieaIMmSPS27ux0_AYvQCN?OhDV3 z<$nJ}_Ohsw3m=iOcalrg&ysBrbRn)4cffM~D~B@Xnc~3_bQgxpa+hNu`-_FR884hpMnblUK_h2OpEeP7;+ zUg17aQ0aGZGgPx3fEy=?mmMC6J z59WDu#e%>^Y`g-+;WscuVi4B-?pbk9G;t3R;J)lX1Y?w~g~UT@Ew=<;8H4w4P+?5) z(dI(JbL5w(t#@p@W_Yj{qPkB5>3XgNP;_@U65D3_0=gBO#iQ^G-iDu8nq6u8wgDlM zf061ES9QJ|^Tdh`j?K7!0-DOAl&jHRKEQWW+5k|gK-ZK>*4W%~ci^bT-1iQu($ zx<1R&geP9CeH1iFROIiQuaR5l9gic?Y zys_@ELPTNh8bS!}u}`Ee{y9T73ZTI%YCBXsJCJfXOEAYxcE8&588tPkY2`IFSeM52 zMI5tI2(0?V8~ktapYpeLz#+|Z*y3jotha*ntCiAd3mHxKQz6K&imnmk!Lk`iv)cYU z@CVvSL0D73V#Ho&Qb2t-reD_!5}_-l`V&0l0U-_3f99!%oCoS%99k%)vn%uru5ec| z;91GRWapcy=$Z+Ex2EY#=HLEm(^!#m)ee}-Q0}rs^;;H;N0?{tx=XM5&u>!*vZL6n zz^N`$1dnoXpsTJzR54vYM8A3qJ(eee-`l2`a7fK}N=Uu)<#FW>+SrRp2r89*7vV8c zX+D!bp}cg5oh03(fLB1Y-}V*Rfjcv}|2FU$UF`<9#|M_7JjiB;_r(s2KN{gr>ejX- zViVSsj!oQAGfW{Gabqu7iXvW{`ejR|~Ku!DX#^bb?JLuEOR()3!Kb#^#{= z3k|L0@1SJXwjYDv4&!Ed5`CWi?)S>e?(w#NEz_=4 zEg#EGUZwP%hBumD_4w}Gy#=0t5&e zCch3ob%{%aj|LtF%H#&0kPUpVBq%ZC>PhhXk3NG=DN!8LaMU)j0adT6z6$^geK9m&-ignuaqc){kL z;iwJ!qjB9a_(GA0=hFNhA7M&YyDH{|%V#}4CxU`-fgaL3pILAnw;~WmI{G{aXf`9T zHc5=a@!g-ms&5Fd@u0h3At3zb<$YI_<*y=U$gD`!|IO2(`%?y``Pf2`A>6a=voY*i z_dbiv1(azgq;zyDJJh36iu?1D@RH*Jfg@Up!lde!pHcLw_}IO3J!i2VG6;dS-J4py z8SO_mAC2LK(O}_>Jm;Jq+#zIt9;0jI4IyGf&p+u*Dz1nLZUJtu#FYwsCNqBt=*Z^X z;`M{yoV4v4p|Qj4{>q?5lY)j_;uBD^ch3vEU`~47vm)_PFZl&&{KFxuJ9y=V)CwC8WP>F_Oe`0<`l zhRAS<2W`&*l{uPNijpSHN0Eq`p!Ke0kyukAOP=>7hs(^-0Wzs#S(4B)5;P8+f*J|X zsk}s75zy9eCOaQttFJ<)_MVjh-FG{Lh8Q(Jx&y6vDsfW6BPGy`u7vh?r3PU;nl+WM z#$*p!2rKtjgpnS`!QreL9RM24mgDiBX+qa0W*F75S?B&#syA;ed$@w+JHgDIk*K)8 z(TLr5RvwAE3MTeclyu2HQ=;C*-UvgF@^?if^&6MR&?j zo3CC-9HoqjwK9&O=)?Sjtpu!WGm-_qHS1DVn5~r)ej=fE!>xAsU1X-Nmt4?KcDGr4 z|E((ch4Eumm?SVLpajc$SKQ4fh@4ZFGOu#gcBm+Ws0Qujt1QO2+9Y`pS?5e_1BJcH zvFM(@`n={6idM9CI|>x;qae;z9<@d+fVjc&Q0z6oolVX_HAVd&Kw`M*?$LqlwLZaU z`Dxkt(hF*$$WMVJY)&0PIrr|UvKS}H1VPA}Nhwarv)elJyrbZPizOjX%9DoSPQKD? zP9|^|L`ufzQnMi3uKP0Rpe(9uhUss&4zd9w%vzSByH81$6Rxq_{CS_#lU_vcog&(Z zYr^3UKMns-(-Wa6J1HxNrGg`8O2TiSA_GU>61a$ySC#|k8M)~q*eSvYDc6sp;%BvK zKr$X}nk*{;eHCWd`HTq>n?GI4I(Av3gECnu4&)Ylu})FRnOh(P^&WU|%Ud-`;JTley-P@C6nYW$B2RW}ix+`9wuj2MNo?$p?CHuLgES z&X!+t#?*hPek`K@;?7wxg6<;jMBEiWJgL^25dEr>mdO_+z$P(P>EjPRm4gqL=(`o_nfEM>=-p z3Jk)OoJ|lb{~am5Z=PD#);ud^LuFR)WG^^2KxX^vLwG7DqUy{#5s8-@n5R&(s9-b$ zMw-FG9epmtNp|gm4Au1C5*3DXPP2NB-`$GbT_A7j*VeI1Fh2I)q@-$JNNZDB8IIZd z^tZV6T&5J9M!qy9ag3q3ZEK5iBNEov+tTa6V&YyKnGkdiMKVd)=_)MU+l_H($Ha%$ z7=ULniGD=b-BFPq%r@ed{^}eT9NmY1IE^eyAQqXFXz6<+&ZMQVAP!^$QNw@T``vAk z`##$VlvGQUshHnT0D_5J-KLVD0$Fp8q$jh&X#2i}*0TfOS9^bykPp_Cuds&cQS_il zm2@vERVDaud3s5^-K|JphdK&#rj_NUmg6m^e-+tFJwF0)CJVa*2;}ZAw@U+_=sfE^ zW+t3W@7QoKQ;_qYsRA7xoZ#MzX(?D6^6_c-DJkYF6tG<)AS#!bWwne zg%-{_n^pIgYVXvRduR6y3ifm2A(C996h&HvCJc(i z7KSj_9ABgdm>`|(QXMC(@nR7s@omOuLAP?qw!$QuoKgrtyU)4o2sZPEkic`9s_qUL zS0b70sZQ`-Yf#Dg*;nkFJ|!PuRew8Pt?!lU54Pa#m;g;ACLkT6Q||1~)clxwEAEax zoIeTXgA+%^lBT1zi^bz-x^|S#VlgwMHbBZxMG+8ZyB*xi(Q>M%ph|EFp4-REV72ja z?!LyQQm*G2%9(V?m8$evVX;s*nMB*5gebmI82*5?9cLgl3eS8L#OXWEcK#7BmZ$2B zd{GF&kHcZQ-}{>bn8-N6ShBTx$%Snlc2F_6XQbJgNvn+k#Zx^B!p%hmBRBeQ(tNnS z6PQX)8{teci4tRer?WD&lQxCR{@c6ma-V82Tj1@Kwj-%YBzs7u;_7dZ%3Jr@3@|rkuV<$YHfFf|0!ZK4P7?9)&tuE@C26Tzo~73t zaIx-<*Nn86Pe3yc6`_Gl=_mCHg5_G;DrQ@rXmoZuGE;kfZ?+)koINvg z*Nj8Q*4gD#%d+=HY%T58k_DV$4o_MP<{k(olo>wptP1Pyb8}!&szJOV^Ts69CQZ@< ztOCU}yzY)8h|C>d^-y|`kPr*K(qLj!$*p?A-e9tb(1O8gG?CvZf~&@VOOX}`N?7(h zNbA2=%N2By%Q8A()@H?&-)>eO?;`CVrAXo)rZP-+gzkwv_@$k_u!2ota4{LEBnBE$ z9I2*8ZWvfR$%74o>by!ue|O(&e_@24rm)0*qag@5dd7BePadw|l7o=SoA-JTrufio z1Bk@^`)^B%{GpB1C6s4!RE(aUFLgI)6E+-n&gv!MK=pzWzGpVc^< zV)xTHtSoo}8qDoTWY?e{t;jqp z^Fy)hJZrQiJC%6vH1$iLI_BFGNKxr`VtDo@P|f#(AeppAZqukYS}HiAZjl^Uxu>uX zpJM*NA2^Q+mb`Mwm?hngz4zj*ze0~S6^~y&Zush&mJ%YD@{<%N3VqV%3QN6*=&wZV zl#P0k@8yI<$=7;S&D=In{p)R{6<5ui=QSBJIaxs% zk%!NNsr3~NHSeA;58s(fT;NBT6svR{yfK?ep(jfst_gssGB?3?x2TTV| ztMUYQ7Janu)t`zzTT{Fa}-bz5?#MB=q@e6^=8X^g=Y-`+5 zth9U*S6A!Z3E_~b(UR}8!Rk08uW5IpGbO$qkBpFjo=MsXA^Hh5K?xF+4X7Ngb~jl> z?K^hpNCRf~r^JlF_CJJY(Q);0>45E8^uH$OGVTu+B7zL3{|<1A2_F8Xy}QMKAK7E| ziiP)QH-@8T{wOy)5j8M7jN$scWY2du){2VFv6(bpSgx}qXy82#yOxC*O_=lOYJIP! z{wqT=@3Dem;b#)#0vlWlYaDcc%w}TmGk5ra&_*P;d$-h_KEjdK6FxZ1qSiW$m_MJ8nWD0C{< zKz^mu%$6FDrhhGno?w{Wh9Z?#4FM-i-Qw-2`_mH875c;J)Sg(R_>6}*mpBig7DJC@t9~xtbF;G?B9_SEX=U}s2KzG;!(%_*|@h2 z&I;o0^>=U13ZJwpF@HOSK11gt<_x|92B32&(i zo^ihGPD`vZCoR5XU_V^-8AnuEsic*-$4C7gO#0RZgPJB8xc3e~RWwXgxgj2`j~mlT zATl_@z${X?H#o8~AOi1O0nJFVParf(-;_CFj^`}OyK7-~9CS$$6{b5Cm_%P-dN4SHpcv?GqP%64ux_)tU{qnAi6{pji^ScPj{}Ewj?P2-F-p$kA)dleX zaB0a)Q8K(s5nycSIJteNrTQOQXLA=X8*@ufuP@eL{tx1?Hnbe zByj@2Q+@K+(f8Cc_n~zA;%Z~>WKHSm=Vnd$uEsk=-#2gn5*5i^kAY!aePUAaj}`!y z28GQM1&0PlITaTchf)T_GhhWv)2u@|v9d5aI5|igebRO0YkF;MjpP3~ZezkFxeLGTJGW#nr`WF>58HB>X7jbuluC zxyCy4sDso4FFg${#!K}LH#AhYT1aLrVVp2GHZF)kBz+EZO1DaC^G#`oH;X1Hq$~X9 zm~eJFUt&Dt#>onA)D_AEF9euo*(1o8fuTy3fuW(9f#K(WApL@YA&7&4 zQ8a>q!D>1KgLwY+DESG%Ky3@~32_DLQCCsP`OjeQBo1WYLXzSV62j6d3My*KC~Cx% z7#+gc0l##V-sHz&7@>et}b3F=QKP1;473^uq@_6{ z!{lo#bXF~~S+mZ(v`;)JmqSfSRZT?&q5w{Eaj^vY$?n?ZG0To3Rpc|Cr<IV03p!W3`;OFAF=LM_NW@eUpV( z0IyVTl&!l@y@{7jIH$OSjRcpobbxzed`3iGQf#=fSAe05qpP#5x3mEpqbR$+czB#V zqmYQIdUAlEa3GsSCZ9&$9S5Kr7?Zr+T^faUt@{V$a29w(7BevD0V7RMnXzK2eHl=Y zy~NYkmHja{v!FK9p5GjWK%twSE{-7*my;717~R~&#N6E2Bob0mQj^o4C$w@J78MnK z{_yD|cR`_1(^A&f7S|arM~|qgEM;lzl31FW@^r>iQIV-rLPM@DX=HjOH7hFWmesDR zUuuQ_M8N4YNhi!Mo18v*Huy9Hm%%e}5i!y1 zsZ*wjialwLJ%1uHE-*4QHaPGc=V$rk+}PUMSlzCAX{iM<3=Xff8dC0C-UWJ6wZt`| zBqgyV)hf9t6-Y4{85mmX8XD>v7>5{|TbUSJ85n6B7+M(^+tdjE!DvL7HGfEhoVJrnhOG`@y$CUh}RE6Nm;*!+dVg=8<Rr~FT!@q8M@z^u%zm&`4!EbKj5gjra@rNQKI3bXR&5QWn> ouADe>=7`J@_R|d>3%v9gUWp5qd~!0K3bca3)78&qol`;+0Fjr?YXATM literal 0 HcmV?d00001 diff --git a/pkgdown/favicon/favicon-32x32.png b/pkgdown/favicon/favicon-32x32.png new file mode 100644 index 0000000000000000000000000000000000000000..49b7727f0058a592319f28238d963cc8e178b0dd GIT binary patch literal 2363 zcmZ{mdoSJf7?VrmHZEy2Gls&9F=^b6A3{pub$d$= zbt0uvqLN&uP(&_~6i2F46lHSDEzY#w)w|Za&U)9g_Otie>+{`vujilrWO=$f%Sfq9 z0RSLFba5n$Jo<-8B1CsgeEb3cz_h~m?)40((EtFGN25~lY;H7%Ay1`tJ~jG9igTQN z@?maC4xSC)LVb7AG z5sdzAYqhY;u-wvv!DK*@c>$!K)?=i-)F8}U%0)BLYm&K7i?@Uvg4O1uXLg`txArR# zmQ-?Axww)nFk;IIEO@y1vM)5lVE39<89&+IhdF?&udnxJ@9*+(^^vSGHX%O6`U-nU zy{3kprmn_BH`ulG23cvij?^BVO4v}?MdGDaq?o52fl>xOc+-uEMd)MzT@_9YPXpb2 zvk?1-**5ah(iz$E(p? z$Zh}-uMYrF8UU{|VM8`eel(vrIz=%K}<&4&tTCLHn z63rb?(=(LwNv4Bj6R~~iy-+9tbm?&s3cSso)Md0R#KtGZvzWoW)YRODDo9n2pkI}K zO6<}#DTj)|qDNVKNzVx94PxKkPfG0lJ+nC|HQJ$y5Yc7p%sjM_%wN3GT=d3I`_cOd zb#2wE)|$M@?F4+`Y8TVL7^y9`0k?y#t6_jc$8FDAmAP-?wdJS^BU{!{6jT#t@P3N_ zgxUm3aENd9TY*6S_&0D9_zl$r&X6j}YJ^BlO>P1CK9m6cA($5^uJb5G`ZwX$h%t#V z*$eO`1Fx${G_U|e5ymatcK+K%56Xo2g5(q{XvWnsTS)*4W>b>I7}2w4g8Vk)dPx+= zT@DlUCc=lW^}Yl*)J8xFHHA78mbxJpFiQw4Ke;IAemnP;ObR9~%}s3!{X@f2+_F94 z`UZO_%umXvXXWELqE%e!VZD~;{CKoxTDdnnr_SQGp;OPri^GAlEp@YJOJCfWp33R?c*gn(@{u<` z?CRkTpS)PcuYWEzQah!z*TOywHUGNJ4!^U+Zi^j4FXhHG^OcNFZOT=yLB4Ax8B0(S zY7AortvoWDa0dtOd_Gu;)tbC=`ojmeqfIQPYe7)4hnLqASz}edNMz9cBxcyU(eE0W zUk-3X6J_fLKqNJxg_3y1+vIpxq7yuv)VY3d#r5+$-MTm5XWdynAI4t2$uSKY9aZQ( zUwMFZouwP<)WE)&eacrX%IW!d!p_~pN;xHhW&v_yhNImd9d&g6*}0zWo(i%QLeQ-T z;09uW9uu`#k;L@K2)v$vKX>HVx0?17HwvcfGe>IUc1g4v%bk7^59LOR2i^7k4l8<@ zO~9ynw}Ifx#yN58)4eOz{VU0e4U(FMh0SSK+)eFmIMmgW#Fo$zSlVrO_zqRCN~g|` zmf*gaz>?%eyPTnyby@@-v2uA%1O6&S19|~dsVXoEo^~$laUbW>COe9hkH+Xl)EOu~ z!oKr)^2CqlhO}4|%!~!O5R_9aa5*h(%W|({Qc07q_4QOzUKhHKFK^_{ujSKTDwKYe zs}1Yyto*(|+DK!Upjv&OC_CB=_x$oVZSq8fOl(? ze17NYg?R%=@Yl*be|l~0%yT)xe3PoJ_^3WSLoynsx~KRZhV5BDu*DH7`imDEI?8%Q z(v_%`z1QMrUCez9L5xu)0zU%^nM!wBD7>IDZHRC6b-*K~Nt7UNX#;}ttTqQ;geuXmb7D26^<-wvUcZN<9iJX!tK((| zhrkC^oZoX>Yeb?U{VjnAZLRh=RR}{49H0h#a31hmLw4W7-%A`1#==$`?|0Ky)}yIn z*m`p@ysloN4ji|mPp;o!UZek6v98sLY|#sB-1w17|j-Y+qVqG@^3D zdq5^jAHq5a;HNS|6yZ&>JorJzYs9$twZ(w`>pC$0mtBH=6Fw7e-M8ir8RTbBSaW~s z$EH)>pIkF1gz~89Q_AnbOPS46n!rd9*crK+ zfBqTc-5W9!`HW z&(!HBTpqu*Td%B)kv_b})W3NGPN=qo2yW^qKr(9I$?BSj_9 zKTFUVF*Hs%n;XuG0{){SJ3F8;qAJ$E+-&@`Bw}@bvXLQC$3jDB++!RD=O1utZu&D3 zto~n^MQ23(gW_sL^ouCJcy9`q9C94Z=CDG;BN%9I9Gig_jUoEH@GiWYla`G3#bBOz zboUV7lL1f{WkN$K=qix%6+s2GBV^G=2X*Vb(cL3Mo$WpCn(Y$ZkW0C%3Ghi}D|gOe RXQ8MCKy-3gpdFYIY~}lB!K|o9Z4{}gn+-XQi><&c}~PM+xj<>^-8zX8}4b-PnLFeN;E7pt=*q?*#tZJYXL-G!M*; zZ98+$*tS%UIt3zAV0$;wYQP4|mWi!aYF427*#BF>F`U4-aSlUYuIM2s1AA_$W82Tz z;^X#jB^v_!6?+VRgKsfL%nd%3B9PM%u)(sWt@iVrwC!iDv48XyX#yKO0{<8*ItubS z3G5)14R*UDvPO(KiFKWeEaawE;-xtWq6wK{2V!sF#X1EFVBbzbbEZ!IE1$zDB zlwe+76xjBHpg)vXh}XnHVThN+IPt7FFJ_5lf-&zd7$e35Sv`aq+GBrqb`EQcwT3^> z6DLHqz((f#X~BFS63oppK^=T*nqX{S71;H-U{BgAs7v{FEB&Zq#)YwG?wDh9?X<)G z-)3fJ7fDXBV66du$~nL#@OAu)xn_>28!Zw9c~RDH{9=S)9LSHc(#S;?&pKlASr7as zZH9K(e=$2d7oChRcBTu?#l+wd*}^GUv$=x6Z|o$tL%0%I0-HTn%$zoanD3-_jqKQQ zv@*!Ye&G4f{?nfI>yaG%ADhCg*qmFX*+)7E_8_w#e)LBZXB4mOu;-ggwUv{ z#Db+YGrP{1zTVk6sZa&zVSYPhWMuKq#$GC-!j09)CV1 z$^`Q^Sv)J~9|8Zvx9q-?=WvFGx^m{upFHAU-uD$eyvZL~*_(FQZ`SvCvWsujeznV& z9Oj;R$JUkt{o@%lT(B;O2*$9n{fs;Fa#+k1W*V;0OP%Q(*pw}pe~%S2FZ2!Hp^WDMd&oAiQn028x>0i+6+Oj4 zkrJJnmRzu8#kAoX_tF3HOJmgg9~k-DA2M94r>zgmO=tehaFgt3?BfOd56^h~otUw= z_lo{XpAbH=Q_L2&pEEyuM66g5;dYniEnGUM?AQywL5GhU{hvHw3^{$)$lA2dNZ9m% zFQT-7XSW${lKr;0<}vo!_T#fpicNw!IUpto0`~8AIGxlfO|7V0)_2c-U-^qK8^hmv zy~SH_5+oioymMMmPbg}%rEMXVt++(P@A6ZZBD!Tw3uENTS%(rz(TU~{!NBY&Th z)T?x3@jAn&u{TEl;$vg1{C?~&FBtuwIcg+rUSK3Xyzo|xKYo)YY=3Yn?G`)_z+P{; zO7kqm*IyF!g)_s^h=jz?6Y>k*&8=Se!yzxdS}Tlxd!I6fzWy^~)VU80k8h>n-dkfN z7_--h<)pK3nBgXkKWi2kSN0C<=b1@=c-}C^b_iF3zGC}6S5EHzUGA#d=JMvAD?9qU zukt5v8iP-qHpYJPsWI~1Ul@13^qSG*@tubIp#?_L57+u!3nwmjMn~G?(a!zHJbz*z zcH<-19ZU#`^XQd)=A4-t=LZKrclu%NlY8-(;cvcclpT3qe)FkOb^cdI?`A>}DKYhoz^XyNJye)nsX@hKka+St@jW53DyKBQdo$$eiVA+2o&)@%1 z+d&P2f=hIcFDhJExM|~tvKLSLun~V@t>Wk9XI?S-95`s?Y%z?E>*pJZJC+zp`&VPT zk+^k%FRG%~XsKx!dsJeBz?O-@nP9dVp!)WE^Bkq^{pEThoFPf^Sy4m#&PrH1#pvLh z?@RSBGE)7EjgH0wBiTRSaBtNfvul~@FG>5?nB$J^(W3|6=LikqIc)}X3Uu@Cjx7W1 zvg^gF>l8&|pRn)2M=Bk0y|$EV{l!J}D=dqhJ!WCT#<{ibJuCdO)tB_t+Ir+G@^`;` z=Rf;h%crb~EblqW84+&Ujt+sY*9E$<0b7Fc-zMg%O}H2;ej?g>hwpU8L?(n6XZK=F z#?Gpm?^-fxg=_hJD_x5xEsy=)sOqSpeX2s!Q!}MBv|G1g#*DM((}MdebfTO6tX)Ae z;>9e{);oNA-LvP$I-?>xhQ!Bqvi3)w+vb=`ZfCJx{KnFOF3u}AHArS#?(kVNyysvC z_H$MOo*QP6yq3Nl(B_r}=?oFv^B)$>b8C0_Ji~a7^3KaR^BghfL+=&%~+SondhE;=5XZY72@O6p)PH%_3hwx^}{VY=82C*t9SS+ zv%eku+Nw(%&QRZqAX_rUR`HoQC%D6pvAEH12e-9vvbFgg{u$)~KK`6&{_Wtl+83-c z*%>V+h<~*p-LMXVmGjrGC!3StuWiRa^xwJ>2$;d)_-1^yHV`2Haz=gpr}Opkdl&2D zjLT+xrS@t$^}Y%O4iKyKJ>ngKz?X_u7`RgFa9jx}lsg>%PyA-nxQ^dH4{<+W#>bM) z`1hNW@|xAFZ}%sw{TG4rX89NAcbM_TPZH|m3z260*?-r^fB2w2{&Hh|`BkGn4p{M3 zPlj3lvV-_a;EJQX+_c-kZo40W&jb3W-(LolrP%Iwz#50Zc^Rhsz{U6KtcH1hQoRfx$=PgLL`#gQUen(EG^s^inR_ox~c!-%hO%+!dOEv{)`EqYii6Hzi0`te7e|&psydg?$#}TxyPc zOiT>tU&^RMUD|Ljc|$>M!vx=GkBMhRg=l;qWXmOw{xTjRd3oJvM_t;`78xzIv)g|o zR{cEjsCY$86Sj{x?l&?aLvWTa64`?1Dt^M+pe-_x#a;9@gX+*`v0xt83gosF7So_ZIt`^x-+{SIP}CA*nzA9VrU z*uXg0_3>TCgZCI@4^~-=L1mTVu)c4hgKr}AkMRYsz;^RpNilbM4flCU^B%=-e6CPn z8@fy%lwACR_o+(dwHPR)PMm@&R0zI3juZ>5G*nat05o z|6yU_S!$CkxM%Aj?hx1mRbqf(uKS34#5jS?j1^@AMQ!oG{39zH^waN$TDJS4tDS=ort6gTZ%v9Yn-2?W#sLy?h@=z_)p zUFcxknQQvJN}wCxqrSN|qEb?#du`q}q5JmjM%3V*{gfXS85z|<`kxWk^*@&@9-pO; z#H{Nmfqwdo{&j-+tr5%v;%t!{U^Vd*doRV)*U|aU}$7iX{TW$7wEf}Z^YaGW`4Wy?%M2gt^V%f zkklks_x$3Z^>^*+!H3Xif5T!9?C&Xz3-iBO7~-Gw{pW3c|2bZ|eb=V)lRq+szwxe7 zarSkijbw^v_-Iesqc7y=$3Y-^u*$AFS{vYumS4ewj1H9j(K-h|1r=U(X@ z7Jf&MuIZ_rIk(+o$=IW~O=nZpx6jxolx9s16y{i3Mv%roZC{~Zp~XpELUOY6_|8Ea z+P3R#uJ+8yEOAymEV3>AtWox3)_-V-g37#B9qQ8NnqzIr2`ZATbYX~B#Uer9*_Rwz zTimCRM;UckyEi>ZE`97J_KDMCyaj3UC~IlW-c(zpBT`g}Qx>H0gWDRUGXZX^(wnTT z{@y_UbDi+jfk5C=UBJ9@DA$dJZdSey1U|hK2-MZ{Mcx1TyDj<4@2kqcQg`XA%XOE& z{$t&xD~5i9v+mMWXWiFZ;DeR|=@`4GP1J-Dp z*P7Zyi2h=p1!s203)EEcoGG(nx-sz0ig z_SngphW=Fubn{&*Eo0oonEaKiD&s24x@2W~$2D$GIxEYxpKr3r;C#q?2WQMXLL(zb z^xM6!s^76=wTX+TmU=V2P4v^=>&@ldhKI3VAcHZO8x|8&oj!K_8vWfyZI2^Q`Quhh z>F>?V`9^!qHRl<|nmG%N?$X7bG3makMXSI6NZFASTl$@R!I%1I&AO;X6T0SPE}D+646~_LwiR;pI%8>zSUE5o_J(k#uJ;2aa$Jb09p5@JDFJ-Pd_ca9lP80VD z-tEnO-kH_W6)~wIH+ufKlGLFC%d)+>GgQXi5M%m{pnUwdK-@3JrlodD>yn(-!Rzsk z@n+}p+@h>S|7|Qxb=ZdoiE0a;(QV#`)g}=d%Wj^ozvJYd^BUBtOiyI)bDP)uGg)!x AX#fBK literal 0 HcmV?d00001 From 2b3ad850c51f030bb559365f71d20875a27e0aa0 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 17 May 2024 17:29:18 +0200 Subject: [PATCH 61/74] fixes --- R/utils_examples.R | 42 +++++++--------------------- man/tbl_summary.Rd | 1 - man/utils_examples.Rd | 12 ++------ tests/testthat/test-utils_examples.R | 9 +----- 4 files changed, 14 insertions(+), 50 deletions(-) diff --git a/R/utils_examples.R b/R/utils_examples.R index d35d74742a..1baa6f09b7 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -16,19 +16,14 @@ #' @name utils_examples write_example_output <- function(tbl, example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2]) { - if (isFALSE(method %in% c("txt", "rds"))) { - stop("Inserted method is not supported.") - } - + out_var_name = deparse(substitute(tbl))) { if (getOption("gtsummary_update_examples", default = FALSE)) { if (is(tbl, "gtsummary")) { tbl <- tbl |> as_gt() } if (is(tbl, "gt_tbl")) { - html_output <- tbl |> + tbl <- tbl |> gt::tab_options() |> gt::as_raw_html() } @@ -39,47 +34,30 @@ write_example_output <- function(tbl, sub("(^.*/gtsummary).*", "\\1", getwd()), "inst", "example_outputs", - paste0(example_name, "_", out_var_name, ".", method) + paste0(example_name, "_", out_var_name, ".rds") ) - if (method == "txt") { - writeLines(text = html_output, con = fl_nm) - } else if (method == "rds") { - saveRDS(html_output, file = fl_nm) - } + saveRDS(tbl, file = fl_nm) } } #' @keywords internal #' @name utils_examples -read_example_output <- function(out_var_name, - example_name = "example", - method = c("txt", "rds")[2]) { +read_example_output <- function(out_var_name, example_name = "example") { fl_nm <- file.path( sub("(^.*/gtsummary).*", "\\1", getwd()), "inst", "example_outputs", - paste0(example_name, "_", out_var_name, ".", method) + paste0(example_name, "_", out_var_name, ".rds") ) - if (isFALSE(method %in% c("txt", "rds"))) { - stop("Inserted method is not supported.") - } if (require("htmltools", quietly = TRUE) && file.exists(fl_nm)) { - if (method == "txt") { - out <- readLines(fl_nm) |> - paste0(collapse = "\n") |> - htmltools::HTML() - } else if (method == "rds") { - out <- readRDS(fl_nm) - } - return(out) + readRDS(fl_nm) } } #' @keywords internal #' @name utils_examples write_read_example_output <- function(tbl, example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2]) { - write_example_output(tbl, example_name, out_var_name, method) - read_example_output(out_var_name, example_name, method) + out_var_name = deparse(substitute(tbl))) { + write_example_output(tbl, example_name, out_var_name) + read_example_output(out_var_name, example_name) } diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index d3b1538aad..ef86a0afbe 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -213,7 +213,6 @@ Customizing the `tbl_summary` function: digits = list(age = c(0, 1)) ) print(getOption("gtsummary_update_examples")) -#> [1] TRUE }\if{html}{\out{}} \if{html}{\out{
diff --git a/man/utils_examples.Rd b/man/utils_examples.Rd index 3b94388750..3624815529 100644 --- a/man/utils_examples.Rd +++ b/man/utils_examples.Rd @@ -10,21 +10,15 @@ write_example_output( tbl, example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2] + out_var_name = deparse(substitute(tbl)) ) -read_example_output( - out_var_name, - example_name = "example", - method = c("txt", "rds")[2] -) +read_example_output(out_var_name, example_name = "example") write_read_example_output( tbl, example_name = "example", - out_var_name = deparse(substitute(tbl)), - method = c("txt", "rds")[2] + out_var_name = deparse(substitute(tbl)) ) } \arguments{ diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R index 30f2094d5a..31064d5c98 100644 --- a/tests/testthat/test-utils_examples.R +++ b/tests/testthat/test-utils_examples.R @@ -14,16 +14,9 @@ test_that("writing and reading examples work", { read_html_tbl <- read_example_output("html_tbl") expect_equal(html_tbl, read_html_tbl) - # txt - write_example_output(html_tbl, method = "txt") - read_html_tbl <- read_example_output("html_tbl", method = "txt") - expect_equal(html_tbl, read_html_tbl) - # One function html_output2 <- write_read_example_output(html_tbl) expect_equal(html_tbl, html_output2) - expect_error(write_example_output(html_tbl, method = "sdads")) - expect_error(read_example_output("html_tbl", method = "sdads")) # Starting from tbl (common behavior) write_example_output(tbl_to_write) @@ -34,7 +27,7 @@ test_that("writing and reading examples work", { read_html_tbl2[1] <- paste0('
Date: Fri, 17 May 2024 17:57:27 +0200 Subject: [PATCH 62/74] fix --- R/utils_examples.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils_examples.R b/R/utils_examples.R index 1baa6f09b7..ed40316cf2 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -16,7 +16,8 @@ #' @name utils_examples write_example_output <- function(tbl, example_name = "example", - out_var_name = deparse(substitute(tbl))) { + out_var_name = NULL) { + if(is.null(out_var_name)) out_var_name <- deparse(substitute(tbl)) if (getOption("gtsummary_update_examples", default = FALSE)) { if (is(tbl, "gtsummary")) { tbl <- tbl |> From 495879bffe0bd1194b3dbdd2c1581e69c7315ef8 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 17 May 2024 11:00:06 -0700 Subject: [PATCH 63/74] doc updates related to pkgdown --- NEWS.md | 2 ++ R/tbl_regression.R | 19 +++++++++++-------- man/tbl_regression.Rd | 3 +-- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 2275a98028..5a58708c45 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ #### User-facing Updates +* The `tbl_regression.tidycrr()` S3 method has been removed and migrated to the {tidycmprsk} package. + * The `add_q(quiet)` argument has been deprecated. * After `tbl_regression()`, the `.$model_obj` is no longer returned with the object. This is (and always has been) available in `.$inputs$x`. diff --git a/R/tbl_regression.R b/R/tbl_regression.R index d3bb59fac5..1abaad29a0 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -2,7 +2,7 @@ #' #' @description #' This function takes a regression model object and returns a formatted table -#' that is publication-ready. The function is highly customizable +#' that is publication-ready. The function is customizable #' allowing the user to create bespoke regression model summary tables. #' Review the #' [`tbl_regression()` vignette](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) @@ -50,17 +50,20 @@ #' TODO: Added the tbl_regression_methods help mentioned file above. #' #' - `"parsnip/workflows"`: If the model was prepared using parsnip/workflows, -#' the original model fit is extracted and the original `x=` argument -#' is replaced with the model fit. This will typically go unnoticed; however,if you've -#' provided a custom tidier in `tidy_fun=` the tidier will be applied to the model -#' fit object and not the parsnip/workflows object. +#' the original model fit is extracted and the original `x=` argument +#' is replaced with the model fit. This will typically go unnoticed; however,if you've +#' provided a custom tidier in `tidy_fun=` the tidier will be applied to the model +#' fit object and not the parsnip/workflows object. +#' #' - `"survreg"`: The scale parameter is removed, `broom::tidy(x) %>% dplyr::filter(term != "Log(scale)")` +#' #' - `"multinom"`: This multinomial outcome is complex, with one line per covariate per outcome (less the reference group) +#' #' - `"gam"`: Uses the internal tidier `tidy_gam()` to print both parametric and smooth terms. -#' - `"tidycrr"`: Uses the tidier `tidycmprsk::tidy()` to print the model terms. +#' #' - `"lmerMod"`, `"glmerMod"`, `"glmmTMB"`, `"glmmadmb"`, `"stanreg"`, `"brmsfit"`: These mixed effects -#' models use `broom.mixed::tidy(x, effects = "fixed")`. Specify `tidy_fun = broom.mixed::tidy` -#' to print the random components. +#' models use `broom.mixed::tidy(x, effects = "fixed")`. Specify `tidy_fun = broom.mixed::tidy` +#' to print the random components. #' #' @author Daniel D. Sjoberg #' diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd index 11e37ec48a..8534a3a5c4 100644 --- a/man/tbl_regression.Rd +++ b/man/tbl_regression.Rd @@ -75,7 +75,7 @@ A \code{tbl_regression} object } \description{ This function takes a regression model object and returns a formatted table -that is publication-ready. The function is highly customizable +that is publication-ready. The function is customizable allowing the user to create bespoke regression model summary tables. Review the \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html}{\code{tbl_regression()} vignette} @@ -97,7 +97,6 @@ fit object and not the parsnip/workflows object. \item \code{"survreg"}: The scale parameter is removed, \code{broom::tidy(x) \%>\% dplyr::filter(term != "Log(scale)")} \item \code{"multinom"}: This multinomial outcome is complex, with one line per covariate per outcome (less the reference group) \item \code{"gam"}: Uses the internal tidier \code{tidy_gam()} to print both parametric and smooth terms. -\item \code{"tidycrr"}: Uses the tidier \code{tidycmprsk::tidy()} to print the model terms. \item \code{"lmerMod"}, \code{"glmerMod"}, \code{"glmmTMB"}, \code{"glmmadmb"}, \code{"stanreg"}, \code{"brmsfit"}: These mixed effects models use \code{broom.mixed::tidy(x, effects = "fixed")}. Specify \code{tidy_fun = broom.mixed::tidy} to print the random components. From be66e076841233f148d84cec272cb1dfc178ceef Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 17 May 2024 16:03:01 -0700 Subject: [PATCH 64/74] v2.0 Adding `add_stat()` (#1667) * progress * Update add_stat.md * lil updates * Update _pkgdown.yml --- NAMESPACE | 1 + NEWS.md | 2 + R/add_p.R | 2 +- R/add_stat.R | 251 ++++++++++++++++++ R/brdg_summary.R | 6 +- R/style_pvalue.R | 1 - man/add_stat.Rd | 122 +++++++++ pkgdown/_pkgdown.yml | 15 +- tests/testthat/_snaps/add_n.tbl_regression.md | 36 --- tests/testthat/_snaps/add_stat.md | 40 +++ tests/testthat/_snaps/tbl_summary.md | 8 +- tests/testthat/test-add_stat.R | 173 ++++++++++++ tests/testthat/test-tbl_summary.R | 2 +- 13 files changed, 606 insertions(+), 53 deletions(-) create mode 100644 R/add_stat.R create mode 100644 man/add_stat.Rd delete mode 100644 tests/testthat/_snaps/add_n.tbl_regression.md create mode 100644 tests/testthat/_snaps/add_stat.md create mode 100644 tests/testthat/test-add_stat.R diff --git a/NAMESPACE b/NAMESPACE index 8f065bb571..1b4e2d223d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ export(add_nevent) export(add_overall) export(add_p) export(add_q) +export(add_stat) export(all_categorical) export(all_continuous) export(all_continuous2) diff --git a/NEWS.md b/NEWS.md index 5a58708c45..508a239f87 100644 --- a/NEWS.md +++ b/NEWS.md @@ -44,6 +44,8 @@ ### Deprecations +* Arguments `add_stat(fmt_fun, header, footnote, new_col_name)` have been deprecated since v1.4.0 (2021-04-13). They have now been fully removed from the package. + * Global options have been deprecated in gtsummary since v1.3.1 (2020-06-02). They have now been fully removed from the package. * The `modify_header(stat_by)` argument was deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the package. diff --git a/R/add_p.R b/R/add_p.R index adcbdc8629..fbe8eb7b90 100644 --- a/R/add_p.R +++ b/R/add_p.R @@ -391,7 +391,7 @@ calculate_and_add_test_results <- function(x, include, group, test.args, adj.var modify_table_body( ~ dplyr::left_join( .x, - df_results[c("variable", new_columns)] |> dplyr::mutate(row_type = "header"), + df_results[c("variable", new_columns)] |> dplyr::mutate(row_type = "label"), by = c("variable", "row_type") ) ) diff --git a/R/add_stat.R b/R/add_stat.R new file mode 100644 index 0000000000..2efeb7f5bc --- /dev/null +++ b/R/add_stat.R @@ -0,0 +1,251 @@ +#' Add a custom statistic +#' +#' The function allows a user to add a new column (or columns) of statistics to an +#' existing `tbl_summary`, `tbl_svysummary`, or `tbl_continuous` object. +#' +#' @param x (`tbl_summary`/`tbl_svysummary`/`tbl_continuous`)\cr +#' A gtsummary table of class `'tbl_summary'`, `'tbl_svysummary'`, or `'tbl_continuous'`. +#' @param fns ([`formula-list-selector`][syntax])\cr +#' Indicates the functions that create the statistic. See details below. +#' @param location ([`formula-list-selector`][syntax])\cr +#' Indicates the location the new statistics are placed. +#' The values must be one of `c("label", "level", "missing")`. +#' When `"label"`, a single statistic +#' is placed on the variable label row. When `"level"` the statistics are placed +#' on the variable level rows. The length of the vector of statistics returned from the +#' `fns` function must match the dimension of levels. Default is to place the +#' new statistics on the label row. +#' +#' @section Details: +#' +#' The returns from custom functions passed in `fns=` are required to follow a +#' specified format. Each of these function will execute on a single variable. +#' +#' 1. Each function must return a tibble or a vector. If a vector is returned, +#' it will be converted to a tibble with one column and number of rows equal +#' to the length of the vector. +#' +#' 1. When `location='label'`, the returned statistic from the custom function +#' must be a tibble with one row. When `location='level'` the tibble must have +#' the same number of rows as there are levels in the variable (excluding the +#' row for unknown values). +#' +#' 1. Each function may take the following arguments: `foo(data, variable, by, tbl, ...)` +#' - `data=` is the input data frame passed to `tbl_summary()` +#' - `variable=` is a string indicating the variable to perform the calculation on. This is the variable in the label column of the table. +#' - `by=` is a string indicating the by variable from `tbl_summary=`, if present +#' - `tbl=` the original `tbl_summary()`/`tbl_svysummary()` object is also available to utilize +#' +#' The user-defined function does not need to utilize each of these inputs. It's +#' encouraged the user-defined function accept `...` as each of the arguments +#' *will* be passed to the function, even if not all inputs are utilized by +#' the user's function, e.g. `foo(data, variable, by, ...)` +#' +#' - Use `modify_header()` to update the column headers +#' - Use `modify_fmt_fun()` to update the functions that format the statistics +#' - Use `modify_footnote()` to add a explanatory footnote +#' +#' If you return a tibble with column names `p.value` or `q.value`, default +#' p-value formatting will be applied, and you may take advantage of subsequent +#' p-value formatting functions, such as `bold_p()` or `add_q()`. +#' +#' @export +#' @return A 'gtsummary' of the same class as the input +#' +#' @examples +#' # Example 1 ---------------------------------- +#' # fn returns t-test pvalue +#' my_ttest <- function(data, variable, by, ...) { +#' t.test(data[[variable]] ~ as.factor(data[[by]]))$p.value +#' } +#' +#' trial |> +#' tbl_summary( +#' by = trt, +#' include = c(trt, age, marker), +#' missing = "no" +#' ) |> +#' add_stat(fns = everything() ~ my_ttest) |> +#' modify_header(add_stat_1 = "**p-value**", all_stat_cols() ~ "**{level}**") +#' +#' # Example 2 ---------------------------------- +#' # fn returns t-test test statistic and pvalue +#' my_ttest2 <- function(data, variable, by, ...) { +#' t.test(data[[variable]] ~ as.factor(data[[by]])) |> +#' broom::tidy() %>% +#' dplyr::mutate( +#' stat = glue::glue("t={style_sigfig(statistic)}, {style_pvalue(p.value, prepend_p = TRUE)}") +#' ) %>% +#' dplyr::pull(stat) +#' } +#' +#' trial |> +#' tbl_summary( +#' by = trt, +#' include = c(trt, age, marker), +#' missing = "no" +#' ) |> +#' add_stat(fns = everything() ~ my_ttest2) |> +#' modify_header(add_stat_1 = "**Treatment Comparison**") +#' +#' # Example 3 ---------------------------------- +#' # return test statistic and p-value is separate columns +#' my_ttest3 <- function(data, variable, by, ...) { +#' t.test(data[[variable]] ~ as.factor(data[[by]])) %>% +#' broom::tidy() %>% +#' select(statistic, p.value) +#' } +#' +#' trial |> +#' tbl_summary( +#' by = trt, +#' include = c(trt, age, marker), +#' missing = "no" +#' ) |> +#' add_stat(fns = everything() ~ my_ttest3) |> +#' modify_header(statistic = "**t-statistic**", p.value = "**p-value**") |> +#' modify_fmt_fun(list(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2))) +add_stat <- function(x, fns, location = everything() ~ "label") { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(add_stat = match.call())) + + # checking inputs ------------------------------------------------------------ + check_not_missing(x) + check_not_missing(fns) + check_class(x, c("tbl_summary", "tbl_svysummary", "tbl_continuous")) + + # convert to named lists ----------------------------------------------------- + cards::process_formula_selectors( + select_prep(x$table_body), + location = location, + fns = fns + ) + cards::fill_formula_selectors( + select_prep(x$table_body), + location = eval(formals(gtsummary::add_stat)[["location"]]) + ) + cards::check_list_elements( + x = location, + predicate = \(x) is_string(x) && x %in% c("label", "level", "missing"), + error_msg = "The element values for the {.arg location} argument + must be one of {.val {c('label', 'level', 'missing')}}." + ) + cards::check_list_elements( + x = fns, + predicate = \(x) is.function(x), + error_msg = "The element values for the {.arg fns} argument must be a {.cls function}." + ) + + # setting new column name ---------------------------------------------------- + stat_col_name <- + dplyr::select(x$table_body, dplyr::matches("^add_stat_\\d*[1-9]\\d*$")) |> + names() |> + length() %>% + {paste0("add_stat_", . + 1)} # styler: off + + # calculating statistics ----------------------------------------------------- + df_new_stat <- + dplyr::tibble(variable = names(fns)) |> + dplyr::mutate( + summary_type = map_chr(.data$variable, ~ x$inputs$type[[.x]]), + row_type = map_chr(.data$variable, ~ location[[.x]]), + label = map2( + .data$variable, .data$row_type, + ~ dplyr::filter(x$table_body, .data$variable == .x, .data$row_type == .y)$label + ) + ) |> + mutate( + df_add_stats = + imap( + fns, + ~ eval_fn_safe(tbl = x, variable = .y, fn = .x) # TODO: UPDATE THIS NOW! + ) + ) |> + select(-"summary_type") + + # converting returned statistics to a tibble if not already ------------------ + df_new_stat$df_add_stats <- + df_new_stat$df_add_stats |> + map(~ switch(is.data.frame(.x), .x) %||% dplyr::tibble(!!stat_col_name := .x)) # styler: off + + # check dims of calculated statistics ---------------------------------------- + pmap( + list(df_new_stat$variable, df_new_stat$label, df_new_stat$df_add_stats), + function(variable, label, df_add_stats) { + if (nrow(df_add_stats) != length(label)) { + cli::cli_abort( + c("Dimension of {.val {variable}} and the added statistic do not match.", + i = "Expecting statistic/data frame to be length/no. rows {.val {length(label)}}."), + call = get_cli_abort_call() + ) + } + } + ) + + # check new column names do not exist in `x$table_body` + new_col_names <- dplyr::bind_rows(df_new_stat$df_add_stats) |> names() + if (any(new_col_names %in% names(x$table_body))) { + cli::cli_abort( + "Cannot add new column that already exist in {.cls gtsummary} table: + {.val {new_col_names |> intersect(names(x$table_body))}}.", + call = get_cli_abort_call() + ) + } + + # merging new columns with `x$table_body` ------------------------------------ + x <- x |> + modify_table_body( + dplyr::left_join, + df_new_stat |> tidyr::unnest(cols = c("label", "df_add_stats")), + by = c("variable", "row_type", "label") + ) %>% + # showing all new columns + modify_table_styling( + columns = all_of(new_col_names), + hide = FALSE, + ) %>% + # assigning a default fmt_fun + modify_table_styling( + columns = c(where(is.numeric) & all_of(new_col_names)), + fmt_fun = styfn_sigfig(digits = 3) + ) |> + # if a numeric column is called 'p.value' or 'q.value', giving p-value default formatting + modify_table_styling( + columns = c(where(is.numeric) & any_of(intersect(c("p.value", "q.value"), new_col_names))), + fmt_fun = get_theme_element("pkgwide-fn:pvalue_fun", default = styfn_pvalue()) + ) + + # return tbl_summary object -------------------------------------------------- + # fill in the Ns in the header table modify_stat_* columns + x <- .fill_table_header_modify_stats(x) + x$call_list <- updated_call_list + x +} + + +eval_fn_safe <- function(variable, tbl, fn) { + result <- + cards::eval_capture_conditions( + exec( + fn, + data = tbl$inputs$data, + variable = variable, + by = tbl$inputs$by, + tbl = tbl + ) + ) + + if (!is_empty(result[["warning"]])) { + cli::cli_inform( + c("There was a warning for variable {.val {variable}}", "!" = result[["warning"]]) + ) + } + if (!is_empty(result[["error"]])) { + cli::cli_inform( + c("There was a error for variable {.val {variable}}", "x" = result[["error"]]) + ) + } + + # return result + result[["result"]] %||% NA_real_ +} diff --git a/R/brdg_summary.R b/R/brdg_summary.R index 399aa5c983..de90367d05 100644 --- a/R/brdg_summary.R +++ b/R/brdg_summary.R @@ -319,7 +319,7 @@ pier_summary_categorical <- function(cards, dplyr::filter(dplyr::row_number() %in% 1L) |> dplyr::mutate( label = .data$var_label, - row_type = "header" + row_type = "label" ), df_result_levels |> dplyr::filter(.data$variable %in% .x) @@ -425,7 +425,7 @@ pier_summary_continuous2 <- function(cards, dplyr::filter(dplyr::row_number() %in% 1L) |> dplyr::mutate( label = .data$var_label, - row_type = "header" + row_type = "label" ), df_result_levels |> dplyr::filter(.data$variable %in% .x) @@ -487,7 +487,7 @@ pier_summary_continuous <- function(cards, ) |> dplyr::mutate( .by = "variable", - row_type = "header", + row_type = "label", var_label = unlist(.data$var_label), label = .data$var_label, .after = 0L diff --git a/R/style_pvalue.R b/R/style_pvalue.R index 30f1b69267..4d8dcaef47 100644 --- a/R/style_pvalue.R +++ b/R/style_pvalue.R @@ -103,7 +103,6 @@ style_pvalue <- function(x, digits = 1, prepend_p = FALSE, p_fmt <- dplyr::case_when( is.na(p_fmt) ~ NA_character_, grepl(pattern = "<|>", x = p_fmt) ~ paste0("p", p_fmt), - # stringr::str_sub(p_fmt, end = 1L) %in% c("<", ">") ~ paste0("p", p_fmt), TRUE ~ paste0("p=", p_fmt) ) } diff --git a/man/add_stat.Rd b/man/add_stat.Rd new file mode 100644 index 0000000000..b65af97e33 --- /dev/null +++ b/man/add_stat.Rd @@ -0,0 +1,122 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_stat.R +\name{add_stat} +\alias{add_stat} +\title{Add a custom statistic} +\usage{ +add_stat(x, fns, location = everything() ~ "label") +} +\arguments{ +\item{x}{(\code{tbl_summary}/\code{tbl_svysummary}/\code{tbl_continuous})\cr +A gtsummary table of class \code{'tbl_summary'}, \code{'tbl_svysummary'}, or \code{'tbl_continuous'}.} + +\item{fns}{(\code{\link[=syntax]{formula-list-selector}})\cr +Indicates the functions that create the statistic. See details below.} + +\item{location}{(\code{\link[=syntax]{formula-list-selector}})\cr +Indicates the location the new statistics are placed. +The values must be one of \code{c("label", "level", "missing")}. +When \code{"label"}, a single statistic +is placed on the variable label row. When \code{"level"} the statistics are placed +on the variable level rows. The length of the vector of statistics returned from the +\code{fns} function must match the dimension of levels. Default is to place the +new statistics on the label row.} +} +\value{ +A 'gtsummary' of the same class as the input +} +\description{ +The function allows a user to add a new column (or columns) of statistics to an +existing \code{tbl_summary}, \code{tbl_svysummary}, or \code{tbl_continuous} object. +} +\section{Details}{ + + +The returns from custom functions passed in \verb{fns=} are required to follow a +specified format. Each of these function will execute on a single variable. +\enumerate{ +\item Each function must return a tibble or a vector. If a vector is returned, +it will be converted to a tibble with one column and number of rows equal +to the length of the vector. +\item When \code{location='label'}, the returned statistic from the custom function +must be a tibble with one row. When \code{location='level'} the tibble must have +the same number of rows as there are levels in the variable (excluding the +row for unknown values). +\item Each function may take the following arguments: \code{foo(data, variable, by, tbl, ...)} +\itemize{ +\item \verb{data=} is the input data frame passed to \code{tbl_summary()} +\item \verb{variable=} is a string indicating the variable to perform the calculation on. This is the variable in the label column of the table. +\item \verb{by=} is a string indicating the by variable from \verb{tbl_summary=}, if present +\item \verb{tbl=} the original \code{tbl_summary()}/\code{tbl_svysummary()} object is also available to utilize +} +} + +The user-defined function does not need to utilize each of these inputs. It's +encouraged the user-defined function accept \code{...} as each of the arguments +\emph{will} be passed to the function, even if not all inputs are utilized by +the user's function, e.g. \code{foo(data, variable, by, ...)} +\itemize{ +\item Use \code{modify_header()} to update the column headers +\item Use \code{modify_fmt_fun()} to update the functions that format the statistics +\item Use \code{modify_footnote()} to add a explanatory footnote +} + +If you return a tibble with column names \code{p.value} or \code{q.value}, default +p-value formatting will be applied, and you may take advantage of subsequent +p-value formatting functions, such as \code{bold_p()} or \code{add_q()}. +} + +\examples{ +# Example 1 ---------------------------------- +# fn returns t-test pvalue +my_ttest <- function(data, variable, by, ...) { + t.test(data[[variable]] ~ as.factor(data[[by]]))$p.value +} + +trial |> + tbl_summary( + by = trt, + include = c(trt, age, marker), + missing = "no" + ) |> + add_stat(fns = everything() ~ my_ttest) |> + modify_header(add_stat_1 = "**p-value**", all_stat_cols() ~ "**{level}**") + +# Example 2 ---------------------------------- +# fn returns t-test test statistic and pvalue +my_ttest2 <- function(data, variable, by, ...) { + t.test(data[[variable]] ~ as.factor(data[[by]])) |> + broom::tidy() \%>\% + dplyr::mutate( + stat = glue::glue("t={style_sigfig(statistic)}, {style_pvalue(p.value, prepend_p = TRUE)}") + ) \%>\% + dplyr::pull(stat) +} + +trial |> + tbl_summary( + by = trt, + include = c(trt, age, marker), + missing = "no" + ) |> + add_stat(fns = everything() ~ my_ttest2) |> + modify_header(add_stat_1 = "**Treatment Comparison**") + +# Example 3 ---------------------------------- +# return test statistic and p-value is separate columns +my_ttest3 <- function(data, variable, by, ...) { + t.test(data[[variable]] ~ as.factor(data[[by]])) \%>\% + broom::tidy() \%>\% + select(statistic, p.value) +} + +trial |> + tbl_summary( + by = trt, + include = c(trt, age, marker), + missing = "no" + ) |> + add_stat(fns = everything() ~ my_ttest3) |> + modify_header(statistic = "**t-statistic**", p.value = "**p-value**") |> + modify_fmt_fun(list(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2))) +} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 3702959890..23eeccc67a 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -64,26 +64,27 @@ reference: - add_n.tbl_summary # - add_ci # - add_stat_label - # - add_stat + - add_stat # - separate_p_footnotes # - subtitle: Cross Tables # - contents: # - tbl_cross # - add_p.tbl_cross - # - subtitle: Continuous Variable Summary - # - contents: + - subtitle: Continuous Variable Summary + - contents: # - tbl_continuous # - add_overall # - add_p.tbl_continuous - # - subtitle: Time-to-event Summary Tables + - add_stat + # - subtitle: Time-to-event Summary Tables # - contents: # - tbl_survfit # - add_p.tbl_survfit # - add_n.tbl_survfit # - add_nevent.tbl_survfit # - add_q - # - subtitle: Survey Design Summary Tables - # - contents: + - subtitle: Survey Design Summary Tables + - contents: # - tbl_svysummary # - add_p.tbl_svysummary # - add_q @@ -92,7 +93,7 @@ reference: # - add_ci # - add_n.tbl_svysummary # - add_stat_label - # - add_stat + - add_stat # - separate_p_footnotes # - subtitle: Custom Summary Tables # - contents: diff --git a/tests/testthat/_snaps/add_n.tbl_regression.md b/tests/testthat/_snaps/add_n.tbl_regression.md deleted file mode 100644 index 0219d8dbca..0000000000 --- a/tests/testthat/_snaps/add_n.tbl_regression.md +++ /dev/null @@ -1,36 +0,0 @@ -# add_n.tbl_regression - - Code - res %>% as.data.frame() - Output - **Characteristic** **N** **log(OR)** **95% CI** **p-value** - 1 Grade 183 - 2 I - 3 II -0.16 -0.94, 0.61 0.7 - 4 III 0.01 -0.74, 0.77 >0.9 - 5 Age 183 0.02 0.00, 0.04 0.10 - ---- - - Code - res %>% as.data.frame() - Output - **Characteristic** **N** **log(OR)** **95% CI** **p-value** - 1 Grade - 2 I 65 - 3 II 58 -0.16 -0.94, 0.61 0.7 - 4 III 60 0.01 -0.74, 0.77 >0.9 - 5 Age 183 0.02 0.00, 0.04 0.10 - ---- - - Code - res %>% as.data.frame() - Output - **Characteristic** **N** **log(OR)** **95% CI** **p-value** - 1 Grade 183 - 2 I 65 - 3 II 58 -0.16 -0.94, 0.61 0.7 - 4 III 60 0.01 -0.74, 0.77 >0.9 - 5 Age 183 0.02 0.00, 0.04 0.10 - diff --git a/tests/testthat/_snaps/add_stat.md b/tests/testthat/_snaps/add_stat.md new file mode 100644 index 0000000000..9a28e5c30d --- /dev/null +++ b/tests/testthat/_snaps/add_stat.md @@ -0,0 +1,40 @@ +# add_stat(fns) messaging + + Code + result <- add_stat(tbl, fns = everything() ~ mean) + Message + There was a error for variable "age" + x argument "x" is missing, with no default + There was a error for variable "marker" + x argument "x" is missing, with no default + +--- + + Code + add_stat(tbl_summary(trial, include = age, type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}")), fns = everything() ~ + return_two_by_two_10s, location = everything() ~ "label") + Condition + Error in `add_stat()`: + ! Dimension of "age" and the added statistic do not match. + i Expecting statistic/data frame to be length/no. rows 1. + +--- + + Code + add_stat(add_stat(tbl_summary(trial, include = age, type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}")), fns = everything() ~ + return_two_by_two_10s, location = everything() ~ "level"), fns = everything() ~ + return_two_by_two_10s, location = everything() ~ "level") + Condition + Error in `add_stat()`: + ! Cannot add new column that already exist in table: "one" and "two". + +# add_stat(x) messaging + + Code + add_stat(mtcars, fns = everything() ~ my_ttest2) + Condition + Error in `add_stat()`: + ! The `x` argument must be class , not a data frame. + diff --git a/tests/testthat/_snaps/tbl_summary.md b/tests/testthat/_snaps/tbl_summary.md index 33b044cb86..3c7788e61b 100644 --- a/tests/testthat/_snaps/tbl_summary.md +++ b/tests/testthat/_snaps/tbl_summary.md @@ -231,11 +231,11 @@ # A tibble: 9 x 4 variable var_type row_type label - 1 age continuous header Age - 2 marker continuous2 header Marker Level (ng/mL) + 1 age continuous label Age + 2 marker continuous2 label Marker Level (ng/mL) 3 marker continuous2 level Median (Q1, Q3) - 4 response dichotomous header Tumor Response - 5 stage categorical header T Stage + 4 response dichotomous label Tumor Response + 5 stage categorical label T Stage 6 stage categorical level T1 7 stage categorical level T2 8 stage categorical level T3 diff --git a/tests/testthat/test-add_stat.R b/tests/testthat/test-add_stat.R new file mode 100644 index 0000000000..22f124472b --- /dev/null +++ b/tests/testthat/test-add_stat.R @@ -0,0 +1,173 @@ +my_ttest <- function(data, variable, by, ...) { + t.test(data[[variable]] ~ as.factor(data[[by]]))$p.value +} + +my_ttest2 <- function(data, variable, by, ...) { + tt <- t.test(data[[variable]] ~ as.factor(data[[by]])) + + # returning test statistic and pvalue + glue::glue( + "t={style_sigfig(tt$statistic)}, {style_pvalue(tt$p.value, prepend_p = TRUE)}" + ) +} + +tbl <- trial %>% + select(trt, age, marker) %>% + tbl_summary(by = trt, missing = "no") + +test_that("add_stat() works with fns that return a scalar", { + expect_error( + test1 <- tbl |> + add_p(test = everything() ~ t.test) |> + # replicating result of `add_p()` with `add_stat()` + add_stat( + fns = everything() ~ my_ttest # all variables compared with with t-test + ), + NA + ) + + # checking the pvalues match + expect_equal( + test1$table_body$p.value, + test1$table_body$add_stat_1 + ) + + expect_error( + tbl |> + add_stat( + fns = everything() ~ my_ttest2, # all variables will be compared by t-test + ), + NA + ) +}) + +test_that("add_stat() works with fns that returns a vector", { + return_three_10s <- function(...) rep_len(10, 3) + expect_equal( + trial |> + tbl_summary(include = grade) |> + add_stat( + fns = everything() ~ return_three_10s, + location = all_categorical() ~ "level" + ) |> + as.data.frame(col_label = FALSE) |> + dplyr::pull(add_stat_1), + c(NA, "10.0", "10.0", "10.0") + ) + + expect_equal( + trial |> + tbl_summary( + include = age, + type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{min}", "{max}") + ) %>% + add_stat( + fns = everything() ~ return_three_10s, + location = everything() ~ "level" + ) |> + as.data.frame(col_label = FALSE) |> + dplyr::pull(add_stat_1), + c(NA, "10.0", "10.0", "10.0", NA) + ) +}) + +test_that("add_stat() works with fns that returns a tibble", { + return_two_by_two_10s <- function(...) dplyr::tibble(one = rep_len(10, 2), two = rep_len(10, 2)) + expect_equal( + trial |> + tbl_summary( + include = age, + type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}") + ) |> + add_stat( + fns = everything() ~ return_two_by_two_10s, + location = everything() ~ "level" + ) |> + as_tibble(col_label = FALSE) |> + dplyr::select(one, two), + dplyr::bind_rows( + dplyr::tibble(one = NA, two = NA), + return_two_by_two_10s(), + dplyr::tibble(one = NA, two = NA) + ) |> + dplyr::mutate(across(everything(), styfn_sigfig(digits = 3))) + ) + + return_one_by_two_10s <- function(...) dplyr::tibble(one = rep_len(10, 1), two = rep_len(10, 1)) + expect_equal( + trial |> + tbl_summary( + include = age, + type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}"), + missing = "always" + ) %>% + add_stat( + fns = everything() ~ return_one_by_two_10s, + location = everything() ~ "missing" + ) |> + as_tibble(col_label = FALSE) |> + dplyr::select(one, two), + dplyr::bind_rows( + dplyr::tibble(one = c(NA, NA, NA), two = c(NA, NA, NA)), + return_one_by_two_10s(), + ) |> + dplyr::mutate(across(everything(), styfn_sigfig(digits = 3))) + ) +}) + +test_that("add_stat(fns) messaging", { + # pass a function, but it does not accept the correct arguments + expect_snapshot( + result <- tbl |> add_stat(fns = everything() ~ mean) + ) + + return_two_by_two_10s <- function(...) dplyr::tibble(one = rep_len(10, 2), two = rep_len(10, 2)) + expect_snapshot( + error = TRUE, + trial |> + tbl_summary( + include = age, + type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}") + ) |> + add_stat( + fns = everything() ~ return_two_by_two_10s, + location = everything() ~ "label" + ) + ) + + return_two_by_two_10s <- function(...) dplyr::tibble(one = rep_len(10, 2), two = rep_len(10, 2)) + expect_snapshot( + error = TRUE, + trial |> + tbl_summary( + include = age, + type = age ~ "continuous2", + statistic = everything() ~ c("{mean}", "{sd}") + ) |> + add_stat( + fns = everything() ~ return_two_by_two_10s, + location = everything() ~ "level" + ) |> + add_stat( + fns = everything() ~ return_two_by_two_10s, + location = everything() ~ "level" + ) + ) +}) + +test_that("add_stat(x) messaging", { + # function only accepts certain gtsummary tables + expect_snapshot( + error = TRUE, + mtcars |> + add_stat(fns = everything() ~ my_ttest2) + ) +}) + +# TODO: Add `tbl_svysummary()` tests + +# TODO: Add `tbl_continuous()` tests diff --git a/tests/testthat/test-tbl_summary.R b/tests/testthat/test-tbl_summary.R index b2f3333d4e..b89351bfdf 100644 --- a/tests/testthat/test-tbl_summary.R +++ b/tests/testthat/test-tbl_summary.R @@ -40,7 +40,7 @@ test_that("tbl_summary(label)", { expect_equal( tbl$table_body |> - dplyr::filter(row_type %in% "header") |> + dplyr::filter(row_type %in% "label") |> dplyr::pull(label), c("New mpg", "New cyl") ) From b29f9cd5a3b990ce02ed6a174a8ab9afac6ebee7 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 18 May 2024 16:11:12 -0700 Subject: [PATCH 65/74] v2.0 `add_stat_label.tbl_summary()` (#1669) * progress * progress * doc updates --- NAMESPACE | 2 + R/add_stat_label.R | 247 ++++++++++++++++++++++ R/tbl_regression.R | 2 +- R/tbl_summary.R | 12 +- man/add_stat_label.Rd | 98 +++++++++ man/figures/lifecycle-archived.svg | 21 ++ man/figures/lifecycle-defunct.svg | 21 ++ man/figures/lifecycle-deprecated.svg | 21 ++ man/figures/lifecycle-experimental.svg | 21 ++ man/figures/lifecycle-maturing.svg | 21 ++ man/figures/lifecycle-questioning.svg | 21 ++ man/figures/lifecycle-soft-deprecated.svg | 21 ++ man/figures/lifecycle-stable.svg | 29 +++ man/figures/lifecycle-superseded.svg | 21 ++ man/tbl_regression.Rd | 2 +- pkgdown/_pkgdown.yml | 2 +- tests/testthat/_snaps/add_stat_label.md | 120 +++++++++++ tests/testthat/test-add_stat_label.R | 81 +++++++ 18 files changed, 751 insertions(+), 12 deletions(-) create mode 100644 R/add_stat_label.R create mode 100644 man/add_stat_label.Rd create mode 100644 man/figures/lifecycle-archived.svg create mode 100644 man/figures/lifecycle-defunct.svg create mode 100644 man/figures/lifecycle-deprecated.svg create mode 100644 man/figures/lifecycle-experimental.svg create mode 100644 man/figures/lifecycle-maturing.svg create mode 100644 man/figures/lifecycle-questioning.svg create mode 100644 man/figures/lifecycle-soft-deprecated.svg create mode 100644 man/figures/lifecycle-stable.svg create mode 100644 man/figures/lifecycle-superseded.svg create mode 100644 tests/testthat/_snaps/add_stat_label.md create mode 100644 tests/testthat/test-add_stat_label.R diff --git a/NAMESPACE b/NAMESPACE index 1b4e2d223d..d5cc098d63 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ S3method(add_n,tbl_summary) S3method(add_nevent,tbl_regression) S3method(add_overall,tbl_summary) S3method(add_p,tbl_summary) +S3method(add_stat_label,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) S3method(assign_tests,tbl_summary) @@ -20,6 +21,7 @@ export(add_overall) export(add_p) export(add_q) export(add_stat) +export(add_stat_label) export(all_categorical) export(all_continuous) export(all_continuous2) diff --git a/R/add_stat_label.R b/R/add_stat_label.R new file mode 100644 index 0000000000..2568b6baf7 --- /dev/null +++ b/R/add_stat_label.R @@ -0,0 +1,247 @@ +#' Add statistic labels +#' +#' `r lifecycle::badge('questioning')`\cr +#' Adds or modifies labels describing the summary statistics presented for +#' each variable in a [`tbl_summary()`] table. +#' +#' @param x (`tbl_summary`)\cr +#' Object with class `'tbl_summary'` or with class `'tbl_svysummary'` +#' @param location (`string`)\cr +#' Location where statistic label will be included. +#' `"row"` (the default) to add the statistic label to the variable label row, +#' and `"column"` adds a column with the statistic label. +#' @param label ([`formula-list-selector`][syntax])\cr +#' indicates the updates to the statistic label, e.g. `label = all_categorical() ~ "No. (%)"`. +#' When not specified, the default statistic labels are used. +#' @inheritParams rlang::args_dots_empty +#' +#' @section Tips: +#' +#' When using `add_stat_label(location='row')` with subsequent `tbl_merge()`, +#' it's important to have somewhat of an understanding of the underlying +#' structure of the gtsummary table. +#' `add_stat_label(location='row')` works by adding a new column called +#' `"stat_label"` to `x$table_body`. The `"label"` and `"stat_label"` +#' columns are merged when the gtsummary table is printed. +#' The `tbl_merge()` function merges on the `"label"` column (among others), +#' which is typically the first column you see in a gtsummary table. +#' Therefore, when you want to merge a table that has run `add_stat_label(location='row')` +#' you need to match the `"label"` column values before the `"stat_column"` +#' is merged with it. +#' +#' For example, the following two tables merge properly +#' +#' ```r +#' tbl1 <- trial %>% select(age, grade) |> tbl_summary() |> add_stat_label() +#' tbl2 <- lm(marker ~ age + grade, trial) |> tbl_regression() +#' +#' tbl_merge(list(tbl1, tbl2)) +#' ``` +#' +#' The addition of the new `"stat_label"` column requires a default +#' labels for categorical variables, which is `"No. (%)"`. This +#' can be changed to either desired text or left blank using `NA_character_`. +#' The blank option is useful in the `location="row"` case to keep the +#' output for categorical variables identical what was produced without +#' a `"add_stat_label()"` function call. +#' +#' @author Daniel D. Sjoberg +#' @name add_stat_label +#' @return A `tbl_summary` or `tbl_svysummary` object +#' +#' @examples +#' tbl <- trial |> +#' dplyr::select(trt, age, grade, response) |> +#' tbl_summary(by = trt) +#' +#' # Example 1 ---------------------------------- +#' # Add statistic presented to the variable label row +#' tbl |> +#' add_stat_label( +#' # update default statistic label for continuous variables +#' label = all_continuous() ~ "med. (iqr)" +#' ) +#' +#' # Example 2 ---------------------------------- +#' tbl |> +#' add_stat_label( +#' # add a new column with statistic labels +#' location = "column" +#' ) +#' +#' # Example 3 ---------------------------------- +#' trial |> +#' select(age, grade, trt) |> +#' tbl_summary( +#' by = trt, +#' type = all_continuous() ~ "continuous2", +#' statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min} - {max}"), +#' ) |> +#' add_stat_label(label = age ~ c("IQR", "Range")) +NULL + +#' @export +#' @rdname add_stat_label +add_stat_label <- function(x, ...) { + check_not_missing(x) + check_class(x, "gtsummary") + UseMethod("add_stat_label") +} + +#' @export +#' @rdname add_stat_label +add_stat_label.tbl_summary <- function(x, location = c("row", "column"), label = NULL, ...) { + set_cli_abort_call() + check_dots_empty() + updated_call_list <- c(x$call_list, list(add_stat_label = match.call())) + + # check inputs --------------------------------------------------------------- + check_not_missing(label) + if ("add_stat_label" %in% names(x$call_list)) { + cli::cli_inform("{.code add_stat_label()} has previously been applied. Returning {.pkg gtsummary} table unaltered.") + return(x) + } + + # process arguments ---------------------------------------------------------- + if (missing(location)) { + location <- get_theme_element("add_stat_label-arg:location", default = location) + location <- arg_match(location) + } + + cards::process_formula_selectors( + select_prep(x$table_body), + label = label + ) + # check the label values are all string (except continuous2) + imap( + label[intersect(names(label), x$inputs$type |> discard(~.x == "continuous2") |> names())], + function(.x, .y) { + if (!is_string(.x)) { + cli::cli_abort( + "Elements of the {.arg label} argument for variable {.val {.y}} must be a string of length 1.", + all = get_cli_abort_call() + ) + } + } + ) + updated_variables <- names(label) # variable whose stat labels were updated from the defaults + cards::fill_formula_selectors( + select_prep(x$table_body), + label = .add_stat_label_default_label_arg(x, statistic = x$inputs$statistic) + ) + + # create df_stat_label to merge into `.$table_body`, + # (does not include continuous2 variables) + df_stat_label <- + x$table_body[c("variable", "var_type")] |> + dplyr::distinct() |> + dplyr::filter(!.data$var_type %in% "continuous2") |> + dplyr::mutate( + stat_label = map_chr(.data$variable, ~label[[.x]]), + row_type = + ifelse( + .env$location %in% "column" & .data$var_type %in% "categorical", + "level", + "label" + ) + ) + + if (location %in% "column") { + df_stat_label <- + df_stat_label %>% + dplyr::bind_rows( + dplyr::select(., "variable", "var_type") |> + dplyr::mutate( + row_type = "missing", + stat_label = + glue::glue( + x$inputs$missing_stat, + .envir = list(N_obs = "N", + N_miss = "n", + N_nonmiss = "N - n", + p_miss = "p", + p_nonmiss = "1 - p") + ) + ) + ) + } + + # update the label column for continuous2 variables -------------------------- + cont2_vars_with_new_label <- names(keep(x$inputs$type, ~ .x == "continuous2")) |> intersect(updated_variables) + if (!is_empty(cont2_vars_with_new_label)) { + # first, check the dimension of the passed value + walk( + cont2_vars_with_new_label, + function(.x) { + if (!is.character(label[[.x]]) || length(label[[.x]]) != length(x$inputs$statistic[[.x]])) { + cli::cli_abort( + "The element of the {.arg label} argument for variable {.val {.x}} + must be a string of length {.val {length(x$inputs$statistic[[.x]])}}.", + call = get_cli_abort_call() + ) + } + } + ) + + # now update the label column of .$table_body + for (variable in cont2_vars_with_new_label) { + x$table_body$label[x$table_body$variable %in% variable & x$table_body$row_type %in% "level"] <- + label[[variable]] + } + } + + # add df_stat_label to `.$table_body` ---------------------------------------- + x <- + modify_table_body( + x, + ~ dplyr::left_join( + .x, + df_stat_label, + by = c("variable", "var_type", "row_type") + ) |> + dplyr::relocate("stat_label", .after = "label") + ) |> + modify_table_styling( + columns = "stat_label", + hide = location %in% "row", + label = paste0("**", translate_text("Statistic"), "**") + ) + + if (location %in% "row") { + x <- x |> + modify_table_styling( + columns = "label", + rows = !is.na(.data$stat_label), + cols_merge_pattern = "{label}, {stat_label}" + ) + } + + # keeping track of all functions previously run ------------------------------ + # fill in the Ns in the header table modify_stat_* columns + x <- .fill_table_header_modify_stats(x) + x$call_list <- updated_call_list + + x +} + +.add_stat_label_default_label_arg <- function(x, statistic) { + statistic |> + imap( + function(full_statistic, variable) { + map_chr( + full_statistic, + function(sub_statistic) { + eval_tidy( + expr(glue::glue(gsub("\\{(p|p_miss|p_nonmiss|p_unweighted)\\}%", "{\\1}", x = sub_statistic))), + cards::get_ard_statistics( + x$cards[[1]] |> + dplyr::filter(.data$variable %in% variable) |> + dplyr::distinct(.data$stat_name, .data$stat_label), + .column = "stat_label" + ) + ) + } + ) + } + ) +} diff --git a/R/tbl_regression.R b/R/tbl_regression.R index 1abaad29a0..918252bb71 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -47,7 +47,7 @@ #' The default method for `tbl_regression()` model summary uses `broom::tidy(x)` #' to perform the initial tidying of the model object. There are, however, #' a few models that use `[modifications][tbl_regression_methods]`. -#' TODO: Added the tbl_regression_methods help mentioned file above. +#' TODO: Re-add link to tbl_regression_methods above. #' #' - `"parsnip/workflows"`: If the model was prepared using parsnip/workflows, #' the original model fit is extracted and the original `x=` argument diff --git a/R/tbl_summary.R b/R/tbl_summary.R index bcf66c863f..e6b97b0f51 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -460,11 +460,9 @@ tbl_summary <- function(data, dplyr::filter(.data$variable %in% .env$variable) |> dplyr::select("stat_name", "stat_label") |> dplyr::distinct() %>% - { - stats::setNames(as.list(.$stat_label), .$stat_name) - } |> + {stats::setNames(as.list(.$stat_label), .$stat_name)} |> # styler: off glue::glue_data( - gsub("\\{(p|p_miss|p_nonmiss)\\}%", "{\\1}", x = statistic[[variable]]) + gsub("\\{(p|p_miss|p_nonmiss|p_unweighted)\\}%", "{\\1}", x = statistic[[variable]]) ) } ) |> @@ -472,11 +470,7 @@ tbl_summary <- function(data, compact() |> unlist() |> unique() %>% - { - switch(!is.null(.), - paste(., collapse = "; ") - ) - } + {switch(!is.null(.), paste(., collapse = "; "))} # styler: off } diff --git a/man/add_stat_label.Rd b/man/add_stat_label.Rd new file mode 100644 index 0000000000..3e121ae035 --- /dev/null +++ b/man/add_stat_label.Rd @@ -0,0 +1,98 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_stat_label.R +\name{add_stat_label} +\alias{add_stat_label} +\alias{add_stat_label.tbl_summary} +\title{Add statistic labels} +\usage{ +add_stat_label(x, ...) + +\method{add_stat_label}{tbl_summary}(x, location = c("row", "column"), label = NULL, ...) +} +\arguments{ +\item{x}{(\code{tbl_summary})\cr +Object with class \code{'tbl_summary'} or with class \code{'tbl_svysummary'}} + +\item{...}{These dots are for future extensions and must be empty.} + +\item{location}{(\code{string})\cr +Location where statistic label will be included. +\code{"row"} (the default) to add the statistic label to the variable label row, +and \code{"column"} adds a column with the statistic label.} + +\item{label}{(\code{\link[=syntax]{formula-list-selector}})\cr +indicates the updates to the statistic label, e.g. \code{label = all_categorical() ~ "No. (\%)"}. +When not specified, the default statistic labels are used.} +} +\value{ +A \code{tbl_summary} or \code{tbl_svysummary} object +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}}\cr +Adds or modifies labels describing the summary statistics presented for +each variable in a \code{\link[=tbl_summary]{tbl_summary()}} table. +} +\section{Tips}{ + + +When using \code{add_stat_label(location='row')} with subsequent \code{tbl_merge()}, +it's important to have somewhat of an understanding of the underlying +structure of the gtsummary table. +\code{add_stat_label(location='row')} works by adding a new column called +\code{"stat_label"} to \code{x$table_body}. The \code{"label"} and \code{"stat_label"} +columns are merged when the gtsummary table is printed. +The \code{tbl_merge()} function merges on the \code{"label"} column (among others), +which is typically the first column you see in a gtsummary table. +Therefore, when you want to merge a table that has run \code{add_stat_label(location='row')} +you need to match the \code{"label"} column values before the \code{"stat_column"} +is merged with it. + +For example, the following two tables merge properly + +\if{html}{\out{
}}\preformatted{tbl1 <- trial \%>\% select(age, grade) |> tbl_summary() |> add_stat_label() +tbl2 <- lm(marker ~ age + grade, trial) |> tbl_regression() + +tbl_merge(list(tbl1, tbl2)) +}\if{html}{\out{
}} + +The addition of the new \code{"stat_label"} column requires a default +labels for categorical variables, which is \code{"No. (\%)"}. This +can be changed to either desired text or left blank using \code{NA_character_}. +The blank option is useful in the \code{location="row"} case to keep the +output for categorical variables identical what was produced without +a \code{"add_stat_label()"} function call. +} + +\examples{ +tbl <- trial |> + dplyr::select(trt, age, grade, response) |> + tbl_summary(by = trt) + +# Example 1 ---------------------------------- +# Add statistic presented to the variable label row +tbl |> + add_stat_label( + # update default statistic label for continuous variables + label = all_continuous() ~ "med. (iqr)" + ) + +# Example 2 ---------------------------------- +tbl |> + add_stat_label( + # add a new column with statistic labels + location = "column" + ) + +# Example 3 ---------------------------------- +trial |> + select(age, grade, trt) |> + tbl_summary( + by = trt, + type = all_continuous() ~ "continuous2", + statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min} - {max}"), + ) |> + add_stat_label(label = age ~ c("IQR", "Range")) +} +\author{ +Daniel D. Sjoberg +} diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg new file mode 100644 index 0000000000..745ab0c781 --- /dev/null +++ b/man/figures/lifecycle-archived.svg @@ -0,0 +1,21 @@ + + lifecycle: archived + + + + + + + + + + + + + + + lifecycle + + archived + + diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg new file mode 100644 index 0000000000..d5c9559edb --- /dev/null +++ b/man/figures/lifecycle-defunct.svg @@ -0,0 +1,21 @@ + + lifecycle: defunct + + + + + + + + + + + + + + + lifecycle + + defunct + + diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 0000000000..b61c57c3f9 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 0000000000..5d88fc2c65 --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1,21 @@ + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg new file mode 100644 index 0000000000..897370ecf5 --- /dev/null +++ b/man/figures/lifecycle-maturing.svg @@ -0,0 +1,21 @@ + + lifecycle: maturing + + + + + + + + + + + + + + + lifecycle + + maturing + + diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg new file mode 100644 index 0000000000..7c1721d05c --- /dev/null +++ b/man/figures/lifecycle-questioning.svg @@ -0,0 +1,21 @@ + + lifecycle: questioning + + + + + + + + + + + + + + + lifecycle + + questioning + + diff --git a/man/figures/lifecycle-soft-deprecated.svg b/man/figures/lifecycle-soft-deprecated.svg new file mode 100644 index 0000000000..9c166ff30b --- /dev/null +++ b/man/figures/lifecycle-soft-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: soft-deprecated + + + + + + + + + + + + + + + lifecycle + + soft-deprecated + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 0000000000..9bf21e76bc --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1,29 @@ + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 0000000000..db8d757f70 --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1,21 @@ + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/tbl_regression.Rd b/man/tbl_regression.Rd index 8534a3a5c4..113bfcccc5 100644 --- a/man/tbl_regression.Rd +++ b/man/tbl_regression.Rd @@ -87,7 +87,7 @@ for detailed examples. The default method for \code{tbl_regression()} model summary uses \code{broom::tidy(x)} to perform the initial tidying of the model object. There are, however, a few models that use \verb{[modifications][tbl_regression_methods]}. -TODO: Added the tbl_regression_methods help mentioned file above. +TODO: Re-add link to tbl_regression_methods above. \itemize{ \item \code{"parsnip/workflows"}: If the model was prepared using parsnip/workflows, the original model fit is extracted and the original \verb{x=} argument diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 23eeccc67a..becc913ec2 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -63,7 +63,7 @@ reference: - add_difference.tbl_summary - add_n.tbl_summary # - add_ci - # - add_stat_label + - add_stat_label - add_stat # - separate_p_footnotes # - subtitle: Cross Tables diff --git a/tests/testthat/_snaps/add_stat_label.md b/tests/testthat/_snaps/add_stat_label.md new file mode 100644 index 0000000000..f17d034468 --- /dev/null +++ b/tests/testthat/_snaps/add_stat_label.md @@ -0,0 +1,120 @@ +# add_stat_label(location='row') standard use + + Code + as.data.frame(modify_column_hide(add_stat_label(tbl, location = "row"), + all_stat_cols())) + Output + **Characteristic** + 1 Age, Median (Q1, Q3) + 2 Unknown + 3 Marker Level (ng/mL), Median (Q1, Q3) + 4 Unknown + 5 T Stage, n (%) + 6 T1 + 7 T2 + 8 T3 + 9 T4 + 10 Grade, n (%) + 11 I + 12 II + 13 III + 14 Tumor Response, n (%) + 15 Unknown + 16 Patient Died, n (%) + 17 Months to Death/Censor, Median (Q1, Q3) + +# add_stat_label(location='column') standard use + + Code + as.data.frame(modify_column_hide(add_stat_label(tbl, location = "column"), + all_stat_cols())) + Output + **Characteristic** **Statistic** + 1 Age Median (Q1, Q3) + 2 Unknown n + 3 Marker Level (ng/mL) Median (Q1, Q3) + 4 Unknown n + 5 T Stage + 6 T1 n (%) + 7 T2 n (%) + 8 T3 n (%) + 9 T4 n (%) + 10 Grade + 11 I n (%) + 12 II n (%) + 13 III n (%) + 14 Tumor Response n (%) + 15 Unknown n + 16 Patient Died n (%) + 17 Months to Death/Censor Median (Q1, Q3) + +--- + + Code + as.data.frame(modify_column_hide(add_stat_label(tbl, location = "column", + label = all_categorical() ~ "no. (%)"), all_stat_cols())) + Output + **Characteristic** **Statistic** + 1 Age Median (Q1, Q3) + 2 Unknown n + 3 Marker Level (ng/mL) Median (Q1, Q3) + 4 Unknown n + 5 T Stage + 6 T1 no. (%) + 7 T2 no. (%) + 8 T3 no. (%) + 9 T4 no. (%) + 10 Grade + 11 I no. (%) + 12 II no. (%) + 13 III no. (%) + 14 Tumor Response no. (%) + 15 Unknown n + 16 Patient Died no. (%) + 17 Months to Death/Censor Median (Q1, Q3) + +# add_stat_label(label) standard use + + Code + as.data.frame(add_stat_label(tbl_summary(trial, include = c(age, grade, trt), + by = trt, type = all_continuous() ~ "continuous2", statistic = all_continuous() ~ + c("{median} ({p25}, {p75})", "{min} - {max}"), ), label = age ~ c( + "Median (IQR)", "Range"))) + Output + **Characteristic** **Drug A** \nN = 98 **Drug B** \nN = 102 + 1 Age + 2 Median (IQR) 46 (37, 60) 48 (39, 56) + 3 Range 6 - 78 9 - 83 + 4 Unknown 7 4 + 5 Grade, n (%) + 6 I 35 (36%) 33 (32%) + 7 II 32 (33%) 36 (35%) + 8 III 31 (32%) 33 (32%) + +# add_stat_label(label) messaging + + Code + add_stat_label(tbl_summary(trial, include = c(age, trt), by = trt, ), label = age ~ + letters) + Condition + Error: + ! Elements of the `label` argument for variable "age" must be a string of length 1. + +--- + + Code + add_stat_label(tbl_summary(trial, include = c(age, grade, trt), by = trt, type = all_continuous() ~ + "continuous2", statistic = all_continuous() ~ c("{median} ({p25}, {p75})", + "{min} - {max}"), ), label = age ~ c("Median (IQR)", "Range", "TOO LONG!")) + Condition + Error in `add_stat_label()`: + ! The element of the `label` argument for variable "age" must be a string of length 2. + +# add_stat_label() messaging + + Code + invisible(add_stat_label(add_stat_label(tbl_summary(trial, include = c(age, trt), + )))) + Message + `add_stat_label()` has previously been applied. Returning gtsummary table unaltered. + diff --git a/tests/testthat/test-add_stat_label.R b/tests/testthat/test-add_stat_label.R new file mode 100644 index 0000000000..b33f34624a --- /dev/null +++ b/tests/testthat/test-add_stat_label.R @@ -0,0 +1,81 @@ +test_that("add_stat_label(location='row') standard use", { + tbl <- trial |> tbl_summary(by = trt) + + expect_snapshot( + tbl |> + add_stat_label(location='row') |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) +}) + +test_that("add_stat_label(location='column') standard use", { + tbl <- trial |> tbl_summary(by = trt) + + expect_snapshot( + tbl |> + add_stat_label(location='column') |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) + + expect_snapshot( + tbl |> + add_stat_label(location = "column", label = all_categorical() ~ "no. (%)") |> + modify_column_hide(all_stat_cols()) |> + as.data.frame() + ) +}) + +test_that("add_stat_label(label) standard use", { + expect_snapshot( + trial |> + tbl_summary( + include = c(age, grade, trt), + by = trt, + type = all_continuous() ~ "continuous2", + statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min} - {max}"), + ) |> + add_stat_label(label = age ~ c("Median (IQR)", "Range")) |> + as.data.frame() + ) +}) + +test_that("add_stat_label(label) messaging", { + expect_snapshot( + error = TRUE, + trial |> + tbl_summary( + include = c(age, trt), + by = trt, + ) |> + add_stat_label(label = age ~ letters) + ) + + expect_snapshot( + error = TRUE, + trial |> + tbl_summary( + include = c(age, grade, trt), + by = trt, + type = all_continuous() ~ "continuous2", + statistic = all_continuous() ~ c("{median} ({p25}, {p75})", "{min} - {max}"), + ) |> + add_stat_label(label = age ~ c("Median (IQR)", "Range", "TOO LONG!")) + ) +}) + +test_that("add_stat_label() messaging", { + expect_snapshot( + trial |> + tbl_summary( + include = c(age, trt), + ) |> + add_stat_label() |> + add_stat_label() |> + invisible() + ) +}) +# TODO: Add tests for `tbl_svysummary()` + +# TODO: Add tests with `tbl_merge()` From a244c17e8a8210cf4148f952ddde884b2c1a5192 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 18 May 2024 16:46:09 -0700 Subject: [PATCH 66/74] Update add_stat_label.R --- R/add_stat_label.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/add_stat_label.R b/R/add_stat_label.R index 2568b6baf7..dc2da416c5 100644 --- a/R/add_stat_label.R +++ b/R/add_stat_label.R @@ -191,9 +191,8 @@ add_stat_label.tbl_summary <- function(x, location = c("row", "column"), label = } # add df_stat_label to `.$table_body` ---------------------------------------- - x <- + x <- x |> modify_table_body( - x, ~ dplyr::left_join( .x, df_stat_label, @@ -205,6 +204,11 @@ add_stat_label.tbl_summary <- function(x, location = c("row", "column"), label = columns = "stat_label", hide = location %in% "row", label = paste0("**", translate_text("Statistic"), "**") + ) |> + # removing stat footnote, since it's in the table now + modify_table_styling( + columns = all_stat_cols(), + footnote = NA_character_ ) if (location %in% "row") { From d748d10ae749fd17b0161a5812544a49739b6b30 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 19 May 2024 08:20:45 -0700 Subject: [PATCH 67/74] v2.0 `modify_table_styling()` (#1672) * progress * progress --- R/as_gt.R | 2 +- R/modify_table_styling.R | 140 ++++--- man/modify_column_hide.Rd | 6 +- man/modify_column_merge.Rd | 6 +- man/modify_fmt_fun.Rd | 5 +- man/modify_table_styling.Rd | 61 +-- tests/testthat/_snaps/modify_table_styling.md | 38 ++ tests/testthat/test-modify_table_styling.R | 396 ++++++++++++++++++ 8 files changed, 562 insertions(+), 92 deletions(-) create mode 100644 tests/testthat/_snaps/modify_table_styling.md create mode 100644 tests/testthat/test-modify_table_styling.R diff --git a/R/as_gt.R b/R/as_gt.R index 55232d2192..5506a9cdb0 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -141,7 +141,7 @@ table_styling_to_gt_calls <- function(x, ...) { columns = !!x$table_styling$indentation$column[[.x]], rows = !!x$table_styling$indentation$row_numbers[[.x]] ), - fn = function(x) paste0("\U00A0\U00A0\U00A0\U00A0", x) + fn = function(x) paste0(!!paste(rep_len("\U00A0", x$table_styling$indentation$n_spaces[[.x]]), collapse = ""), x) )) ) diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 26225f95f4..4c81009bd9 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -2,42 +2,55 @@ #' #' This is a function meant for advanced users to gain #' more control over the characteristics of the resulting -#' gtsummary table by directly modifying `.$table_styling` +#' gtsummary table by directly modifying `.$table_styling`. +#' *This function is primarily used in the development of other gtsummary +#' functions, and very little checking of the passed arguments is performed.* #' #' Review the #' \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition} #' vignette for information on `.$table_styling` objects. #' -#' @param x gtsummary object -#' @param columns vector or selector of columns in `x$table_body` -#' @param rows predicate expression to select rows in `x$table_body`. -#' Can be used to style footnote, formatting functions, missing symbols, -#' and text formatting. Default is `NULL`. See details below. -#' @param label string of column label(s) -#' @param hide logical indicating whether to hide column from output -#' @param align string indicating alignment of column, must be one of -#' `c("left", "right", "center")` -#' @param text_format,undo_text_format -#' string indicated which type of text formatting to apply/remove to the rows and columns. -#' Must be one of `c("bold", "italic")`. -#' @param text_interpret string, must be one of `"md"` or `"html"` -#' @param fmt_fun function that formats the statistics in the -#' columns/rows in `columns=` and `rows=` -#' @param footnote_abbrev string with abbreviation definition, e.g. -#' `"CI = Confidence Interval"` -#' @param footnote string with text for footnote -#' @param spanning_header string with text for spanning header -#' @param missing_symbol string indicating how missing values are formatted. -#' @param cols_merge_pattern \lifecycle{experimental} glue-syntax string -#' indicating how to merge -#' columns in `x$table_body`. For example, to construct a confidence interval -#' use `"{conf.low}, {conf.high}"`. The first column listed in the pattern -#' string must match the single column name passed in `columns=`. -#' @param indentation an integer indicating how many space to indent text +#' @param x (`gtsummary`)\cr +#' gtsummary object +#' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' Selector of columns in `x$table_body` +#' @param rows (predicate `expression`) +#' Predicate expression to select rows in `x$table_body`. +#' Can be used to style footnote, formatting functions, missing symbols, +#' and text formatting. Default is `NULL`. See details below. +#' @param label (`character`)\cr +#' Character vector of column label(s). Must be the same length as `columns`. +#' @param hide (scalar `logical`) +#' Logical indicating whether to hide column from output +#' @param align (`string`) +#' String indicating alignment of column, must be one of `c("left", "right", "center")` +#' @param text_format,undo_text_format (`string`)\cr +#' String indicated which type of text formatting to apply/remove to the rows and columns. +#' Must be one of `c("bold", "italic")`. +#' @param text_interpret (`string`)\cr +#' Must be one of `"md"` or `"html"` and indicates the processing function +#' as `gt::md()` or `gt::html()`. Use this in conjunction with arguments for +#' header and footnotes. +#' @param fmt_fun (`function`)\cr +#' function that formats the statistics in the columns/rows in `columns` and `rows` +#' @param footnote_abbrev (`string`)\cr +#' string with abbreviation definition, e.g. `"CI = Confidence Interval"` +#' @param footnote (`string`)\cr +#' string with text for footnote +#' @param spanning_header (`string`)\cr +#' string with text for spanning header +#' @param missing_symbol (`string`)\cr +#' string indicating how missing values are formatted. +#' @param cols_merge_pattern (`string`) \lifecycle{experimental}\cr +#' glue-syntax string indicating how to merge +#' columns in `x$table_body`. For example, to construct a confidence interval +#' use `"{conf.low}, {conf.high}"`. The first column listed in the pattern +#' string must match the single column name passed in `columns=`. +#' @param indentation (`integer`)\cr +#' An integer indicating how many space to indent text #' -#' @seealso `modify_table_body()` #' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} -#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' #' @export #' @family Advanced modifiers #' @@ -47,14 +60,14 @@ #' evaluated in `x$table_body`. For example, to apply formatting to the age rows #' pass `rows = variable == "age"`. A vector of row numbers is NOT acceptable. #' -#' A couple of things to note when using the `rows=` argument. +#' A couple of things to note when using the `rows` argument. #' 1. You can use saved objects to create the predicate argument, e.g. -#' `rows = variable == letters[1]`. +#' `rows = variable == letters[1]`. #' 2. The saved object cannot share a name with a column in `x$table_body`. -#' The reason for this is that in `tbl_merge()` the columns are renamed, -#' and the renaming process cannot disambiguate the `variable` column from -#' an external object named `variable` in the following expression -#' `rows = .data$variable = .env$variable`. +#' The reason for this is that in `tbl_merge()` the columns are renamed, +#' and the renaming process cannot disambiguate the `variable` column from +#' an external object named `variable` in the following expression +#' `rows = .data$variable = .env$variable`. #' #' @section cols_merge_pattern argument: #' @@ -162,10 +175,10 @@ modify_table_styling <- function(x, text_interpret <- paste0("gt::", arg_match(text_interpret)) - if (!is.null(text_format)) { + if (!is_empty(text_format)) { text_format <- arg_match(text_format, values = c("bold", "italic"), multiple = TRUE) } - if (!is.null(undo_text_format)) { + if (!is_empty(undo_text_format)) { undo_text_format <- arg_match(undo_text_format, values = c("bold", "italic"), multiple = TRUE) } rows <- enquo(rows) @@ -176,11 +189,14 @@ modify_table_styling <- function(x, error = function(e) TRUE ) if (rows_eval_error) { - abort("The `rows=` predicate expression must result in logical vector when evaluated with `x$table_body`") + cli::cli_abort( + "The {.arg rows} argument must be an expression that evaluates to a logical vector in {.code x$table_body}.", + call = get_cli_abort_call() + ) } # label ---------------------------------------------------------------------- - if (!is.null(label)) { + if (!is_empty(label)) { x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( @@ -190,7 +206,7 @@ modify_table_styling <- function(x, } # spanning_header ------------------------------------------------------------ - if (!is.null(spanning_header)) { + if (!is_empty(spanning_header)) { x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( @@ -200,7 +216,7 @@ modify_table_styling <- function(x, } # hide ----------------------------------------------------------------------- - if (!is.null(hide)) { + if (!is_empty(hide)) { x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( @@ -210,7 +226,7 @@ modify_table_styling <- function(x, } # align ---------------------------------------------------------------------- - if (!is.null(align)) { + if (!is_empty(align)) { x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( @@ -220,7 +236,7 @@ modify_table_styling <- function(x, } # footnote ------------------------------------------------------------------- - if (!is.null(footnote)) { + if (!is_empty(footnote)) { x$table_styling$footnote <- dplyr::bind_rows( x$table_styling$footnote, @@ -234,7 +250,7 @@ modify_table_styling <- function(x, } # footnote_abbrev ------------------------------------------------------------ - if (!is.null(footnote_abbrev)) { + if (!is_empty(footnote_abbrev)) { x$table_styling$footnote_abbrev <- dplyr::bind_rows( x$table_styling$footnote_abbrev, @@ -248,7 +264,7 @@ modify_table_styling <- function(x, } # fmt_fun -------------------------------------------------------------------- - if (!is.null(fmt_fun)) { + if (!is_empty(fmt_fun)) { if (rlang::is_function(fmt_fun)) fmt_fun <- list(fmt_fun) x$table_styling$fmt_fun <- dplyr::bind_rows( @@ -262,7 +278,7 @@ modify_table_styling <- function(x, } # text_format ---------------------------------------------------------------- - if (!is.null(text_format)) { + if (!is_empty(text_format)) { x$table_styling$text_format <- list( column = columns, @@ -273,7 +289,7 @@ modify_table_styling <- function(x, {tidyr::expand_grid(!!!.)} %>% # styler: off {dplyr::bind_rows(x$table_styling$text_format, .)} # styler: off } - if (!is.null(undo_text_format)) { + if (!is_empty(undo_text_format)) { x$table_styling$text_format <- list( column = columns, @@ -286,7 +302,7 @@ modify_table_styling <- function(x, } # indentation ---------------------------------------------------------------- - if (!is.null(indentation)) { + if (!is_empty(indentation)) { if (!rlang::is_scalar_integerish(indentation)) { cli::cli_abort("The {.arg indentation} argument must be a scalar integer.") } @@ -302,7 +318,7 @@ modify_table_styling <- function(x, } # missing_symbol ------------------------------------------------------------- - if (!is.null(missing_symbol)) { + if (!is_empty(missing_symbol)) { x$table_styling$fmt_missing <- list( column = columns, @@ -314,7 +330,8 @@ modify_table_styling <- function(x, } # cols_merge_pattern --------------------------------------------------------- - if (!is.null(cols_merge_pattern)) { + if (!is_empty(cols_merge_pattern)) { + if (!is.na(cols_merge_pattern)) check_string(cols_merge_pattern) x <- .modify_cols_merge( x, @@ -336,18 +353,21 @@ modify_table_styling <- function(x, all_columns <- .extract_glue_elements(pattern) if (!is_empty(pattern) && !all(all_columns %in% x$table_styling$header$column)) { - cli::cli_abort(c( - "All columns specified in {.arg cols_merge_pattern} argument must be present in {.code x$table_body}", - "i" = "The following columns are not present: {.val {setdiff(all_columns, x$table_styling$header$column)}}" - )) + cli::cli_abort( + c("All columns specified in {.arg cols_merge_pattern} argument must be present in {.code x$table_body}", + "i" = "The following columns are not present: {.val {setdiff(all_columns, x$table_styling$header$column)}}"), + call = get_cli_abort_call() + ) } - if (!is_empty(pattern) && !identical(column, all_columns[1])) { - paste( - "A single column must be passed when using {.arg cols_merge_pattern},", - "and that column must be the first to appear in the pattern argument." - ) %>% - cli::cli_abort() + if (!is.na(pattern) && !identical(column, all_columns[1])) { + cli::cli_abort( + c("A single column must be specified in the {.arg columns} argument when + using {.arg cols_merge_pattern}, and that column must be the first to + appear in the pattern argument.", + i = "For example, {.code modify_table_styling(columns={.val {all_columns[1]}}, cols_merge_pattern={.val {pattern}})}"), + call = get_cli_abort_call() + ) } x$table_styling$cols_merge <- diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 411d184d1e..b9809b48f9 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -10,9 +10,11 @@ modify_column_hide(x, columns) modify_column_unhide(x, columns) } \arguments{ -\item{x}{gtsummary object} +\item{x}{(\code{gtsummary})\cr +gtsummary object} -\item{columns}{vector or selector of columns in \code{x$table_body}} +\item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Selector of columns in \code{x$table_body}} } \description{ \lifecycle{maturing} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd index 438b896851..6d1ec538b2 100644 --- a/man/modify_column_merge.Rd +++ b/man/modify_column_merge.Rd @@ -7,13 +7,15 @@ modify_column_merge(x, pattern, rows = NULL) } \arguments{ -\item{x}{gtsummary object} +\item{x}{(\code{gtsummary})\cr +gtsummary object} \item{pattern}{glue syntax string indicating how to merge columns in \code{x$table_body}. For example, to construct a confidence interval use \code{"{conf.low}, {conf.high}"}.} -\item{rows}{predicate expression to select rows in \code{x$table_body}. +\item{rows}{(predicate \code{expression}) +Predicate expression to select rows in \code{x$table_body}. Can be used to style footnote, formatting functions, missing symbols, and text formatting. Default is \code{NULL}. See details below.} } diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index 3a63f7da4f..3a3db7161c 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -7,7 +7,8 @@ modify_fmt_fun(x, update, rows = NULL) } \arguments{ -\item{x}{gtsummary object} +\item{x}{(\code{gtsummary})\cr +gtsummary object} \item{update}{list of formulas or a single formula specifying the updated formatting function. @@ -29,7 +30,7 @@ rows to apply formatting. The expression must evaluate to a logical when evaluated in \code{x$table_body}. For example, to apply formatting to the age rows pass \code{rows = variable == "age"}. A vector of row numbers is NOT acceptable. -A couple of things to note when using the \verb{rows=} argument. +A couple of things to note when using the \code{rows} argument. \enumerate{ \item You can use saved objects to create the predicate argument, e.g. \code{rows = variable == letters[1]}. diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 7f216568d1..c6223ac318 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -24,42 +24,55 @@ modify_table_styling( ) } \arguments{ -\item{x}{gtsummary object} +\item{x}{(\code{gtsummary})\cr +gtsummary object} -\item{columns}{vector or selector of columns in \code{x$table_body}} +\item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Selector of columns in \code{x$table_body}} -\item{rows}{predicate expression to select rows in \code{x$table_body}. +\item{rows}{(predicate \code{expression}) +Predicate expression to select rows in \code{x$table_body}. Can be used to style footnote, formatting functions, missing symbols, and text formatting. Default is \code{NULL}. See details below.} -\item{label}{string of column label(s)} +\item{label}{(\code{character})\cr +Character vector of column label(s). Must be the same length as \code{columns}.} -\item{spanning_header}{string with text for spanning header} +\item{spanning_header}{(\code{string})\cr +string with text for spanning header} -\item{hide}{logical indicating whether to hide column from output} +\item{hide}{(scalar \code{logical}) +Logical indicating whether to hide column from output} -\item{footnote}{string with text for footnote} +\item{footnote}{(\code{string})\cr +string with text for footnote} -\item{footnote_abbrev}{string with abbreviation definition, e.g. -\code{"CI = Confidence Interval"}} +\item{footnote_abbrev}{(\code{string})\cr +string with abbreviation definition, e.g. \code{"CI = Confidence Interval"}} -\item{align}{string indicating alignment of column, must be one of -\code{c("left", "right", "center")}} +\item{align}{(\code{string}) +String indicating alignment of column, must be one of \code{c("left", "right", "center")}} -\item{missing_symbol}{string indicating how missing values are formatted.} +\item{missing_symbol}{(\code{string})\cr +string indicating how missing values are formatted.} -\item{fmt_fun}{function that formats the statistics in the -columns/rows in \verb{columns=} and \verb{rows=}} +\item{fmt_fun}{(\code{function})\cr +function that formats the statistics in the columns/rows in \code{columns} and \code{rows}} -\item{text_format, undo_text_format}{string indicated which type of text formatting to apply/remove to the rows and columns. +\item{text_format, undo_text_format}{(\code{string})\cr +String indicated which type of text formatting to apply/remove to the rows and columns. Must be one of \code{c("bold", "italic")}.} -\item{indentation}{an integer indicating how many space to indent text} +\item{indentation}{(\code{integer})\cr +An integer indicating how many space to indent text} -\item{text_interpret}{string, must be one of \code{"md"} or \code{"html"}} +\item{text_interpret}{(\code{string})\cr +Must be one of \code{"md"} or \code{"html"} and indicates the processing function +as \code{gt::md()} or \code{gt::html()}. Use this in conjunction with arguments for +header and footnotes.} -\item{cols_merge_pattern}{\lifecycle{experimental} glue-syntax string -indicating how to merge +\item{cols_merge_pattern}{(\code{string}) \lifecycle{experimental}\cr +glue-syntax string indicating how to merge columns in \code{x$table_body}. For example, to construct a confidence interval use \code{"{conf.low}, {conf.high}"}. The first column listed in the pattern string must match the single column name passed in \verb{columns=}.} @@ -67,7 +80,9 @@ string must match the single column name passed in \verb{columns=}.} \description{ This is a function meant for advanced users to gain more control over the characteristics of the resulting -gtsummary table by directly modifying \code{.$table_styling} +gtsummary table by directly modifying \code{.$table_styling}. +\emph{This function is primarily used in the development of other gtsummary +functions, and very little checking of the passed arguments is performed.} } \details{ Review the @@ -81,7 +96,7 @@ rows to apply formatting. The expression must evaluate to a logical when evaluated in \code{x$table_body}. For example, to apply formatting to the age rows pass \code{rows = variable == "age"}. A vector of row numbers is NOT acceptable. -A couple of things to note when using the \verb{rows=} argument. +A couple of things to note when using the \code{rows} argument. \enumerate{ \item You can use saved objects to create the predicate argument, e.g. \code{rows = variable == letters[1]}. @@ -115,12 +130,8 @@ internally with care, and it is \emph{not} recommended for users. } \seealso{ -\code{modify_table_body()} - See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} -Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary - Other Advanced modifiers: \code{\link{modify_column_hide}()}, \code{\link{modify_column_merge}()}, diff --git a/tests/testthat/_snaps/modify_table_styling.md b/tests/testthat/_snaps/modify_table_styling.md new file mode 100644 index 0000000000..a8c6b9d640 --- /dev/null +++ b/tests/testthat/_snaps/modify_table_styling.md @@ -0,0 +1,38 @@ +# modify_table_styling(cols_merge_pattern) messaging + + Code + modify_table_styling(tbl_regression(lm(mpg ~ factor(am), mtcars)), columns = "label", + rows = !is.na(conf.low), cols_merge_pattern = "{conf.low}:::{conf.high}") + Condition + Error in `modify_table_styling()`: + ! A single column must be specified in the `columns` argument when using `cols_merge_pattern`, and that column must be the first to appear in the pattern argument. + i For example, `modify_table_styling(columns="conf.low", cols_merge_pattern="{conf.low}:::{conf.high}")` + +--- + + Code + modify_table_styling(tbl_regression(lm(mpg ~ factor(am), mtcars)), columns = "conf.low", + rows = !is.na(conf.low), cols_merge_pattern = "{conf.low}:::{not_in_table}") + Condition + Error in `modify_table_styling()`: + ! All columns specified in `cols_merge_pattern` argument must be present in `x$table_body` + i The following columns are not present: "not_in_table" + +# modify_table_styling(indentation) messaging + + Code + modify_table_styling(tbl_summary(trial, include = grade), columns = "label", + rows = !row_type %in% "label", indentation = "not an integer") + Condition + Error in `modify_table_styling()`: + ! The `indentation` argument must be a scalar integer. + +# modify_table_styling(rows) messaging + + Code + modify_table_styling(tbl_summary(trial, include = grade), columns = "label", + rows = "not_a_predicate", indentation = 8L) + Condition + Error in `modify_table_styling()`: + ! The `rows` argument must be an expression that evaluates to a logical vector in `x$table_body`. + diff --git a/tests/testthat/test-modify_table_styling.R b/tests/testthat/test-modify_table_styling.R new file mode 100644 index 0000000000..c2aea14c8e --- /dev/null +++ b/tests/testthat/test-modify_table_styling.R @@ -0,0 +1,396 @@ +# starting with checks of the deprecation +test_that("modify_table_styling(undo_text_format=logical()) deprecation", { + withr::local_options(lifecycle_verbosity = "quiet") + lifecycle::expect_deprecated( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + text_format = "indent", + undo_text_format = TRUE + ) + ) + + expect_equal( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + text_format = "indent", + undo_text_format = TRUE + ) |> + getElement("table_styling") |> + getElement("indentation"), + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + indentation = 0L + ) |> + getElement("table_styling") |> + getElement("indentation") + ) +}) + +test_that("modify_table_styling(text_format=c('indent', 'indent2')) deprecation", { + withr::local_options(lifecycle_verbosity = "quiet") + lifecycle::expect_deprecated( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + text_format = "indent" + ) + ) + + expect_equal( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + text_format = "indent" + ) |> + getElement("table_styling") |> + getElement("indentation"), + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = "label", + indentation = 4L + ) |> + getElement("table_styling") |> + getElement("indentation") + ) +}) + +test_that("modify_table_styling(rows)", { + # works with objects defined outside of the expression + footnote_variable <- "age" + expect_error( + tbl_summary(trial[c("trt", "age")]) %>% + modify_table_styling( + columns = label, + footnote = "test footnote", + rows = variable == footnote_variable + ), + NA + ) +}) + + + +test_that("modify_table_styling(label)", { + expect_equal( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = stat_0, + label = "**Overall**" + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column == "stat_0") |> + dplyr::pull(label), + "**Overall**" + ) + + expect_equal( + mtcars |> + tbl_summary(include = mpg) |> + modify_table_styling( + columns = c(label, stat_0), + label = c("**Variable**", "**Overall**") + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull(label), + c("**Variable**", "**Overall**") + ) +}) + +test_that("modify_table_styling(spanning_header)", { + expect_equal( + trial |> + tbl_summary(include = age, by = trt) |> + modify_table_styling( + columns = all_stat_cols(), + spanning_header = "**Treatment Assignment**" + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull(spanning_header), + c("**Treatment Assignment**", "**Treatment Assignment**") + ) +}) + +test_that("modify_table_styling(hide)", { + expect_equal( + trial |> + tbl_summary(include = age, missing = "no") |> + modify_table_styling( + columns = variable, + hide = FALSE + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column == "variable") |> + dplyr::pull(hide), + FALSE + ) +}) + +test_that("modify_table_styling(footnote)", { + expect_equal( + trial |> + tbl_summary(include = age, missing = "no") |> + modify_table_styling( + columns = all_stat_cols(), + footnote = "testing footnote" + ) |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::filter(column == "stat_0") |> + dplyr::slice_tail(n = 1L) |> + dplyr::pull(footnote), + "testing footnote" + ) +}) + +test_that("modify_table_styling(footnote_abbrev)", { + expect_equal( + trial |> + tbl_summary(include = age, missing = "no") |> + modify_table_styling( + columns = all_stat_cols(), + footnote_abbrev = "testing footnote_abbrev" + ) |> + getElement("table_styling") |> + getElement("footnote_abbrev") |> + dplyr::filter(column == "stat_0") |> + dplyr::slice_tail(n = 1L) |> + dplyr::pull(footnote), + "testing footnote_abbrev" + ) +}) + +test_that("modify_table_styling(align)", { + expect_equal( + lapply( + c("left", "right", "center"), + function(x) { + trial |> + tbl_summary(include = age, missing = "no") |> + modify_table_styling( + columns = label, + align = x + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column == "label") |> + dplyr::pull(align) + } + ) |> + unlist(), + c("left", "right", "center") + ) +}) + +test_that("modify_table_styling(missing_symbol)", { + expect_equal( + trial |> + tbl_summary(include = age, missing = "no") |> + modify_table_styling( + columns = all_stat_cols(), + missing_symbol = "THIS IS NA" + ) |> + getElement("table_styling") |> + getElement("fmt_missing") |> + dplyr::filter(column == "stat_0") |> + dplyr::slice_tail(n = 1L) |> + dplyr::pull(symbol), + "THIS IS NA" + ) +}) + +test_that("modify_table_styling(fmt_fun)", { + expect_equal( + lm(mpg ~ am, mtcars) |> + tbl_regression() |> + modify_table_styling( + columns = c("estimate", "conf.low", "conf.high", "p.value"), + fmt_fun = list(styfn_sigfig(digits = 1), styfn_sigfig(digits = 2), styfn_sigfig(digits = 4), styfn_pvalue(digits = 3)) + ) |> + getElement("table_styling") |> + getElement("fmt_fun") |> + dplyr::filter(.by = column, dplyr::n() == dplyr::row_number()) |> + dplyr::filter(column %in% c("estimate", "conf.low", "conf.high", "p.value")) |> + dplyr::pull(fmt_fun), + list(styfn_sigfig(digits = 1), styfn_sigfig(digits = 2), styfn_sigfig(digits = 4), styfn_pvalue(digits = 3)) + ) +}) + +test_that("modify_table_styling(text_format)", { + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + rows = row_type %in% "label", + text_format = "bold" + ) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(column == "label", undo_text_format == FALSE) |> + dplyr::pull(format_type), + "bold" + ) +}) + +test_that("modify_table_styling(undo_text_format)", { + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + rows = row_type %in% "label", + undo_text_format = "bold" + ) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(column == "label", undo_text_format == TRUE) |> + dplyr::pull(format_type), + "bold" + ) +}) + +test_that("modify_table_styling(indentation)", { + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + rows = !row_type %in% "label", + indentation = 8L + ) |> + getElement("table_styling") |> + getElement("indentation") |> + dplyr::filter(.by = "column", column == "label", dplyr::n() == dplyr::row_number()) |> + dplyr::pull(n_spaces), + 8L + ) +}) + +test_that("modify_table_styling(text_interpret)", { + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + label = "header", + text_interpret = "html" + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column == "label") |> + dplyr::pull(interpret_label), + "gt::html" + ) + + expect_equal( + trial |> + tbl_summary(include = grade, by = trt) |> + modify_table_styling( + columns = all_stat_cols(), + spanning_header = "my big header", + text_interpret = "html" + ) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull(spanning_header), + c("my big header", "my big header") + ) +}) + +test_that("modify_table_styling(cols_merge_pattern)", { + expect_equal( + lm(mpg ~ factor(am), mtcars) |> + tbl_regression() |> + modify_table_styling( + columns = "conf.low", + rows = !is.na(conf.low), + cols_merge_pattern = "{conf.low}:::{conf.high}" + ) |> + getElement("table_styling") |> + getElement("cols_merge") |> + dplyr::filter(.by = "column", column == "conf.low", dplyr::n() == dplyr::row_number()) |> + dplyr::pull(pattern), + "{conf.low}:::{conf.high}" + ) + + # test we can undo merging + expect_equal( + lm(mpg ~ factor(am), mtcars) |> + tbl_regression() |> + modify_table_styling( + columns = conf.low, + cols_merge_pattern = NA_character_ + ) |> + modify_column_unhide(c("conf.low", "conf.high")) |> + as.data.frame(col_label = FALSE) |> + names(), + c("label", "estimate", "conf.low", "conf.high", "p.value") + ) +}) + +test_that("modify_table_styling(cols_merge_pattern) messaging", { + expect_snapshot( + error = TRUE, + lm(mpg ~ factor(am), mtcars) |> + tbl_regression() |> + modify_table_styling( + columns = "label", + rows = !is.na(conf.low), + cols_merge_pattern = "{conf.low}:::{conf.high}" + ) + ) + + expect_snapshot( + error = TRUE, + lm(mpg ~ factor(am), mtcars) |> + tbl_regression() |> + modify_table_styling( + columns = "conf.low", + rows = !is.na(conf.low), + cols_merge_pattern = "{conf.low}:::{not_in_table}" + ) + ) +}) + +test_that("modify_table_styling(indentation) messaging", { + expect_snapshot( + error = TRUE, + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + rows = !row_type %in% "label", + indentation = "not an integer" + ) + ) +}) + +test_that("modify_table_styling(rows) messaging", { + expect_snapshot( + error = TRUE, + trial |> + tbl_summary(include = grade) |> + modify_table_styling( + columns = "label", + rows = "not_a_predicate", + indentation = 8L + ) + ) +}) From ffb9b02b11cdf16c11ae9e53b26f90d16eb7b065 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sun, 19 May 2024 09:07:56 -0700 Subject: [PATCH 68/74] progress (#1673) --- R/modify_table_body.R | 32 ++++++++++++++++------ man/modify_column_hide.Rd | 1 - man/modify_column_merge.Rd | 1 - man/modify_fmt_fun.Rd | 1 - man/modify_table_body.Rd | 27 +++++++++--------- man/modify_table_styling.Rd | 3 +- tests/testthat/_snaps/modify_table_body.md | 25 +++++++++++++++++ tests/testthat/test-modify_table_body.R | 20 ++++++++++++++ 8 files changed, 82 insertions(+), 28 deletions(-) create mode 100644 tests/testthat/_snaps/modify_table_body.md create mode 100644 tests/testthat/test-modify_table_body.R diff --git a/R/modify_table_body.R b/R/modify_table_body.R index dad5a3fcfb..17cd6ee187 100644 --- a/R/modify_table_body.R +++ b/R/modify_table_body.R @@ -7,18 +7,23 @@ #' #' If a new column is added to the table, default printing instructions will then #' be added to `.$table_styling`. By default, columns are hidden. -#' To show a column, add a column header with `modify_header()`. +#' To show a column, add a column header with `modify_header()` or call +#' `modify_column_unhide()`. #' -#' @param x gtsummary object -#' @param fun A function or formula. If a _function_, it is used as is. -#' If a _formula_, e.g. `fun = ~ .x %>% arrange(variable)`, -#' it is converted to a function. The argument passed to `fun=` is `x$table_body`. -#' @param ... Additional arguments passed on to the mapped function +#' @param x (`gtsummary`)\cr +#' A 'gtsummary' object +#' @param fun (`function`)\cr +#' A function or formula. If a _function_, it is used as is. +#' If a _formula_, e.g. `fun = ~ .x |> arrange(variable)`, +#' it is converted to a function. The argument passed to `fun` is `x$table_body`. +#' @param ... Additional arguments passed on to the function #' #' @export +#' @return A 'gtsummary' object #' #' @examples #' # Example 1 -------------------------------- +#' # TODO: Re-add example when tbl_uvregression() is added #' # # Add number of cases and controls to regression table #' # modify_table_body_ex1 <- #' # trial %>% @@ -39,15 +44,24 @@ #' # # assigning header labels #' # modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") %>% #' # modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) -#' @export -#' @family Advanced modifiers modify_table_body <- function(x, fun, ...) { set_cli_abort_call() check_class(x, "gtsummary") + check_class(fun, c("function", "formula")) updated_call_list <- c(x$call_list, list(modify_table_body = match.call())) # execute function on x$table_body ------------------------------------------- - x$table_body <- map(.x = list(x$table_body), .f = fun, ...)[[1]] + x$table_body <- + tryCatch( + map(.x = list(x$table_body), .f = fun, ...)[[1]], + error = \(e) { + cli::cli_abort( + c("The following error occured while executing {.arg fun} on {.code x$table_body}:", + "x" = conditionMessage(e)), + call = get_cli_abort_call() + ) + } + ) # update table_styling ------------------------------------------------------- x <- .update_table_styling(x) diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index b9809b48f9..57db86f220 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -26,7 +26,6 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_merge}()}, \code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd index 6d1ec538b2..9660494b5c 100644 --- a/man/modify_column_merge.Rd +++ b/man/modify_column_merge.Rd @@ -76,7 +76,6 @@ modify_column_merge_ex1 <- Other Advanced modifiers: \code{\link{modify_column_hide}()}, \code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index 3a3db7161c..195f7f42bd 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -48,7 +48,6 @@ Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsumm Other Advanced modifiers: \code{\link{modify_column_hide}()}, \code{\link{modify_column_merge}()}, -\code{\link{modify_table_body}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_table_body.Rd b/man/modify_table_body.Rd index 816f3f5ba2..5c3d6a6e3b 100644 --- a/man/modify_table_body.Rd +++ b/man/modify_table_body.Rd @@ -7,13 +7,18 @@ modify_table_body(x, fun, ...) } \arguments{ -\item{x}{gtsummary object} +\item{x}{(\code{gtsummary})\cr +A 'gtsummary' object} -\item{fun}{A function or formula. If a \emph{function}, it is used as is. -If a \emph{formula}, e.g. \code{fun = ~ .x \%>\% arrange(variable)}, -it is converted to a function. The argument passed to \verb{fun=} is \code{x$table_body}.} +\item{fun}{(\code{function})\cr +A function or formula. If a \emph{function}, it is used as is. +If a \emph{formula}, e.g. \code{fun = ~ .x |> arrange(variable)}, +it is converted to a function. The argument passed to \code{fun} is \code{x$table_body}.} -\item{...}{Additional arguments passed on to the mapped function} +\item{...}{Additional arguments passed on to the function} +} +\value{ +A 'gtsummary' object } \description{ Function is for advanced manipulation of gtsummary tables. @@ -22,10 +27,12 @@ in each gtsummary object. If a new column is added to the table, default printing instructions will then be added to \code{.$table_styling}. By default, columns are hidden. -To show a column, add a column header with \code{modify_header()}. +To show a column, add a column header with \code{modify_header()} or call +\code{modify_column_unhide()}. } \examples{ # Example 1 -------------------------------- +# TODO: Re-add example when tbl_uvregression() is added # # Add number of cases and controls to regression table # modify_table_body_ex1 <- # trial \%>\% @@ -47,11 +54,3 @@ To show a column, add a column header with \code{modify_header()}. # modify_header(N_nonevent = "**Control N**", N_event = "**Case N**") \%>\% # modify_fmt_fun(c(N_event, N_nonevent) ~ style_number) } -\seealso{ -Other Advanced modifiers: -\code{\link{modify_column_hide}()}, -\code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_styling}()} -} -\concept{Advanced modifiers} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index c6223ac318..3085f8c8e7 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -135,7 +135,6 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition Other Advanced modifiers: \code{\link{modify_column_hide}()}, \code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_body}()} +\code{\link{modify_fmt_fun}()} } \concept{Advanced modifiers} diff --git a/tests/testthat/_snaps/modify_table_body.md b/tests/testthat/_snaps/modify_table_body.md new file mode 100644 index 0000000000..6bfe251980 --- /dev/null +++ b/tests/testthat/_snaps/modify_table_body.md @@ -0,0 +1,25 @@ +# modify_table_body() works + + Code + as.data.frame(modify_header(modify_table_body(modify_table_body( + modify_column_hide(tbl_regression(glm(response ~ trt + marker, trial, family = binomial)), + c("conf.low", "conf.high")), ~ dplyr::mutate(.x, n_nonevent = N - nevent)), + dplyr::relocate, nevent, n_nonevent, .after = label), n_nonevent = "**Control N**", + nevent = "**Case N**")) + Output + **Characteristic** **Case N** **Control N** **log(OR)** **p-value** + 1 Chemotherapy Treatment 57.0 126 + 2 Drug A 57.0 126 + 3 Drug B 57.0 126 0.34 0.3 + 4 Marker Level (ng/mL) 57.0 126 0.32 0.080 + +# modify_table_body() messaging + + Code + modify_table_body(tbl_summary(trial, include = marker), ~ stop( + "I made an error.")) + Condition + Error in `modify_table_body()`: + ! The following error occured while executing `fun` on `x$table_body`: + x I made an error. + diff --git a/tests/testthat/test-modify_table_body.R b/tests/testthat/test-modify_table_body.R new file mode 100644 index 0000000000..a47721286a --- /dev/null +++ b/tests/testthat/test-modify_table_body.R @@ -0,0 +1,20 @@ +test_that("modify_table_body() works", { + expect_snapshot( + glm(response ~ trt + marker, trial, family = binomial) |> + tbl_regression() |> + modify_column_hide(c("conf.low", "conf.high")) |> + # adding number of non-events to table + modify_table_body(~.x |> dplyr::mutate(n_nonevent = N - nevent)) |> + modify_table_body(dplyr::relocate, nevent, n_nonevent, .after = label) |> + modify_header(n_nonevent = "**Control N**", nevent = "**Case N**") |> + as.data.frame() + ) +}) + +test_that("modify_table_body() messaging", { + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = marker) |> + modify_table_body(~stop("I made an error.")) + ) +}) From 3de9bf7a230ad98f13cf74bf7fc1fa984eabe898 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 20 May 2024 08:27:49 -0700 Subject: [PATCH 69/74] v2.0 `modify_header()`, `modify_spanning_header()`, `modify_footnote()`, `modify_caption()` (#1676) * progress * progress * Create test-modify_spanning_header.R --- NAMESPACE | 3 + NEWS.md | 4 + R/as_gt.R | 5 +- R/modify.R | 289 +++++++++++++++++++ R/modify_caption.R | 46 +++ R/modify_header.R | 176 ----------- R/modify_table_styling.R | 2 +- R/tbl_summary.R | 2 +- man/modify.Rd | 124 ++++---- man/modify_caption.Rd | 36 +++ man/tbl_summary.Rd | 5 +- pkgdown/_pkgdown.yml | 1 + tests/testthat/_snaps/modify_footnote.md | 8 + tests/testthat/_snaps/modify_header.md | 8 + tests/testthat/test-modify_caption.R | 10 + tests/testthat/test-modify_footnote.R | 148 ++++++++++ tests/testthat/test-modify_header.R | 124 ++++++++ tests/testthat/test-modify_spanning_header.R | 134 +++++++++ 18 files changed, 872 insertions(+), 253 deletions(-) create mode 100644 R/modify.R create mode 100644 R/modify_caption.R delete mode 100644 R/modify_header.R create mode 100644 man/modify_caption.Rd create mode 100644 tests/testthat/_snaps/modify_footnote.md create mode 100644 tests/testthat/_snaps/modify_header.md create mode 100644 tests/testthat/test-modify_caption.R create mode 100644 tests/testthat/test-modify_footnote.R create mode 100644 tests/testthat/test-modify_header.R create mode 100644 tests/testthat/test-modify_spanning_header.R diff --git a/NAMESPACE b/NAMESPACE index d5cc098d63..2e23654ddc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,11 +42,14 @@ export(ends_with) export(everything) export(last_col) export(matches) +export(modify_caption) export(modify_column_hide) export(modify_column_merge) export(modify_column_unhide) export(modify_fmt_fun) +export(modify_footnote) export(modify_header) +export(modify_spanning_header) export(modify_table_body) export(modify_table_styling) export(mutate) diff --git a/NEWS.md b/NEWS.md index 508a239f87..7fbaa20672 100644 --- a/NEWS.md +++ b/NEWS.md @@ -44,6 +44,10 @@ ### Deprecations +* Arguments `modify_header(quiet)`, `modify_footnote(quiet)`, and `modify_spanning_header(quiet)` have been deprecated. Verbose messaging is no longer available. + +* Arguments `modify_header(update)`, `modify_footnote(update)`, and `modify_spanning_header(update)` have been deprecated. Use dynamic dots instead, e.g. `modify_header(...)` + * Arguments `add_stat(fmt_fun, header, footnote, new_col_name)` have been deprecated since v1.4.0 (2021-04-13). They have now been fully removed from the package. * Global options have been deprecated in gtsummary since v1.3.1 (2020-06-02). They have now been fully removed from the package. diff --git a/R/as_gt.R b/R/as_gt.R index 5506a9cdb0..6120f54844 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -87,8 +87,9 @@ table_styling_to_gt_calls <- function(x, ...) { caption <- switch(!is.null(x$table_styling$caption), rlang::call2( - attr(x$table_styling$caption, "text_interpret"), - x$table_styling$caption + .fn = attr(x$table_styling$caption, "text_interpret"), + x$table_styling$caption, + .ns = "gt" ) ) gt_calls[["gt"]] <- diff --git a/R/modify.R b/R/modify.R new file mode 100644 index 0000000000..1d2afd727e --- /dev/null +++ b/R/modify.R @@ -0,0 +1,289 @@ +#' Modify column headers, footnotes, and spanning headers +#' +#' @description +#' These functions assist with modifying the aesthetics/style of a table. +#' +#' - `modify_header()` update column headers +#' - `modify_footnote()` update/add table footnotes +#' - `modify_spanning_header()` update/add spanning headers +#' +#' The functions often require users to know the underlying column names. +#' Run `show_header_names()` to print the column names to the console. +#' +#' @param x (`gtsummary`)\cr +#' A gtsummary object +#' @param ... [`dynamic-dots`][rlang::dyn-dots]\cr +#' Used to assign updates to headers, +#' spanning headers, and footnotes. +#' +#' Use `modify_*(colname='new header/footnote')` to update a single column. Using a +#' formula will invoke tidyselect, e.g. `modify_*(all_stat_cols() ~ "**{level}**")`. +#' The dynamic dots allow syntax like `modify_header(x, !!!list(label = "Variable"))`. +#' See examples below. +#' +#' Use the `show_header_names()` to see the column names that can be modified. +#' @param abbreviation (scalar `logical`)\cr +#' Logical indicating if an abbreviation is being updated. +#' @param text_interpret (`string`)\cr +#' String indicates whether text will be interpreted with +#' [`gt::md()`] or [`gt::html()`]. Must be `"md"` (default) or `"html"`. +# TODO: add this back when show function is added +# @param include_example (scalar `logical`)\cr +# Logical whether to include print of `modify_header()` example +#' @param update,quiet `r lifecycle::badge("deprecated")` +#' +#' @author Daniel D. Sjoberg +#' +#' @return Updated gtsummary object +#' @name modify +#' +#' @section `tbl_summary()`, `tbl_svysummary()`, and `tbl_cross()`: +#' When assigning column headers, footnotes, and spanning headers, +#' you may use `{N}` to insert the number of observations. +#' `tbl_svysummary` objects additionally have `{N_unweighted}` available. +#' +#' When there is a stratifying `by=` argument present, the following fields are +#' additionally available to stratifying columns: `{level}`, `{n}`, and `{p}` +#' (`{n_unweighted}` and `{p_unweighted}` for `tbl_svysummary` objects) +#' +#' Syntax follows [`glue::glue()`], e.g. `all_stat_cols() ~ "**{level}**, N = {n}"`. +#' @section tbl_regression(): +#' When assigning column headers for `tbl_regression` tables, +#' you may use `{N}` to insert the number of observations, and `{N_event}` +#' for the number of events (when applicable). +#' +#' @examples +#' # create summary table +#' tbl <- trial |> +#' tbl_summary(by = trt, missing = "no", include = c("age", "grade", "trt")) |> +#' add_p() +#' +#' # print the column names that can be modified +#' # TODO: Add this back in after function is added +#' # show_header_names(tbl) +#' +#' # Example 1 ---------------------------------- +#' # updating column headers and footnote +#' tbl |> +#' modify_header(label = "**Variable**", p.value = "**P**") |> +#' modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (%) for Grade") +#' +#' # Example 2 ---------------------------------- +#' # updating headers, remove all footnotes, add spanning header +#' tbl |> +#' modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}%)") |> +#' modify_footnote(everything() ~ NA) |> +#' modify_spanning_header(all_stat_cols() ~ "**Treatment Received**") +#' +#' # Example 3 ---------------------------------- +#' # updating an abbreviation in table footnote +#' glm(response ~ age + grade, trial, family = binomial) |> +#' tbl_regression(exponentiate = TRUE) |> +#' modify_footnote(conf.low = "CI = Credible Interval", abbreviation = TRUE) +NULL + +#' @name modify +#' @export +modify_header <- function(x, ..., text_interpret = c("md", "html"), + quiet, update) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(modify_footnote = match.call())) + + # checking inputs ------------------------------------------------------------ + check_class(x, "gtsummary") + text_interpret <- arg_match(text_interpret) + + # process inputs ------------------------------------------------------------- + dots <- dots_list(...) + dots <- + .deprecate_modify_update_and_quiet_args( + dots = dots, update = update, quiet = quiet, calling_fun = "modify_header" + ) + + + cards::process_formula_selectors(data = x$table_body, dots = dots) + cards::check_list_elements( + x = dots, + predicate = function(x) is_string(x), + error_msg = + c("All values passed in {.arg ...} must be strings.", + "i" = "For example, {.code label='**Variable**'}" + ) + ) + + # evaluate the strings with glue + dots <- .evaluate_string_with_glue(x, dots) + + # updated header meta data + x <- + modify_table_styling( + x = x, + columns = names(dots), + label = unlist(dots), + hide = FALSE, + text_interpret = text_interpret + ) + + # return object + x$call_list <- updated_call_list + x +} + +#' @name modify +#' @export +modify_footnote <- function(x, ..., abbreviation = FALSE, + text_interpret = c("md", "html"), + update, quiet) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(modify_footnote = match.call())) + + # checking inputs ------------------------------------------------------------ + check_class(x, "gtsummary") + text_interpret <- arg_match(text_interpret) + + # process inputs ------------------------------------------------------------- + dots <- rlang::dots_list(...) + dots <- .deprecate_modify_update_and_quiet_args(dots, update, quiet, calling_fun = "modify_footnote") + + # process arguments ---------------------------------------------------------- + text_interpret <- rlang::arg_match(text_interpret) + cards::process_formula_selectors(data = x$table_body, dots = dots) + cards::check_list_elements( + x = dots, + predicate = function(x) is_string(x) || is.na(x), + error_msg = + c("All values passed in {.arg ...} must be strings.", + "i" = "For example, {.code label='Results as of June 26, 2015'}" + ) + ) + + # evaluate the strings with glue + dots <- .evaluate_string_with_glue(x, dots) + + # updating footnotes --------------------------------------------------------- + x <- + if (!abbreviation) { + modify_table_styling( + x = x, + columns = names(dots), + footnote = unlist(dots), + text_interpret = text_interpret + ) + } else { + modify_table_styling( + x = x, + columns = names(dots), + footnote_abbrev = unlist(dots), + text_interpret = text_interpret + ) + } + + # returning gtsummary object ------------------------------------------------- + x$call_list <- updated_call_list + x +} + +#' @name modify +#' @export +modify_spanning_header <- function(x, ..., text_interpret = c("md", "html"), + quiet, update) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(modify_footnote = match.call())) + + # checking inputs ------------------------------------------------------------ + check_class(x, "gtsummary") + text_interpret <- arg_match(text_interpret) + + # process inputs ------------------------------------------------------------- + dots <- rlang::dots_list(...) + dots <- .deprecate_modify_update_and_quiet_args(dots, update, quiet, calling_fun = "modify_spanning_header") + + cards::process_formula_selectors(data = x$table_body, dots = dots) + cards::check_list_elements( + x = dots, + predicate = function(x) is_string(x) || is.na(x), + error_msg = + c("All values passed in {.arg ...} must be strings.", + "i" = "For example, {.code all_stat_cols() ~ '**Treatment**'}" + ) + ) + + # evaluate the strings with glue + dots <- .evaluate_string_with_glue(x, dots) + + # updated header meta data + x <- + modify_table_styling( + x = x, + columns = names(dots), + spanning_header = unlist(dots), + text_interpret = text_interpret + ) + + # return object + x$call_list <- updated_call_list + x +} + +.evaluate_string_with_glue <- function(x, dots) { + # only keep values that are in the table_body + dots <- dots[intersect(names(dots), x$table_styling$header$column)] + + df_header_subset <- + x$table_styling$header |> + dplyr::select("column", starts_with("modify_stat_")) |> + dplyr::rename_with( + .fn = function(x) gsub("^modify_stat_", "", x), + .cols = starts_with("modify_stat_") + ) + + imap( + dots, + function(value, variable) { + df_header_subset <- + df_header_subset |> + dplyr::filter(.data$column %in% .env$variable) |> + dplyr::select(-"column") + + glued_value <- + cards::eval_capture_conditions( + expr(glue::glue(value)), + data = df_header_subset + ) + + if (!is.null(glued_value$result)) { + return(glued_value$result) + } + + cli::cli_abort( + c("There was an error in the {.fun glue::glue} evaluation of {.val {value}} for column {.val {variable}}." + # TODO: Add this after we update `show_header_names()` to print info on the stats available for printing. + # i = "Run {.fun gtsummary::show_header_names} for information on values available for glue interpretation." + ), + call = get_cli_abort_call() + ) + } + ) +} + +.deprecate_modify_update_and_quiet_args <- function(dots, update, quiet, calling_fun) { + # deprecated arguments + if (!missing(update)) { + lifecycle::deprecate_warn( + "2.0.0", glue("gtsummary::{calling_fun}(update=)"), + details = + glue("Use `{calling_fun}(...)` input instead. + Dynamic dots allow for syntax like `{calling_fun}(!!!update)`."), + env = get_cli_abort_call() + ) + dots <- c(dots, update) + } + if (!missing(quiet)) { + lifecycle::deprecate_warn( + "2.0.0", glue("gtsummary::{calling_fun}(quiet=)"), + details = "Argument has been ignored." + ) + } + + dots +} diff --git a/R/modify_caption.R b/R/modify_caption.R new file mode 100644 index 0000000000..344d2857c7 --- /dev/null +++ b/R/modify_caption.R @@ -0,0 +1,46 @@ +#' Modify table caption +#' +#' @description +#' Captions are assigned based on output type. +#' - `gt::gt(caption=)` +#' - `flextable::set_caption(caption=)` +#' - `huxtable::set_caption(value=)` +#' - `knitr::kable(caption=)` +#' +#' @param x (`gtsummary`)\cr +#' A gtsummary object +#' @param caption (`string`)\cr +#' A string for the table caption/title +#' @inheritParams modify +#' +#' @export +#' @return Updated gtsummary object +#' +#' @examples +#' trial |> +#' tbl_summary(by = trt, include = c(marker, stage)) |> +#' modify_caption(caption = "**Baseline Characteristics** N = {N}") +modify_caption <- function(x, caption, text_interpret = c("md", "html")) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(modify_footnote = match.call())) + + # checking inputs ------------------------------------------------------------ + check_class(x, "gtsummary") + check_string(caption) + text_interpret <- arg_match(text_interpret) + + # evaluating update with glue ------------------------------------------------ + if ("label" %in% x$table_styling$header$column) { + caption <- .evaluate_string_with_glue(x, list(label = caption)) |> + unlist() |> + unname() + } + + # adding caption to gtsummary object ---------------------------------------- + x$table_styling$caption <- caption + attr(x$table_styling$caption, "text_interpret") <- text_interpret + + # returning updated object --------------------------------------------------- + x$call_list <- updated_call_list + x +} diff --git a/R/modify_header.R b/R/modify_header.R deleted file mode 100644 index 4722e0fd53..0000000000 --- a/R/modify_header.R +++ /dev/null @@ -1,176 +0,0 @@ -#' Modify column headers, footnotes, spanning headers, and table captions -#' -#' These functions assist with updating or adding column headers -#' (`modify_header()`), footnotes (`modify_footnote()`), spanning -#' headers (`modify_spanning_header()`), and table captions -#' (`modify_caption()`). Use `show_header_names()` to learn -#' the column names. -#' -#' @name modify -#' @param x a gtsummary object -#' @param update,... use these arguments to assign updates to headers, -#' spanning headers, and footnotes. See examples below. -#' - `update` expects a list of assignments, with the variable name or selector -#' on the LHS of the formula, and the updated string on the RHS. Also accepts -#' a named list. -#' - `...` pass individual updates outside of a list, e.g, -#' `modify_header(p.value = "**P**", all_stat_cols() ~ "**{level}**")` -#' -#' Use the `show_header_names()` to see the column names that can be modified. -# #' @param abbreviation Logical indicating if an abbreviation is being updated. -#' @param text_interpret String indicates whether text will be interpreted with -#' [gt::md()] or [gt::html()]. Must be `"md"` (default) or `"html"`. -# #' @param caption a string of the table caption/title -# #' @param include_example logical whether to include print of `modify_header()` example -#' @param quiet (scalar `logical`)\cr -#' When `TRUE`, additional messaging is not printed. -#' TODO: Set defaults here and theme control of argument -# #' @inheritParams modify_table_styling -#' @family tbl_summary tools -#' @family tbl_svysummary tools -#' @family tbl_regression tools -#' @family tbl_uvregression tools -#' @family tbl_survfit tools -#' @author Daniel D. Sjoberg -#' -#' @section tbl_summary(), tbl_svysummary(), and tbl_cross(): -#' When assigning column headers, footnotes, spanning headers, and captions -#' for these gtsummary tables, -#' you may use `{N}` to insert the number of observations. -#' `tbl_svysummary` objects additionally have `{N_unweighted}` available. -#' -#' When there is a stratifying `by=` argument present, the following fields are -#' additionally available to stratifying columns: `{level}`, `{n}`, and `{p}` -#' (`{n_unweighted}` and `{p_unweighted}` for `tbl_svysummary` objects) -#' -#' Syntax follows [glue::glue()], e.g. `all_stat_cols() ~ "**{level}**, N = {n}"`. -#' @section tbl_regression(): -#' When assigning column headers for `tbl_regression` tables, -#' you may use `{N}` to insert the number of observations, and `{N_event}` -#' for the number of events (when applicable). -#' -#' @section captions: -#' Captions are assigned based on output type. -#' - `gt::gt(caption=)` -#' - `flextable::set_caption(caption=)` -#' - `huxtable::set_caption(value=)` -#' - `knitr::kable(caption=)` -#' -#' @examplesIf FALSE -#' \donttest{ -#' # create summary table -#' tbl <- trial[c("age", "grade", "trt")] %>% -#' tbl_summary(by = trt, missing = "no") %>% -#' add_p() -#' -#' # print the column names that can be modified -#' show_header_names(tbl) -#' -#' # Example 1 ---------------------------------- -#' # updating column headers, footnote, and table caption -#' modify_ex1 <- tbl %>% -#' modify_header(label = "**Variable**", p.value = "**P**") %>% -#' modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (%) for Grade") %>% -#' modify_caption("**Patient Characteristics** (N = {N})") -#' -#' # Example 2 ---------------------------------- -#' # updating headers, remove all footnotes, add spanning header -#' modify_ex2 <- tbl %>% -#' modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}%)") %>% -#' # use `modify_footnote(everything() ~ NA, abbreviation = TRUE)` to delete abbrev. footnotes -#' modify_footnote(update = everything() ~ NA) %>% -#' modify_spanning_header(all_stat_cols() ~ "**Treatment Received**") -#' -#' # Example 3 ---------------------------------- -#' # updating an abbreviation in table footnote -#' modify_ex3 <- -#' glm(response ~ age + grade, trial, family = binomial) %>% -#' tbl_regression(exponentiate = TRUE) %>% -#' modify_footnote(ci = "CI = Credible Interval", abbreviation = TRUE) -#' } -#' @return Updated gtsummary object -NULL - -#' @name modify -#' @export -modify_header <- function(x, ..., text_interpret = c("md", "html"), - quiet = NULL, update = NULL) { - # process inputs ------------------------------------------------------------- - dots <- rlang::dots_list(...) - text_interpret <- rlang::arg_match(text_interpret) - - # deprecated arguments - if (!is.null(update)) { - lifecycle::deprecate_warn( - "2.0.0", "gtsummary::modify_header(update=)", - details = "Use `modify_header(...)` input instead." - ) - if (is.factor(dots)) { - dots <- c(list(dots), update) - } else { - dots <- c(list(dots), update) - } - } - - cards::process_formula_selectors(data = x$table_body, dots = dots) - cards::check_list_elements( - x = dots, - predicate = function(x) is_string(x), - error_msg = - c("All values passed in {.arg ...} must be strings.", - "i" = "For example, {.code label = '**Variable**'}" - ) - ) - - # evaluate the strings with glue - dots <- .evaluate_string_with_glue(x, dots) - - # updated header meta data - x$table_styling$header <- - x$table_styling$header |> - dplyr::mutate( - hide = ifelse(.data$column %in% names(dots), FALSE, .data$hide) - ) |> - dplyr::rows_update( - tibble::enframe(unlist(dots), name = "column", value = "label"), - by = "column" - ) - - # return object - x -} - -.evaluate_string_with_glue <- function(x, dots) { - # only keep values that are in the table_body - dots <- dots[intersect(names(dots), x$table_styling$header$column)] - - df_header_subset <- - x$table_styling$header |> - dplyr::select("column", starts_with("modify_stat_")) |> - dplyr::rename_with( - .fn = function(x) gsub("^modify_stat_", "", x), - .cols = starts_with("modify_stat_") - ) - - imap( - dots, - function(value, variable) { - df_header_subset <- - df_header_subset |> - dplyr::filter(.data$column %in% .env$variable) |> - dplyr::select(-"column") - - glued_value <- - cards::eval_capture_conditions( - expr(glue::glue(value)), - data = df_header_subset - ) - - if (!is.null(glued_value$result)) { - return(glued_value$result) - } - - cli::cli_abort("There was an error the {.fun glue::glue} evaluation of {.val {value}}.") - } - ) -} diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 4c81009bd9..c4dbfea7e1 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -210,7 +210,7 @@ modify_table_styling <- function(x, x$table_styling$header <- x$table_styling$header %>% dplyr::rows_update( - dplyr::tibble(column = columns, interpret_label = text_interpret, spanning_header = spanning_header), + dplyr::tibble(column = columns, interpret_spanning_header = text_interpret, spanning_header = spanning_header), by = "column" ) } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index e6b97b0f51..e5c58c2918 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -104,7 +104,7 @@ #' statistic, e.g. `list(sd = styfn_number(digits=1))`. #' #' @section type and value arguments: -#' There are four summary types: +#' There are four summary types. Use the `type` argument to change the default summary types. #' - `"continuous"` summaries are shown on a *single row*. Most numeric #' variables default to summary type continuous. #' - `"continuous2"` summaries are shown on *2 or more rows* diff --git a/man/modify.Rd b/man/modify.Rd index 4643a98215..ea6c6be6bd 100644 --- a/man/modify.Rd +++ b/man/modify.Rd @@ -1,54 +1,66 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/modify_header.R +% Please edit documentation in R/modify.R \name{modify} \alias{modify} \alias{modify_header} -\title{Modify column headers, footnotes, spanning headers, and table captions} +\alias{modify_footnote} +\alias{modify_spanning_header} +\title{Modify column headers, footnotes, and spanning headers} \usage{ -modify_header( +modify_header(x, ..., text_interpret = c("md", "html"), quiet, update) + +modify_footnote( x, ..., + abbreviation = FALSE, text_interpret = c("md", "html"), - quiet = NULL, - update = NULL + update, + quiet ) + +modify_spanning_header(x, ..., text_interpret = c("md", "html"), quiet, update) } \arguments{ -\item{x}{a gtsummary object} +\item{x}{(\code{gtsummary})\cr +A gtsummary object} -\item{text_interpret}{String indicates whether text will be interpreted with -\code{\link[gt:md]{gt::md()}} or \code{\link[gt:html]{gt::html()}}. Must be \code{"md"} (default) or \code{"html"}.} +\item{...}{\code{\link[rlang:dyn-dots]{dynamic-dots}}\cr +Used to assign updates to headers, +spanning headers, and footnotes. -\item{quiet}{(scalar \code{logical})\cr -When \code{TRUE}, additional messaging is not printed. -TODO: Set defaults here and theme control of argument} - -\item{update, ...}{use these arguments to assign updates to headers, -spanning headers, and footnotes. See examples below. -\itemize{ -\item \code{update} expects a list of assignments, with the variable name or selector -on the LHS of the formula, and the updated string on the RHS. Also accepts -a named list. -\item \code{...} pass individual updates outside of a list, e.g, -\code{modify_header(p.value = "**P**", all_stat_cols() ~ "**{level}**")} -} +Use \code{modify_*(colname='new header/footnote')} to update a single column. Using a +formula will invoke tidyselect, e.g. \code{modify_*(all_stat_cols() ~ "**{level}**")}. +The dynamic dots allow syntax like \code{modify_header(x, !!!list(label = "Variable"))}. +See examples below. Use the \code{show_header_names()} to see the column names that can be modified.} + +\item{text_interpret}{(\code{string})\cr +String indicates whether text will be interpreted with +\code{\link[gt:md]{gt::md()}} or \code{\link[gt:html]{gt::html()}}. Must be \code{"md"} (default) or \code{"html"}.} + +\item{update, quiet}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} + +\item{abbreviation}{(scalar \code{logical})\cr +Logical indicating if an abbreviation is being updated.} } \value{ Updated gtsummary object } \description{ -These functions assist with updating or adding column headers -(\code{modify_header()}), footnotes (\code{modify_footnote()}), spanning -headers (\code{modify_spanning_header()}), and table captions -(\code{modify_caption()}). Use \code{show_header_names()} to learn -the column names. +These functions assist with modifying the aesthetics/style of a table. +\itemize{ +\item \code{modify_header()} update column headers +\item \code{modify_footnote()} update/add table footnotes +\item \code{modify_spanning_header()} update/add spanning headers +} + +The functions often require users to know the underlying column names. +Run \code{show_header_names()} to print the column names to the console. } -\section{tbl_summary(), tbl_svysummary(), and tbl_cross()}{ +\section{\code{tbl_summary()}, \code{tbl_svysummary()}, and \code{tbl_cross()}}{ -When assigning column headers, footnotes, spanning headers, and captions -for these gtsummary tables, +When assigning column headers, footnotes, and spanning headers, you may use \code{{N}} to insert the number of observations. \code{tbl_svysummary} objects additionally have \code{{N_unweighted}} available. @@ -66,61 +78,35 @@ you may use \code{{N}} to insert the number of observations, and \code{{N_event} for the number of events (when applicable). } -\section{captions}{ - -Captions are assigned based on output type. -\itemize{ -\item \code{gt::gt(caption=)} -\item \code{flextable::set_caption(caption=)} -\item \code{huxtable::set_caption(value=)} -\item \code{knitr::kable(caption=)} -} -} - \examples{ -\dontshow{if (FALSE) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -\donttest{ # create summary table -tbl <- trial[c("age", "grade", "trt")] \%>\% - tbl_summary(by = trt, missing = "no") \%>\% +tbl <- trial |> + tbl_summary(by = trt, missing = "no", include = c("age", "grade", "trt")) |> add_p() # print the column names that can be modified -show_header_names(tbl) +# TODO: Add this back in after function is added +# show_header_names(tbl) # Example 1 ---------------------------------- -# updating column headers, footnote, and table caption -modify_ex1 <- tbl \%>\% - modify_header(label = "**Variable**", p.value = "**P**") \%>\% - modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (\%) for Grade") \%>\% - modify_caption("**Patient Characteristics** (N = {N})") +# updating column headers and footnote +tbl |> + modify_header(label = "**Variable**", p.value = "**P**") |> + modify_footnote(all_stat_cols() ~ "median (IQR) for Age; n (\%) for Grade") # Example 2 ---------------------------------- # updating headers, remove all footnotes, add spanning header -modify_ex2 <- tbl \%>\% - modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}\%)") \%>\% - # use `modify_footnote(everything() ~ NA, abbreviation = TRUE)` to delete abbrev. footnotes - modify_footnote(update = everything() ~ NA) \%>\% +tbl |> + modify_header(all_stat_cols() ~ "**{level}**, N = {n} ({style_percent(p)}\%)") |> + modify_footnote(everything() ~ NA) |> modify_spanning_header(all_stat_cols() ~ "**Treatment Received**") # Example 3 ---------------------------------- # updating an abbreviation in table footnote -modify_ex3 <- - glm(response ~ age + grade, trial, family = binomial) \%>\% - tbl_regression(exponentiate = TRUE) \%>\% - modify_footnote(ci = "CI = Credible Interval", abbreviation = TRUE) -} -\dontshow{\}) # examplesIf} -} -\seealso{ -Other tbl_summary tools: -\code{\link{tbl_summary}()} +glm(response ~ age + grade, trial, family = binomial) |> + tbl_regression(exponentiate = TRUE) |> + modify_footnote(conf.low = "CI = Credible Interval", abbreviation = TRUE) } \author{ Daniel D. Sjoberg } -\concept{tbl_regression tools} -\concept{tbl_summary tools} -\concept{tbl_survfit tools} -\concept{tbl_svysummary tools} -\concept{tbl_uvregression tools} diff --git a/man/modify_caption.Rd b/man/modify_caption.Rd new file mode 100644 index 0000000000..89da945f80 --- /dev/null +++ b/man/modify_caption.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_caption.R +\name{modify_caption} +\alias{modify_caption} +\title{Modify table caption} +\usage{ +modify_caption(x, caption, text_interpret = c("md", "html")) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +A gtsummary object} + +\item{caption}{(\code{string})\cr +A string for the table caption/title} + +\item{text_interpret}{(\code{string})\cr +String indicates whether text will be interpreted with +\code{\link[gt:md]{gt::md()}} or \code{\link[gt:html]{gt::html()}}. Must be \code{"md"} (default) or \code{"html"}.} +} +\value{ +Updated gtsummary object +} +\description{ +Captions are assigned based on output type. +\itemize{ +\item \code{gt::gt(caption=)} +\item \code{flextable::set_caption(caption=)} +\item \code{huxtable::set_caption(value=)} +\item \code{knitr::kable(caption=)} +} +} +\examples{ +trial |> + tbl_summary(by = trt, include = c(marker, stage)) |> + modify_caption(caption = "**Baseline Characteristics** N = {N}") +} diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index d9f46097b1..b48161b543 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -140,7 +140,7 @@ statistic, e.g. \code{list(sd = styfn_number(digits=1))}. \section{type and value arguments}{ -There are four summary types: +There are four summary types. Use the \code{type} argument to change the default summary types. \itemize{ \item \code{"continuous"} summaries are shown on a \emph{single row}. Most numeric variables default to summary type continuous. @@ -192,9 +192,6 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/tbl_summary.html}{tb See \href{https://www.danieldsjoberg.com/gtsummary/articles/gallery.html}{table gallery} for additional examples Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary - -Other tbl_summary tools: -\code{\link{modify}} } \author{ Daniel D. Sjoberg diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index becc913ec2..1ef036c0f6 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -146,6 +146,7 @@ reference: - subtitle: Style Summary Tables - contents: - modify + - modify_caption # - bold_italicize_labels_levels # - bold_p # - sort_filter_p diff --git a/tests/testthat/_snaps/modify_footnote.md b/tests/testthat/_snaps/modify_footnote.md new file mode 100644 index 0000000000..9adafa6716 --- /dev/null +++ b/tests/testthat/_snaps/modify_footnote.md @@ -0,0 +1,8 @@ +# modify_footnote(...) dynamic headers work with `tbl_summary()` + + Code + modify_footnote(tbl_summary(trial, include = marker), label = "This is not a valid {element}.") + Condition + Error in `modify_footnote()`: + ! There was an error in the `glue::glue()` evaluation of "This is not a valid {element}." for column "label". + diff --git a/tests/testthat/_snaps/modify_header.md b/tests/testthat/_snaps/modify_header.md new file mode 100644 index 0000000000..8d9b5a8153 --- /dev/null +++ b/tests/testthat/_snaps/modify_header.md @@ -0,0 +1,8 @@ +# modify_header(...) dynamic headers work with `tbl_summary()` + + Code + modify_header(tbl_summary(trial, include = marker), label = "This is not a valid {element}.") + Condition + Error in `modify_header()`: + ! There was an error in the `glue::glue()` evaluation of "This is not a valid {element}." for column "label". + diff --git a/tests/testthat/test-modify_caption.R b/tests/testthat/test-modify_caption.R new file mode 100644 index 0000000000..2482eed632 --- /dev/null +++ b/tests/testthat/test-modify_caption.R @@ -0,0 +1,10 @@ +test_that("modify_caption(caption) works", { + expect_equal( + tbl_summary(trial, include = marker) |> + modify_caption("**Adding a caption** N = {N}", text_interpret = "html") |> + getElement("table_styling") |> + getElement("caption"), + "**Adding a caption** N = 200" |> + structure(text_interpret = "html") + ) +}) diff --git a/tests/testthat/test-modify_footnote.R b/tests/testthat/test-modify_footnote.R new file mode 100644 index 0000000000..fd9ea9ac3b --- /dev/null +++ b/tests/testthat/test-modify_footnote.R @@ -0,0 +1,148 @@ + +# first, testing deprecation +test_that("modify_footnote(update,quiet) are deprecated", { + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_footnote(update = list(label = "Variable")) + ) + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_footnote(quiet = FALSE) + ) +}) + +test_that("modify_footnote(update) deprecated argument still works", { + withr::local_options(lifecycle_verbosity = "quiet") + expect_equal( + tbl_summary(trial, include = marker) |> + modify_footnote(update = list(label = "Variable")) %>% + {.[c("table_body", "table_styling")]}, + tbl_summary(trial, include = marker) |> + modify_footnote(label = "Variable") %>% + {.[c("table_body", "table_styling")]} + ) +}) + + +test_that("modify_footnote(...) works", { + tbl <- tbl_summary(trial, include = "marker") + + # typical use + expect_equal( + tbl |> + modify_footnote(label = "Variable") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::filter(column %in% "label") |> + dplyr::pull("footnote"), + "Variable", + ignore_attr = TRUE + ) + + expect_equal( + tbl |> + modify_footnote(label = "Variable", stat_0 = "Overall") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("footnote"), + c("Overall", "Variable"), + ignore_attr = TRUE + ) + + expect_equal( + tbl |> + modify_footnote(label = "Variable", stat_0 = "Overall", abbreviation = TRUE) |> + getElement("table_styling") |> + getElement("footnote_abbrev") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("footnote"), + c("Variable", "Overall"), + ignore_attr = TRUE + ) +}) + +# TODO: Add dynamic headers work with `tbl_svysummary()` +# TODO: Add dynamic headers work with `tbl_continuous()` +# TODO: Add dynamic headers work with `tbl_cross()` +# TODO: Add dynamic headers work with `tbl_regression()` +# TODO: Add dynamic headers work with `tbl_uvregression()` +test_that("modify_footnote(...) dynamic headers work with `tbl_summary()`", { + tbl <- tbl_summary(trial, include = "marker") + + # test dynamic dots + expect_equal( + tbl |> + modify_footnote(!!!list(label = "Variable", stat_0 = "Overall")) |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("footnote"), + c("Overall", "Variable"), + ignore_attr = TRUE + ) + + # testing dynamic entries in header + expect_equal( + tbl |> + modify_footnote(stat_0 = "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(column %in% "stat_0") |> + dplyr::pull("footnote"), + "Overall | N = 200 | n = 200 | p = 100%", + ignore_attr = TRUE + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("footnote"), + c("Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%"), + ignore_attr = TRUE + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + add_overall() |> + modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("footnote"), + c("Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%", + "Overall | N = 200 | n = 200 | p = 100%"), + ignore_attr = TRUE + ) + + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = marker) |> + modify_footnote(label = "This is not a valid {element}.") + ) +}) + +test_that("modify_footnote(text_interpret) works", { + expect_equal( + tbl_summary(trial, include = marker) |> + modify_footnote(label = "Variable", text_interpret = "html") |> + getElement("table_styling") |> + getElement("footnote") |> + dplyr::slice_tail(by = "column", n = 1) |> + dplyr::filter(column %in% "label") |> + dplyr::pull(text_interpret), + "gt::html" + ) +}) + diff --git a/tests/testthat/test-modify_header.R b/tests/testthat/test-modify_header.R new file mode 100644 index 0000000000..df6d73206d --- /dev/null +++ b/tests/testthat/test-modify_header.R @@ -0,0 +1,124 @@ + +# first, testing deprecation +test_that("modify_header(update,quiet) are deprecated", { + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_header(update = list(label = "Variable")) + ) + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_header(quiet = FALSE) + ) +}) + +test_that("modify_header(update) deprecated argument still works", { + withr::local_options(lifecycle_verbosity = "quiet") + expect_equal( + tbl_summary(trial, include = marker) |> + modify_header(update = list(label = "Variable")) %>% + {.[c("table_body", "table_styling")]}, + tbl_summary(trial, include = marker) |> + modify_header(label = "Variable") %>% + {.[c("table_body", "table_styling")]} + ) +}) + + +test_that("modify_header(...) works", { + tbl <- tbl_summary(trial, include = "marker") + + # typical use + expect_equal( + tbl |> + modify_header(label = "Variable") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "label") |> + dplyr::pull("label"), + "Variable" + ) + + expect_equal( + tbl |> + modify_header(label = "Variable", stat_0 = "Overall") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("label"), + c("Variable", "Overall") + ) +}) + +# TODO: Add dynamic headers work with `tbl_svysummary()` +# TODO: Add dynamic headers work with `tbl_continuous()` +# TODO: Add dynamic headers work with `tbl_cross()` +# TODO: Add dynamic headers work with `tbl_regression()` +# TODO: Add dynamic headers work with `tbl_uvregression()` +test_that("modify_header(...) dynamic headers work with `tbl_summary()`", { + tbl <- tbl_summary(trial, include = "marker") + + # test dynamic dots + expect_equal( + tbl |> + modify_header(!!!list(label = "Variable", stat_0 = "Overall")) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("label"), + c("Variable", "Overall") + ) + + # testing dynamic entries in header + expect_equal( + tbl |> + modify_header(stat_0 = "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "stat_0") |> + dplyr::pull("label"), + "Overall | N = 200 | n = 200 | p = 100%" + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("label"), + c("Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%") + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + add_overall() |> + modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("label"), + c("Overall | N = 200 | n = 200 | p = 100%", + "Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%") + ) + + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = marker) |> + modify_header(label = "This is not a valid {element}.") + ) +}) + +test_that("modify_header(text_interpret) works", { + expect_equal( + tbl_summary(trial, include = marker) |> + modify_header(label = "Variable", text_interpret = "html") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "label") |> + dplyr::pull(interpret_label), + "gt::html" + ) +}) + diff --git a/tests/testthat/test-modify_spanning_header.R b/tests/testthat/test-modify_spanning_header.R new file mode 100644 index 0000000000..517e7c0d80 --- /dev/null +++ b/tests/testthat/test-modify_spanning_header.R @@ -0,0 +1,134 @@ + +# first, testing deprecation +test_that("modify_spanning_header(update,quiet) are deprecated", { + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_spanning_header(update = list(label = "Variable")) + ) + lifecycle::expect_deprecated( + tbl_summary(trial, include = marker) |> + modify_spanning_header(quiet = FALSE) + ) +}) + +test_that("modify_spanning_header(update) deprecated argument still works", { + withr::local_options(lifecycle_verbosity = "quiet") + expect_equal( + tbl_summary(trial, include = marker) |> + modify_spanning_header(update = list(label = "Variable")) %>% + {.[c("table_body", "table_styling")]}, + tbl_summary(trial, include = marker) |> + modify_spanning_header(label = "Variable") %>% + {.[c("table_body", "table_styling")]} + ) +}) + + +test_that("modify_spanning_header(...) works", { + tbl <- tbl_summary(trial, include = "marker") + + # typical use + expect_equal( + tbl |> + modify_spanning_header(label = "Variable") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "label") |> + dplyr::pull("spanning_header"), + "Variable" + ) + + expect_equal( + tbl |> + modify_spanning_header(label = "Variable", stat_0 = "Overall") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("spanning_header"), + c("Variable", "Overall") + ) + + expect_equal( + tbl |> + modify_spanning_header(c(label, stat_0) ~ "Variable") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("spanning_header"), + c("Variable", "Variable") + ) +}) + +# TODO: Add dynamic headers work with `tbl_svysummary()` +# TODO: Add dynamic headers work with `tbl_continuous()` +# TODO: Add dynamic headers work with `tbl_cross()` +# TODO: Add dynamic headers work with `tbl_regression()` +# TODO: Add dynamic headers work with `tbl_uvregression()` +test_that("modify_spanning_header(...) dynamic headers work with `tbl_summary()`", { + tbl <- tbl_summary(trial, include = "marker") + + # test dynamic dots + expect_equal( + tbl |> + modify_spanning_header(!!!list(label = "Variable", stat_0 = "Overall")) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% c("label", "stat_0")) |> + dplyr::pull("spanning_header"), + c("Variable", "Overall") + ) + + # testing dynamic entries in header + expect_equal( + tbl |> + modify_spanning_header(stat_0 = "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "stat_0") |> + dplyr::pull("spanning_header"), + "Overall | N = 200 | n = 200 | p = 100%" + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + modify_spanning_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("spanning_header"), + c("Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%") + ) + + expect_equal( + tbl_summary(trial, by = trt, include = marker) |> + add_overall() |> + modify_spanning_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(startsWith(column, "stat_")) |> + dplyr::pull("spanning_header"), + c("Overall | N = 200 | n = 200 | p = 100%", + "Drug A | N = 200 | n = 98 | p = 49%", + "Drug B | N = 200 | n = 102 | p = 51%") + ) + + expect_snapshot( + error = TRUE, + tbl_summary(trial, include = marker) |> + modify_spanning_header(label = "This is not a valid {element}.") + ) +}) + +test_that("modify_spanning_header(text_interpret) works", { + expect_equal( + tbl_summary(trial, include = marker) |> + modify_spanning_header(label = "Variable", text_interpret = "html") |> + getElement("table_styling") |> + getElement("header") |> + dplyr::filter(column %in% "label") |> + dplyr::pull(interpret_spanning_header), + "gt::html" + ) +}) + From c3b0bc1e592d2ec62028dc39b775f48b6bec695a Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 20 May 2024 12:11:55 -0700 Subject: [PATCH 70/74] progress (#1677) --- NAMESPACE | 1 + NEWS.md | 6 +++ R/deprecated.R | 44 ++++++++++++++++++++ R/modify_column_merge.R | 31 +++++++------- man/deprecated.Rd | 15 +++++++ man/modify_column_merge.Rd | 11 ++++- tests/testthat/_snaps/modify_column_merge.md | 10 +++++ tests/testthat/test-modify_column_merge.R | 41 ++++++++++++++++++ 8 files changed, 143 insertions(+), 16 deletions(-) create mode 100644 R/deprecated.R create mode 100644 man/deprecated.Rd create mode 100644 tests/testthat/_snaps/modify_column_merge.md create mode 100644 tests/testthat/test-modify_column_merge.R diff --git a/NAMESPACE b/NAMESPACE index 2e23654ddc..f2c0f817e4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,6 +43,7 @@ export(everything) export(last_col) export(matches) export(modify_caption) +export(modify_cols_merge) export(modify_column_hide) export(modify_column_merge) export(modify_column_unhide) diff --git a/NEWS.md b/NEWS.md index 7fbaa20672..3d3870b731 100644 --- a/NEWS.md +++ b/NEWS.md @@ -56,6 +56,12 @@ * Use of the `vars()` selector was first removed in v1.2.5 (2020-02-11), and the messaging about the deprecation was kicked up in June 2022. This use is now defunct and the function will soon no longer be exported. +* The `as_flextable()` function was deprecated in v1.3.3 (2020-08-11), and has now been fully removed from the package. + +* Custom selectors `all_numeric()`, `all_character()`, `all_integer()`, `all_double()`, `all_logical()`, `all_factor()` functions were deprecated in v1.3.6 (2021-01-08), and has now been fully removed from the package. These functions were added before the `tidyselect::where()` function was released, which is a replacement for all these functions. + +* The `modify_cols_merge()` functions was renamed to `modify_column_merge()` to match the other function names in v1.6.1 (2022-06-22). The deprecation has been upgraded from a warning to an error. + * The `add_p(test = ~'aov')` test is now deprecated as identical results can be obtained with `add_p(test = ~'oneway.test', test.args = ~list(var.equal = TRUE))`. * Previously, `add_p.tbl_summary()` would coerce various data types to classes compatible with some base R tests. For example, we would convert `difftime` classes to general numeric before passing to `wilcox.test()`. We have eliminated type- and class-specific handling in these functions and it is now left to the the user pass data compatible with the functions that calculate the p-values or to create a custom test that wraps `wilcox.test()` and performs the conversion. This change is effective immediately. diff --git a/R/deprecated.R b/R/deprecated.R new file mode 100644 index 0000000000..9ddd89760a --- /dev/null +++ b/R/deprecated.R @@ -0,0 +1,44 @@ +#' Deprecated functions +#' +#' \lifecycle{deprecated} +#' Some functions have been deprecated and are no longer being actively +#' supported. +#' +#' @name deprecated +#' @keywords internal +NULL + +# tentative deprecation schedule, `Sys.Date() - months(18)` +# "warn" for 18 months +# 2.0.0 TARGET 2024-07-01 TODO: Update this +# 1.7.2 2023-07-13 +# 1.7.1 2023-04-27 +# 1.7.0 2023-01-13 + + +# "stop" for 18 months, then delete from pkg, `Sys.Date() - months(36)` +# 1.6.3 2022-12-06 +# 1.6.2 2022-09-30 +# 1.6.1 2022-06-22 +# 1.6.0 2022-04-25 +# 1.5.2 2022-01-29 +# 1.5.1 2022-01-20 +# 1.5.0 2021-10-16 +# 1.4.2 2021-07-13 + + +# TODO: Delete these version and dates +# 1.4.1 2021-05-19 +# 1.4.0 2021-04-13 +# 1.3.7 2021-02-26 +# 1.3.6 2021-01-08 +# 1.3.5 2020-09-29 +# 1.3.4 2020-08-27 +# 1.3.3 2020-08-11 + +# v1.6.1 ---------------------------------------------------------- +#' @rdname deprecated +#' @export +modify_cols_merge <- function(...) { + lifecycle::deprecate_stop("1.6.1", "gtsummary::modify_cols_merge()", "modify_column_merge()") +} diff --git a/R/modify_column_merge.R b/R/modify_column_merge.R index dfa404646e..46adfb16e7 100644 --- a/R/modify_column_merge.R +++ b/R/modify_column_merge.R @@ -42,23 +42,20 @@ #' @family Advanced modifiers #' @examplesIf gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx") #' # Example 1 ---------------------------------- -#' modify_column_merge_ex1 <- -#' trial |> +#' trial |> #' tbl_summary(by = trt, missing = "no", include = c(age, marker, trt)) |> #' add_p(all_continuous() ~ "t.test", pvalue_fun = styfn_pvalue(prepend_p = TRUE)) |> #' modify_fmt_fun(statistic ~ styfn_sigfig()) |> #' modify_column_merge(pattern = "t = {statistic}; {p.value}") |> #' modify_header(statistic = "**t-test**") #' -# #' # TODO: Re-add the second example after `tbl_regression()` is added -# #' # # Example 2 ---------------------------------- -# #' # modify_column_merge_ex2 <- -# #' # lm(marker ~ age + grade, trial) |> -# #' # tbl_regression() |> -# #' # modify_column_merge( -# #' # pattern = "{estimate} ({ci})", -# #' # rows = !is.na(estimate) -# #' # ) +#' # Example 2 ---------------------------------- +#' lm(marker ~ age + grade, trial) |> +#' tbl_regression() |> +#' modify_column_merge( +#' pattern = "{estimate} ({conf.low}, {conf.high})", +#' rows = !is.na(estimate) +#' ) modify_column_merge <- function(x, pattern, rows = NULL) { set_cli_abort_call() # check inputs --------------------------------------------------------------- @@ -71,7 +68,7 @@ modify_column_merge <- function(x, pattern, rows = NULL) { if (is_empty(columns)) { cli::cli_abort( c("No column names found in {.code modify_column_merge(pattern)} argument.", - i = "Wrap all column names in curly brackets, e.g {.code modify_column_merge(pattern = '{{conf.low}}, {{conf.high}}')}." + i = "Wrap column names in curly brackets, e.g {.code modify_column_merge(pattern = '{{conf.low}}, {{conf.high}}')}." ), call = get_cli_abort_call() ) @@ -88,9 +85,15 @@ modify_column_merge <- function(x, pattern, rows = NULL) { } # merge columns -------------------------------------------------------------- - x <- + x <- x |> + # remove prior merging for the specified columns + modify_table_styling( + columns = all_of(columns), + rows = {{ rows }}, + cols_merge_pattern = NA, + ) |> + # add the newly specified pattern of merging modify_table_styling( - x, columns = columns[1], rows = {{ rows }}, hide = FALSE, diff --git a/man/deprecated.Rd b/man/deprecated.Rd new file mode 100644 index 0000000000..b1abc9c949 --- /dev/null +++ b/man/deprecated.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/deprecated.R +\name{deprecated} +\alias{deprecated} +\alias{modify_cols_merge} +\title{Deprecated functions} +\usage{ +modify_cols_merge(...) +} +\description{ +\lifecycle{deprecated} +Some functions have been deprecated and are no longer being actively +supported. +} +\keyword{internal} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd index 9660494b5c..54798e255c 100644 --- a/man/modify_column_merge.Rd +++ b/man/modify_column_merge.Rd @@ -63,13 +63,20 @@ numeric columns numeric. For the \emph{vast majority} of users, \examples{ \dontshow{if (gtsummary:::is_pkg_installed("cardx", reference_pkg = "gtsummary") && gtsummary:::is_pkg_installed("broom", reference_pkg = "cardx")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Example 1 ---------------------------------- -modify_column_merge_ex1 <- - trial |> +trial |> tbl_summary(by = trt, missing = "no", include = c(age, marker, trt)) |> add_p(all_continuous() ~ "t.test", pvalue_fun = styfn_pvalue(prepend_p = TRUE)) |> modify_fmt_fun(statistic ~ styfn_sigfig()) |> modify_column_merge(pattern = "t = {statistic}; {p.value}") |> modify_header(statistic = "**t-test**") + +# Example 2 ---------------------------------- +lm(marker ~ age + grade, trial) |> + tbl_regression() |> + modify_column_merge( + pattern = "{estimate} ({conf.low}, {conf.high})", + rows = !is.na(estimate) + ) \dontshow{\}) # examplesIf} } \seealso{ diff --git a/tests/testthat/_snaps/modify_column_merge.md b/tests/testthat/_snaps/modify_column_merge.md new file mode 100644 index 0000000000..43e76f8fa3 --- /dev/null +++ b/tests/testthat/_snaps/modify_column_merge.md @@ -0,0 +1,10 @@ +# modify_column_merge() messaging + + Code + modify_column_merge(mod, pattern = "{not_a_column} ({conf.low}, {conf.high})", + rows = !is.na(estimate)) + Condition + Error in `modify_column_merge()`: + ! Columns specified in the `modify_column_merge(pattern)` argument are not present in table. + Columns "not_a_column" not found. + diff --git a/tests/testthat/test-modify_column_merge.R b/tests/testthat/test-modify_column_merge.R new file mode 100644 index 0000000000..ffc6ce0591 --- /dev/null +++ b/tests/testthat/test-modify_column_merge.R @@ -0,0 +1,41 @@ +mod <- lm(marker ~ age + grade, trial) |> tbl_regression() + +test_that("modify_column_merge() works", { + expect_error( + tbl <- + mod |> + modify_column_merge( + pattern = "{estimate} ({conf.low}, {conf.high})", + rows = !is.na(estimate) + ), + NA + ) + + expect_equal( + as_tibble(tbl, col_labels = FALSE) |> + dplyr::pull(estimate), + c( + "0.00 (-0.01, 0.01)", NA, NA, + "-0.38 (-0.69, -0.07)", "-0.12 (-0.43, 0.19)" + ) + ) +}) + +test_that("modify_column_merge() messaging", { + expect_snapshot( + error = TRUE, + mod |> + modify_column_merge( + pattern = "{not_a_column} ({conf.low}, {conf.high})", + rows = !is.na(estimate) + ) + ) + + expect_error( + mod |> + modify_column_merge( + pattern = "no columns selected", + rows = !is.na(estimate) + ) + ) +}) From a6664d6d3b133779741060c9ed51421b563043a8 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 20 May 2024 14:40:19 -0700 Subject: [PATCH 71/74] v2.0 `modify_column_hide()`, `modify_column_unhide()`, `modify_column_alignment()`, `modify_column_indent()` (#1678) * in progress * progress * progress --- DESCRIPTION | 7 +- NAMESPACE | 2 + NEWS.md | 2 +- R/as_gt.R | 8 +- R/card_summary.R | 2 +- R/modify_column_alignment.R | 27 ++++++ R/modify_column_hide.R | 32 ++++--- R/modify_column_indent.R | 85 +++++++++++++++++++ R/modify_table_styling.R | 25 +++--- R/tbl_regression.R | 2 +- R/tbl_summary.R | 2 +- R/utils-as.R | 4 +- R/utils-gtsummary_core.R | 2 +- man/modify_column_alignment.Rd | 27 ++++++ man/modify_column_hide.Rd | 23 +++-- man/modify_column_indent.Rd | 49 +++++++++++ man/modify_column_merge.Rd | 2 +- man/modify_fmt_fun.Rd | 2 +- man/modify_table_styling.Rd | 6 +- pkgdown/_pkgdown.yml | 4 +- tests/testthat/_snaps/modify_column_hide.md | 13 +++ .../testthat/_snaps/modify_spanning_header.md | 8 ++ tests/testthat/_snaps/modify_table_styling.md | 8 +- tests/testthat/test-modify_column_alignment.R | 19 +++++ tests/testthat/test-modify_column_hide.R | 9 ++ tests/testthat/test-modify_column_indent.R | 72 ++++++++++++++++ tests/testthat/test-modify_table_styling.R | 24 +++--- 27 files changed, 395 insertions(+), 71 deletions(-) create mode 100644 R/modify_column_alignment.R create mode 100644 R/modify_column_indent.R create mode 100644 man/modify_column_alignment.Rd create mode 100644 man/modify_column_indent.Rd create mode 100644 tests/testthat/_snaps/modify_column_hide.md create mode 100644 tests/testthat/_snaps/modify_spanning_header.md create mode 100644 tests/testthat/test-modify_column_alignment.R create mode 100644 tests/testthat/test-modify_column_hide.R create mode 100644 tests/testthat/test-modify_column_indent.R diff --git a/DESCRIPTION b/DESCRIPTION index d9ef880efd..8d99026023 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -60,10 +60,13 @@ Suggests: broom.helpers (>= 1.15.0), broom.mixed, cardx (>= 0.1.0.9039), + effectsize, + emmeans, knitr, + lme4, + smd, testthat (>= 3.2.0), - withr, - lme4, smd, effectsize, emmeans + withr VignetteBuilder: knitr RdMacros: diff --git a/NAMESPACE b/NAMESPACE index f2c0f817e4..a92ad2d11f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,7 +44,9 @@ export(last_col) export(matches) export(modify_caption) export(modify_cols_merge) +export(modify_column_alignment) export(modify_column_hide) +export(modify_column_indent) export(modify_column_merge) export(modify_column_unhide) export(modify_fmt_fun) diff --git a/NEWS.md b/NEWS.md index 3d3870b731..2341d52c9f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,7 +20,7 @@ * Previously, in a `tbl_summary()` variables that were `c(0, 1)`, `c("no", "yes")`, `c("No", "Yes")`, and `c("NO", "YES")` would default to a dichotomous summary with the `1` and `yes` level being shown in the table. This would occur even in the case when, for example, only `0` was observed. In this release, the line shown for dichotomous variables must be observed OR the unobserved level must be either explicitly defined in a factor or be a logical vector. This means that a character vector of all `"yes"` or all `"no"` values will default to a categorical summary instead of dichotomous. -* Previously, indentation was handled with `modify_table_styling(text_format = c("indent", "indent2"))`, which would indent a cell 4 and 8 spaces, respectively. Handling of indentation has been migrated to `modify_table_styling(indentation = integer())`, and by default, the label column is indented to zero spaces. This makes it easier to indent a group of rows. +* Previously, indentation was handled with `modify_table_styling(text_format = c("indent", "indent2"))`, which would indent a cell 4 and 8 spaces, respectively. Handling of indentation has been migrated to `modify_table_styling(indent = integer())`, and by default, the label column is indented to zero spaces. This makes it easier to indent a group of rows. * The inputs for `modify_table_styling(undo_text_format)` has been updated to mirror its counterpart `modify_table_styling(text_format)` and no longer accepts `TRUE` or `FALSE`. diff --git a/R/as_gt.R b/R/as_gt.R index 6120f54844..f80fbfa3b9 100644 --- a/R/as_gt.R +++ b/R/as_gt.R @@ -136,13 +136,13 @@ table_styling_to_gt_calls <- function(x, ...) { # indent --------------------------------------------------------------------- gt_calls[["indent"]] <- map( - seq_len(nrow(x$table_styling$indentation)), + seq_len(nrow(x$table_styling$indent)), ~ expr(gt::text_transform( locations = gt::cells_body( - columns = !!x$table_styling$indentation$column[[.x]], - rows = !!x$table_styling$indentation$row_numbers[[.x]] + columns = !!x$table_styling$indent$column[[.x]], + rows = !!x$table_styling$indent$row_numbers[[.x]] ), - fn = function(x) paste0(!!paste(rep_len("\U00A0", x$table_styling$indentation$n_spaces[[.x]]), collapse = ""), x) + fn = function(x) paste0(!!paste(rep_len("\U00A0", x$table_styling$indent$n_spaces[[.x]]), collapse = ""), x) )) ) diff --git a/R/card_summary.R b/R/card_summary.R index 81408a1e68..9e500b39cc 100644 --- a/R/card_summary.R +++ b/R/card_summary.R @@ -234,7 +234,7 @@ card_summary <- function(cards, columns = "label", label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), - indentation = 4L + indent = 4L ) |> # adding the statistic footnote modify_table_styling( diff --git a/R/modify_column_alignment.R b/R/modify_column_alignment.R new file mode 100644 index 0000000000..f547733b0e --- /dev/null +++ b/R/modify_column_alignment.R @@ -0,0 +1,27 @@ +#' Modify column alignment +#' +#' Update column alignment/justification in a gtsummary table. +#' +#' @inheritParams modify_table_styling +#' +#' @export +#' @examples +#' # Example 1 ---------------------------------- +#' lm(age ~ marker + grade, trial) %>% +#' tbl_regression() %>% +#' modify_column_alignment(columns = everything(), align = "left") +modify_column_alignment <- function(x, columns, align = c("left", "right", "center")) { + check_class(x, "gtsummary") + updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) + align <- arg_match(align) + + x <- + modify_table_styling( + x = x, + columns = {{ columns }}, + align = align + ) + + x$call_list <- updated_call_list + x +} diff --git a/R/modify_column_hide.R b/R/modify_column_hide.R index d3200abcd5..030bebf70e 100644 --- a/R/modify_column_hide.R +++ b/R/modify_column_hide.R @@ -1,31 +1,31 @@ -#' Modify Hidden Columns +#' Modify hidden columns #' -#' \lifecycle{maturing} #' Use these functions to hide or unhide columns in a gtsummary table. +#' # TODO: Ensure this is accurate after we update `show_header_names()` +#' Use `show_header_names(show_hidden=TRUE)` to print available columns to update. #' #' @inheritParams modify_table_styling #' #' @name modify_column_hide -#' @family Advanced modifiers -# #' @examples -# #' \donttest{ -# #' # Example 1 ---------------------------------- -# #' # hide 95% CI, and replace with standard error -# #' modify_column_hide_ex1 <- -# #' lm(age ~ marker + grade, trial) %>% -# #' tbl_regression() %>% -# #' modify_column_hide(columns = ci) %>% -# #' modify_column_unhide(columns = std.error) -# #' } +#' @author Daniel D. Sjoberg +#' +#' @examples +#' # Example 1 ---------------------------------- +#' # hide 95% CI, and replace with standard error +#' lm(age ~ marker + grade, trial) |> +#' tbl_regression() |> +#' modify_column_hide(conf.low) |> +#' modify_column_unhide(columns = std.error) NULL #' @rdname modify_column_hide -#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary #' @export modify_column_hide <- function(x, columns) { set_cli_abort_call() check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_hide = match.call())) + + # hide columns --------------------------------------------------------------- x <- modify_table_styling( x = x, @@ -33,6 +33,7 @@ modify_column_hide <- function(x, columns) { hide = TRUE ) + # return updated object ------------------------------------------------------ x$call_list <- updated_call_list x } @@ -43,6 +44,8 @@ modify_column_unhide <- function(x, columns) { set_cli_abort_call() check_class(x, "gtsummary") updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) + + # unhide columns ------------------------------------------------------------- x <- modify_table_styling( x = x, @@ -50,6 +53,7 @@ modify_column_unhide <- function(x, columns) { hide = FALSE ) + # return updated object ------------------------------------------------------ x$call_list <- updated_call_list x } diff --git a/R/modify_column_indent.R b/R/modify_column_indent.R new file mode 100644 index 0000000000..f04911a39d --- /dev/null +++ b/R/modify_column_indent.R @@ -0,0 +1,85 @@ +#' Modify column indentation +#' +#' Add, increase, or reduce indentation for columns. +#' +#' @inheritParams modify_table_styling +#' @param double_indent,undo `r lifecycle::badge("deprecated")` +#' +#' @return a gtsummary table +#' @export +#' +#' @family Advanced modifiers +#' @examples +#' # remove indentation from `tbl_summary()` +#' trial |> +#' tbl_summary(include = grade) |> +#' modify_column_indent(columns = label, indent = 0L) +#' +#' # increase indentation in `tbl_summary` +#' trial |> +#' tbl_summary(include = grade) |> +#' modify_column_indent(columns = label, rows = !row_type %in% 'label', indent = 8L) +modify_column_indent <- function(x, columns, rows = NULL, indent = 4L, + double_indent, undo) { + set_cli_abort_call() + updated_call_list <- c(x$call_list, list(modify_table_styling = match.call())) + + # check inputs --------------------------------------------------------------- + check_class(x, "gtsummary") + check_not_missing(x) + check_not_missing(columns) + + # if deprecated arguments passed --------------------------------------------- + if (!missing(double_indent) || !missing(undo)) { + check_pkg_installed("withr", reference_pkg = "gtsummary") + if (!missing(double_indent)) { + lifecycle::deprecate_warn( + when = "2.0.0", + what = I(glue("modify_column_indent(double_indent={double_indent})")), + with = I(glue("modify_column_indent(indent={ifelse(double_indent, 8, 4)})")) + ) + } else double_indent <- FALSE + if (!missing(undo) && isTRUE(undo)) { + lifecycle::deprecate_warn( + when = "2.0.0", + what = I(glue("modify_column_indent(undo=TRUE)")), + with = I("modify_column_indent(indent=0)") + ) + } + else if (!missing(undo) && isFALSE(undo)) { + lifecycle::deprecate_warn( + when = "2.0.0", + what = I(glue("modify_column_indent(undo)")), + details = "Argument has been ignored." + ) + } else undo <- FALSE + + x <- + # run without triggering additional deprecation messaging + withr::with_options( + new = list(lifecycle_verbosity = "quiet"), + code = + modify_table_styling( + x, + columns = {{ columns }}, + rows = {{ rows }}, + text_format = ifelse(double_indent, "indent2", "indent"), + undo_text_format = undo + ) + ) + } + # otherwise, continue with the non-deprecated arguments ---------------------- + else { + x <- + modify_table_styling( + x, + columns = {{ columns }}, + rows = {{ rows }}, + indent = indent + ) + } + + # return x ------------------------------------------------------------------- + x$call_list <- updated_call_list + x +} diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index c4dbfea7e1..5c4e430753 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -46,7 +46,7 @@ #' columns in `x$table_body`. For example, to construct a confidence interval #' use `"{conf.low}, {conf.high}"`. The first column listed in the pattern #' string must match the single column name passed in `columns=`. -#' @param indentation (`integer`)\cr +#' @param indent (`integer`)\cr #' An integer indicating how many space to indent text #' #' @seealso See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} @@ -100,7 +100,7 @@ modify_table_styling <- function(x, fmt_fun = NULL, text_format = NULL, undo_text_format = NULL, - indentation = NULL, + indent = NULL, text_interpret = c("md", "html"), cols_merge_pattern = NULL) { set_cli_abort_call() @@ -123,10 +123,11 @@ modify_table_styling <- function(x, } # deprecation ---------------------------------------------------------------- + if (isFALSE(undo_text_format)) undo_text_format <- NULL if (isTRUE(undo_text_format)) { # set new values for the user if (any(c("indent", "indent2") %in% text_format)) { - indentation <- 0L + indent <- 0L } undo_text_format <- text_format |> setdiff(c("indent", "indent2")) text_format <- NULL @@ -135,7 +136,7 @@ modify_table_styling <- function(x, match.call() |> as.list() |> utils::modifyList( - list(text_format = NULL, undo_text_format = undo_text_format, indentation = indentation) + list(text_format = NULL, undo_text_format = undo_text_format, indent = indent) ) |> compact() if (nchar(expr_deparse(updated_call[["x"]])) > 30L) updated_call[["x"]] <- expr(.) @@ -150,7 +151,7 @@ modify_table_styling <- function(x, if (any(c("indent", "indent2") %in% text_format)) { lst_new_args <- list( - indentation = ifelse("indent" %in% text_format, 4L, 8L), + indent = ifelse("indent" %in% text_format, 4L, 8L), text_format = text_format |> setdiff(c("indent", "indent2")) %>% @@ -301,18 +302,18 @@ modify_table_styling <- function(x, {dplyr::bind_rows(x$table_styling$text_format, .)} # styler: off } - # indentation ---------------------------------------------------------------- - if (!is_empty(indentation)) { - if (!rlang::is_scalar_integerish(indentation)) { - cli::cli_abort("The {.arg indentation} argument must be a scalar integer.") + # indent --------------------------------------------------------------------- + if (!is_empty(indent)) { + if (!is_scalar_integerish(indent) || indent < 0L) { + cli::cli_abort("The {.arg indent} argument must be a non-negative scalar integer.") } - x$table_styling$indentation <- + x$table_styling$indent <- dplyr::bind_rows( - x$table_styling$indentation, + x$table_styling$indent, dplyr::tibble( column = columns, rows = list(rows), - n_spaces = as.integer(indentation) + n_spaces = as.integer(indent) ) ) } diff --git a/R/tbl_regression.R b/R/tbl_regression.R index 918252bb71..e9c1d9308a 100644 --- a/R/tbl_regression.R +++ b/R/tbl_regression.R @@ -235,6 +235,6 @@ tbl_regression.default <- function(x, modify_table_styling( columns = "label", rows = .data$row_type %in% c("level", "missing"), - indentation = 4 + indent = 4 ) } diff --git a/R/tbl_summary.R b/R/tbl_summary.R index e5c58c2918..d21f3d9eab 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -373,7 +373,7 @@ tbl_summary <- function(data, columns = "label", label = "**Characteristic**", rows = .data$row_type %in% c("level", "missing"), - indentation = 4L + indent = 4L ) |> # adding the statistic footnote modify_table_styling( diff --git a/R/utils-as.R b/R/utils-as.R index 127fa2c7c6..6ed1d26579 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -72,8 +72,8 @@ dplyr::ungroup() # indentation ---------------------------------------------------------------- - x$table_styling$indentation <- - x$table_styling$indentation %>% + x$table_styling$indent <- + x$table_styling$indent %>% dplyr::filter(.data$column %in% .cols_to_show(x)) %>% dplyr::rowwise() %>% dplyr::mutate( diff --git a/R/utils-gtsummary_core.R b/R/utils-gtsummary_core.R index 92993273e7..0bcbaebe7a 100644 --- a/R/utils-gtsummary_core.R +++ b/R/utils-gtsummary_core.R @@ -34,7 +34,7 @@ construct_initial_table_styling <- function(x) { format_type = character(), undo_text_format = logical() ) - x$table_styling$indentation <- + x$table_styling$indent <- # if there is a label column, make it if ("label" %in% x$table_styling$header$column) { dplyr::tibble( diff --git a/man/modify_column_alignment.Rd b/man/modify_column_alignment.Rd new file mode 100644 index 0000000000..a8bb02c4b9 --- /dev/null +++ b/man/modify_column_alignment.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_column_alignment.R +\name{modify_column_alignment} +\alias{modify_column_alignment} +\title{Modify column alignment} +\usage{ +modify_column_alignment(x, columns, align = c("left", "right", "center")) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +gtsummary object} + +\item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Selector of columns in \code{x$table_body}} + +\item{align}{(\code{string}) +String indicating alignment of column, must be one of \code{c("left", "right", "center")}} +} +\description{ +Update column alignment/justification in a gtsummary table. +} +\examples{ +# Example 1 ---------------------------------- +lm(age ~ marker + grade, trial) \%>\% + tbl_regression() \%>\% + modify_column_alignment(columns = everything(), align = "left") +} diff --git a/man/modify_column_hide.Rd b/man/modify_column_hide.Rd index 57db86f220..740ca473cb 100644 --- a/man/modify_column_hide.Rd +++ b/man/modify_column_hide.Rd @@ -3,7 +3,7 @@ \name{modify_column_hide} \alias{modify_column_hide} \alias{modify_column_unhide} -\title{Modify Hidden Columns} +\title{Modify hidden columns} \usage{ modify_column_hide(x, columns) @@ -17,15 +17,20 @@ gtsummary object} Selector of columns in \code{x$table_body}} } \description{ -\lifecycle{maturing} Use these functions to hide or unhide columns in a gtsummary table. } -\seealso{ -Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary +\section{TODO: Ensure this is accurate after we update \code{show_header_names()}}{ +Use \code{show_header_names(show_hidden=TRUE)} to print available columns to update. +} -Other Advanced modifiers: -\code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, -\code{\link{modify_table_styling}()} +\examples{ +# Example 1 ---------------------------------- +# hide 95\% CI, and replace with standard error +lm(age ~ marker + grade, trial) |> + tbl_regression() |> + modify_column_hide(conf.low) |> + modify_column_unhide(columns = std.error) +} +\author{ +Daniel D. Sjoberg } -\concept{Advanced modifiers} diff --git a/man/modify_column_indent.Rd b/man/modify_column_indent.Rd new file mode 100644 index 0000000000..42fc5d32a5 --- /dev/null +++ b/man/modify_column_indent.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/modify_column_indent.R +\name{modify_column_indent} +\alias{modify_column_indent} +\title{Modify column indentation} +\usage{ +modify_column_indent(x, columns, rows = NULL, indent = 4L, double_indent, undo) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +gtsummary object} + +\item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +Selector of columns in \code{x$table_body}} + +\item{rows}{(predicate \code{expression}) +Predicate expression to select rows in \code{x$table_body}. +Can be used to style footnote, formatting functions, missing symbols, +and text formatting. Default is \code{NULL}. See details below.} + +\item{indent}{(\code{integer})\cr +An integer indicating how many space to indent text} + +\item{double_indent, undo}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} +} +\value{ +a gtsummary table +} +\description{ +Add, increase, or reduce indentation for columns. +} +\examples{ +# remove indentation from `tbl_summary()` +trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = label, indent = 0L) + +# increase indentation in `tbl_summary` +trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = label, rows = !row_type \%in\% 'label', indent = 8L) +} +\seealso{ +Other Advanced modifiers: +\code{\link{modify_column_merge}()}, +\code{\link{modify_fmt_fun}()}, +\code{\link{modify_table_styling}()} +} +\concept{Advanced modifiers} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd index 54798e255c..1d2d1dd980 100644 --- a/man/modify_column_merge.Rd +++ b/man/modify_column_merge.Rd @@ -81,7 +81,7 @@ lm(marker ~ age + grade, trial) |> } \seealso{ Other Advanced modifiers: -\code{\link{modify_column_hide}()}, +\code{\link{modify_column_indent}()}, \code{\link{modify_fmt_fun}()}, \code{\link{modify_table_styling}()} } diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index 195f7f42bd..d68919bf10 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -46,7 +46,7 @@ an external object named \code{variable} in the following expression Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary Other Advanced modifiers: -\code{\link{modify_column_hide}()}, +\code{\link{modify_column_indent}()}, \code{\link{modify_column_merge}()}, \code{\link{modify_table_styling}()} } diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 3085f8c8e7..188809bf0e 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -18,7 +18,7 @@ modify_table_styling( fmt_fun = NULL, text_format = NULL, undo_text_format = NULL, - indentation = NULL, + indent = NULL, text_interpret = c("md", "html"), cols_merge_pattern = NULL ) @@ -63,7 +63,7 @@ function that formats the statistics in the columns/rows in \code{columns} and \ String indicated which type of text formatting to apply/remove to the rows and columns. Must be one of \code{c("bold", "italic")}.} -\item{indentation}{(\code{integer})\cr +\item{indent}{(\code{integer})\cr An integer indicating how many space to indent text} \item{text_interpret}{(\code{string})\cr @@ -133,7 +133,7 @@ internally with care, and it is \emph{not} recommended for users. See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary internals vignette} Other Advanced modifiers: -\code{\link{modify_column_hide}()}, +\code{\link{modify_column_indent}()}, \code{\link{modify_column_merge}()}, \code{\link{modify_fmt_fun}()} } diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 1ef036c0f6..f474c92892 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -168,10 +168,10 @@ reference: - modify_table_styling - modify_table_body - modify_column_hide - # - modify_column_alignment + - modify_column_alignment - modify_fmt_fun - modify_column_merge - # - modify_column_indent + - modify_column_indent - subtitle: Select Helpers - contents: - select_helpers diff --git a/tests/testthat/_snaps/modify_column_hide.md b/tests/testthat/_snaps/modify_column_hide.md new file mode 100644 index 0000000000..d5f446c75c --- /dev/null +++ b/tests/testthat/_snaps/modify_column_hide.md @@ -0,0 +1,13 @@ +# modify_column_hide() works + + Code + as.data.frame(modify_column_unhide(modify_column_hide(tbl_regression(lm(age ~ + marker + grade, trial)), column = conf.low), column = std.error)) + Output + **Characteristic** **Beta** **SE** **p-value** + 1 Marker Level (ng/mL) -0.04 1.28 >0.9 + 2 Grade + 3 I + 4 II 0.64 2.70 0.8 + 5 III 2.4 2.64 0.4 + diff --git a/tests/testthat/_snaps/modify_spanning_header.md b/tests/testthat/_snaps/modify_spanning_header.md new file mode 100644 index 0000000000..5b554bd9d9 --- /dev/null +++ b/tests/testthat/_snaps/modify_spanning_header.md @@ -0,0 +1,8 @@ +# modify_spanning_header(...) dynamic headers work with `tbl_summary()` + + Code + modify_spanning_header(tbl_summary(trial, include = marker), label = "This is not a valid {element}.") + Condition + Error in `modify_spanning_header()`: + ! There was an error in the `glue::glue()` evaluation of "This is not a valid {element}." for column "label". + diff --git a/tests/testthat/_snaps/modify_table_styling.md b/tests/testthat/_snaps/modify_table_styling.md index a8c6b9d640..05ba0eefb4 100644 --- a/tests/testthat/_snaps/modify_table_styling.md +++ b/tests/testthat/_snaps/modify_table_styling.md @@ -18,20 +18,20 @@ ! All columns specified in `cols_merge_pattern` argument must be present in `x$table_body` i The following columns are not present: "not_in_table" -# modify_table_styling(indentation) messaging +# modify_table_styling(indent) messaging Code modify_table_styling(tbl_summary(trial, include = grade), columns = "label", - rows = !row_type %in% "label", indentation = "not an integer") + rows = !row_type %in% "label", indent = "not an integer") Condition Error in `modify_table_styling()`: - ! The `indentation` argument must be a scalar integer. + ! The `indent` argument must be a non-negative scalar integer. # modify_table_styling(rows) messaging Code modify_table_styling(tbl_summary(trial, include = grade), columns = "label", - rows = "not_a_predicate", indentation = 8L) + rows = "not_a_predicate", indent = 8L) Condition Error in `modify_table_styling()`: ! The `rows` argument must be an expression that evaluates to a logical vector in `x$table_body`. diff --git a/tests/testthat/test-modify_column_alignment.R b/tests/testthat/test-modify_column_alignment.R new file mode 100644 index 0000000000..7580c1018e --- /dev/null +++ b/tests/testthat/test-modify_column_alignment.R @@ -0,0 +1,19 @@ +test_that("modify_column_alignment() works", { + tbl <- + lm(age ~ marker + grade, trial) |> + tbl_regression() + + expect_equal( + map_chr( + c("left", "right", "center"), + ~ tbl |> + modify_column_alignment(columns = everything(), align = .x) |> + getElement("table_styling") |> + getElement("header") |> + dplyr::pull("align") |> + unique() + ), + c("left", "right", "center") + ) +}) + diff --git a/tests/testthat/test-modify_column_hide.R b/tests/testthat/test-modify_column_hide.R new file mode 100644 index 0000000000..75aa7b49af --- /dev/null +++ b/tests/testthat/test-modify_column_hide.R @@ -0,0 +1,9 @@ +test_that("modify_column_hide() works", { + expect_snapshot( + lm(age ~ marker + grade, trial) |> + tbl_regression() |> + modify_column_hide(column = conf.low) |> + modify_column_unhide(column = std.error) |> + as.data.frame() + ) +}) diff --git a/tests/testthat/test-modify_column_indent.R b/tests/testthat/test-modify_column_indent.R new file mode 100644 index 0000000000..fc878e11f5 --- /dev/null +++ b/tests/testthat/test-modify_column_indent.R @@ -0,0 +1,72 @@ +# begin with deprecation messaging +test_that("modify_column_indent() deprecations", { + lifecycle::expect_deprecated( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = "label", undo = TRUE) + ) + lifecycle::expect_deprecated( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = "label", undo = FALSE) + ) + lifecycle::expect_deprecated( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = "label", double_indent = TRUE) + ) + lifecycle::expect_deprecated( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = "label", double_indent = FALSE) + ) + + # now check that the results are the same with and without deprecated args + withr::local_options(lifecycle_verbosity = "quiet") + tbl <- trial |> tbl_summary(include = grade) + + expect_equal( + modify_column_indent(tbl, columns = "label", undo = TRUE)[c("table_body", "table_styling")], + modify_column_indent(tbl, columns = "label", indent = 0L)[c("table_body", "table_styling")] + ) + expect_equal( + modify_column_indent(tbl, columns = "label", double_indent = TRUE)[c("table_body", "table_styling")], + modify_column_indent(tbl, columns = "label", indent = 8L)[c("table_body", "table_styling")] + ) +}) + +test_that("modify_column_indent() works", { + # remove indentation from `tbl_summary()` + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = label, indent = 0L) |> + getElement("table_styling") |> + getElement("indent") |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(n_spaces), + 0L + ) + + + # increase indentation in `tbl_summary` + expect_equal( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = label, rows = !row_type %in% 'label', indent = 8L) |> + getElement("table_styling") |> + getElement("indent") |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(n_spaces), + 8L + ) +}) + +test_that("modify_column_indent() messaging", { + expect_error( + trial |> + tbl_summary(include = grade) |> + modify_column_indent(columns = label, indent = -4L), + "must be a non-negative scalar integer" + ) +}) diff --git a/tests/testthat/test-modify_table_styling.R b/tests/testthat/test-modify_table_styling.R index c2aea14c8e..7eca4f47be 100644 --- a/tests/testthat/test-modify_table_styling.R +++ b/tests/testthat/test-modify_table_styling.R @@ -20,15 +20,15 @@ test_that("modify_table_styling(undo_text_format=logical()) deprecation", { undo_text_format = TRUE ) |> getElement("table_styling") |> - getElement("indentation"), + getElement("indent"), mtcars |> tbl_summary(include = mpg) |> modify_table_styling( columns = "label", - indentation = 0L + indent = 0L ) |> getElement("table_styling") |> - getElement("indentation") + getElement("indent") ) }) @@ -51,15 +51,15 @@ test_that("modify_table_styling(text_format=c('indent', 'indent2')) deprecation" text_format = "indent" ) |> getElement("table_styling") |> - getElement("indentation"), + getElement("indent"), mtcars |> tbl_summary(include = mpg) |> modify_table_styling( columns = "label", - indentation = 4L + indent = 4L ) |> getElement("table_styling") |> - getElement("indentation") + getElement("indent") ) }) @@ -265,17 +265,17 @@ test_that("modify_table_styling(undo_text_format)", { ) }) -test_that("modify_table_styling(indentation)", { +test_that("modify_table_styling(indent)", { expect_equal( trial |> tbl_summary(include = grade) |> modify_table_styling( columns = "label", rows = !row_type %in% "label", - indentation = 8L + indent = 8L ) |> getElement("table_styling") |> - getElement("indentation") |> + getElement("indent") |> dplyr::filter(.by = "column", column == "label", dplyr::n() == dplyr::row_number()) |> dplyr::pull(n_spaces), 8L @@ -369,7 +369,7 @@ test_that("modify_table_styling(cols_merge_pattern) messaging", { ) }) -test_that("modify_table_styling(indentation) messaging", { +test_that("modify_table_styling(indent) messaging", { expect_snapshot( error = TRUE, trial |> @@ -377,7 +377,7 @@ test_that("modify_table_styling(indentation) messaging", { modify_table_styling( columns = "label", rows = !row_type %in% "label", - indentation = "not an integer" + indent = "not an integer" ) ) }) @@ -390,7 +390,7 @@ test_that("modify_table_styling(rows) messaging", { modify_table_styling( columns = "label", rows = "not_a_predicate", - indentation = 8L + indent = 8L ) ) }) From 3ab49691a93a7b18a31256c57a99b9491eefe945 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 20 May 2024 17:41:56 -0700 Subject: [PATCH 72/74] v2.0 `modify_fmt_fun()` (#1679) * progress * Update DESCRIPTION * Update DESCRIPTION --- DESCRIPTION | 6 +-- NEWS.md | 2 +- R/add_stat.R | 2 +- R/modify.R | 3 +- R/modify_fmt_fun.R | 64 +++++++++++++++------------- R/modify_table_styling.R | 2 +- R/utils-as.R | 2 +- man/add_stat.Rd | 2 +- man/modify.Rd | 1 + man/modify_column_indent.Rd | 3 +- man/modify_column_merge.Rd | 3 +- man/modify_fmt_fun.Rd | 45 +++++++++++-------- man/modify_table_styling.Rd | 5 +-- tests/testthat/test-modify_fmt_fun.R | 34 +++++++++++++++ 14 files changed, 111 insertions(+), 63 deletions(-) create mode 100644 tests/testthat/test-modify_fmt_fun.R diff --git a/DESCRIPTION b/DESCRIPTION index 8d99026023..fc20c3bd5a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,7 @@ BugReports: https://github.com/ddsjoberg/gtsummary/issues Depends: R (>= 4.1) Imports: - cards (>= 0.1.0.9024), + cards (>= 0.1.0.9031), cli (>= 3.6.1), dplyr (>= 1.1.3), glue (>= 1.6.2), @@ -72,8 +72,8 @@ VignetteBuilder: RdMacros: lifecycle Remotes: - insightsengineering/cards, - insightsengineering/cardx + github::insightsengineering/cards, + github::insightsengineering/cardx Config/Needs/check: broom, broom.helpers, broom.mixed, lme4, effectsize, emmeans, smd Config/testthat/edition: 3 diff --git a/NEWS.md b/NEWS.md index 2341d52c9f..9ed25993dc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -46,7 +46,7 @@ * Arguments `modify_header(quiet)`, `modify_footnote(quiet)`, and `modify_spanning_header(quiet)` have been deprecated. Verbose messaging is no longer available. -* Arguments `modify_header(update)`, `modify_footnote(update)`, and `modify_spanning_header(update)` have been deprecated. Use dynamic dots instead, e.g. `modify_header(...)` +* Arguments `modify_header(update)`, `modify_footnote(update)`, `modify_spanning_header(update)`, and `modify_fmt_fun()` have been deprecated. Use dynamic dots instead, e.g. `modify_header(...)` * Arguments `add_stat(fmt_fun, header, footnote, new_col_name)` have been deprecated since v1.4.0 (2021-04-13). They have now been fully removed from the package. diff --git a/R/add_stat.R b/R/add_stat.R index 2efeb7f5bc..5cb9db1375 100644 --- a/R/add_stat.R +++ b/R/add_stat.R @@ -104,7 +104,7 @@ #' ) |> #' add_stat(fns = everything() ~ my_ttest3) |> #' modify_header(statistic = "**t-statistic**", p.value = "**p-value**") |> -#' modify_fmt_fun(list(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2))) +#' modify_fmt_fun(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2)) add_stat <- function(x, fns, location = everything() ~ "label") { set_cli_abort_call() updated_call_list <- c(x$call_list, list(add_stat = match.call())) diff --git a/R/modify.R b/R/modify.R index 1d2afd727e..a082249f87 100644 --- a/R/modify.R +++ b/R/modify.R @@ -21,6 +21,7 @@ #' The dynamic dots allow syntax like `modify_header(x, !!!list(label = "Variable"))`. #' See examples below. #' +#' TODO: Add link when the function below is added. #' Use the `show_header_names()` to see the column names that can be modified. #' @param abbreviation (scalar `logical`)\cr #' Logical indicating if an abbreviation is being updated. @@ -273,7 +274,7 @@ modify_spanning_header <- function(x, ..., text_interpret = c("md", "html"), "2.0.0", glue("gtsummary::{calling_fun}(update=)"), details = glue("Use `{calling_fun}(...)` input instead. - Dynamic dots allow for syntax like `{calling_fun}(!!!update)`."), + Dynamic dots allow for syntax like `{calling_fun}(!!!list(...))`."), env = get_cli_abort_call() ) dots <- c(dots, update) diff --git a/R/modify_fmt_fun.R b/R/modify_fmt_fun.R index 5cd2eea415..a5c1a1fb07 100644 --- a/R/modify_fmt_fun.R +++ b/R/modify_fmt_fun.R @@ -1,46 +1,52 @@ -#' Modify Formatting Functions +#' Modify formatting functions #' -#' \lifecycle{maturing} #' Use this function to update the way numeric columns and rows of `.$table_body` #' are formatted #' -#' @param update list of formulas or a single formula specifying the updated -#' formatting function. -#' The LHS specifies the column(s) to be updated, -#' and the RHS is the updated formatting function. -#' @param rows predicate expression to select rows in `x$table_body`. -#' Default is `NULL`. See details below. +#' @param ... [`dynamic-dots`][rlang::dyn-dots]\cr +#' Used to assign updates to formatting functions. +#' +#' Use `modify_fmt_fun(colname = )` to update a single column. Using a +#' formula will invoke tidyselect, e.g. `modify_fmt_fun(c(estimate, conf.low, conf.high) ~ )`. +#' +#' TODO: Add link when the function below is added. +#' Use the `show_header_names()` to see the column names that can be modified. +#' @inheritParams modify #' @inheritParams modify_table_styling #' #' @inheritSection modify_table_styling rows argument -#' @family Advanced modifiers -#' @seealso Review [list, formula, and selector syntax][syntax] used throughout gtsummary +#' #' @export -# #' @examples -# #' \donttest{ -# #' # Example 1 ---------------------------------- -# #' # show 'grade' p-values to 3 decimal places -# #' modify_fmt_fun_ex1 <- -# #' lm(age ~ marker + grade, trial) %>% -# #' tbl_regression() %>% -# #' modify_fmt_fun( -# #' update = p.value ~ styfn_pvalue(digits = 3), -# #' rows = variable == "grade" -# #' ) -# #' } -modify_fmt_fun <- function(x, update, rows = NULL) { +#' @examples +#' # Example 1 ---------------------------------- +#' # show 'grade' p-values to 3 decimal places and estimates to 4 sig figs +#' lm(age ~ marker + grade, trial) |> +#' tbl_regression() %>% +#' modify_fmt_fun( +#' p.value = styfn_pvalue(digits = 3), +#' c(estimate, conf.low, conf.high) ~ styfn_sigfig(digits = 4), +#' rows = variable == "grade" +#' ) +modify_fmt_fun <- function(x, ..., rows = NULL, update, quiet) { set_cli_abort_call() updated_call_list <- c(x$call_list, list(modify_column_unhide = match.call())) check_class(x, "gtsummary") - # converting update arg to a tidyselect list --------------------------------- + # process inputs ------------------------------------------------------------- + dots <- dots_list(...) + dots <- + .deprecate_modify_update_and_quiet_args( + dots = dots, update = update, quiet = quiet, calling_fun = "modify_fmt_fun" + ) + + # converting dots arg to a tidyselect list ----------------------------------- cards::process_formula_selectors( data = x$table_body, - update = update + dots = dots ) cards::check_list_elements( - x = update, - predicate = function(x) is_function(x), + x = dots, + predicate = \(x) is_function(x), error_msg = "The value passed in {.arg {arg_name}} for variable {.val {variable}} must be a function." ) @@ -48,9 +54,9 @@ modify_fmt_fun <- function(x, update, rows = NULL) { x <- modify_table_styling( x = x, - columns = names(update), + columns = names(dots), rows = {{ rows }}, - fmt_fun = update + fmt_fun = dots ) x$call_list <- updated_call_list diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R index 5c4e430753..d7da9c9872 100644 --- a/R/modify_table_styling.R +++ b/R/modify_table_styling.R @@ -14,7 +14,7 @@ #' gtsummary object #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Selector of columns in `x$table_body` -#' @param rows (predicate `expression`) +#' @param rows (predicate `expression`)\cr #' Predicate expression to select rows in `x$table_body`. #' Can be used to style footnote, formatting functions, missing symbols, #' and text formatting. Default is `NULL`. See details below. diff --git a/R/utils-as.R b/R/utils-as.R index 6ed1d26579..6251d4e471 100644 --- a/R/utils-as.R +++ b/R/utils-as.R @@ -274,7 +274,7 @@ dplyr::filter(FALSE) # replacing formatting functions for merged columns -------------------------- - x <- modify_fmt_fun(x, update = inject(!!merging_columns ~ as.character)) + x <- modify_fmt_fun(x, any_of(merging_columns) ~ as.character) # return merged gtsummary table ---------------------------------------------- x diff --git a/man/add_stat.Rd b/man/add_stat.Rd index b65af97e33..6c9d006e3f 100644 --- a/man/add_stat.Rd +++ b/man/add_stat.Rd @@ -118,5 +118,5 @@ trial |> ) |> add_stat(fns = everything() ~ my_ttest3) |> modify_header(statistic = "**t-statistic**", p.value = "**p-value**") |> - modify_fmt_fun(list(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2))) + modify_fmt_fun(statistic = styfn_sigfig(), p.value = styfn_pvalue(digits = 2)) } diff --git a/man/modify.Rd b/man/modify.Rd index ea6c6be6bd..ec7dd46ffd 100644 --- a/man/modify.Rd +++ b/man/modify.Rd @@ -33,6 +33,7 @@ formula will invoke tidyselect, e.g. \code{modify_*(all_stat_cols() ~ "**{level} The dynamic dots allow syntax like \code{modify_header(x, !!!list(label = "Variable"))}. See examples below. +TODO: Add link when the function below is added. Use the \code{show_header_names()} to see the column names that can be modified.} \item{text_interpret}{(\code{string})\cr diff --git a/man/modify_column_indent.Rd b/man/modify_column_indent.Rd index 42fc5d32a5..82ce70bd10 100644 --- a/man/modify_column_indent.Rd +++ b/man/modify_column_indent.Rd @@ -13,7 +13,7 @@ gtsummary object} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Selector of columns in \code{x$table_body}} -\item{rows}{(predicate \code{expression}) +\item{rows}{(predicate \code{expression})\cr Predicate expression to select rows in \code{x$table_body}. Can be used to style footnote, formatting functions, missing symbols, and text formatting. Default is \code{NULL}. See details below.} @@ -43,7 +43,6 @@ trial |> \seealso{ Other Advanced modifiers: \code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_column_merge.Rd b/man/modify_column_merge.Rd index 1d2d1dd980..4ac46f7782 100644 --- a/man/modify_column_merge.Rd +++ b/man/modify_column_merge.Rd @@ -14,7 +14,7 @@ gtsummary object} \code{x$table_body}. For example, to construct a confidence interval use \code{"{conf.low}, {conf.high}"}.} -\item{rows}{(predicate \code{expression}) +\item{rows}{(predicate \code{expression})\cr Predicate expression to select rows in \code{x$table_body}. Can be used to style footnote, formatting functions, missing symbols, and text formatting. Default is \code{NULL}. See details below.} @@ -82,7 +82,6 @@ lm(marker ~ age + grade, trial) |> \seealso{ Other Advanced modifiers: \code{\link{modify_column_indent}()}, -\code{\link{modify_fmt_fun}()}, \code{\link{modify_table_styling}()} } \concept{Advanced modifiers} diff --git a/man/modify_fmt_fun.Rd b/man/modify_fmt_fun.Rd index d68919bf10..77afcc4452 100644 --- a/man/modify_fmt_fun.Rd +++ b/man/modify_fmt_fun.Rd @@ -2,24 +2,31 @@ % Please edit documentation in R/modify_fmt_fun.R \name{modify_fmt_fun} \alias{modify_fmt_fun} -\title{Modify Formatting Functions} +\title{Modify formatting functions} \usage{ -modify_fmt_fun(x, update, rows = NULL) +modify_fmt_fun(x, ..., rows = NULL, update, quiet) } \arguments{ \item{x}{(\code{gtsummary})\cr -gtsummary object} +A gtsummary object} -\item{update}{list of formulas or a single formula specifying the updated -formatting function. -The LHS specifies the column(s) to be updated, -and the RHS is the updated formatting function.} +\item{...}{\code{\link[rlang:dyn-dots]{dynamic-dots}}\cr +Used to assign updates to formatting functions. -\item{rows}{predicate expression to select rows in \code{x$table_body}. -Default is \code{NULL}. See details below.} +Use \verb{modify_fmt_fun(colname = )} to update a single column. Using a +formula will invoke tidyselect, e.g. \verb{modify_fmt_fun(c(estimate, conf.low, conf.high) ~ )}. + +TODO: Add link when the function below is added. +Use the \code{show_header_names()} to see the column names that can be modified.} + +\item{rows}{(predicate \code{expression})\cr +Predicate expression to select rows in \code{x$table_body}. +Can be used to style footnote, formatting functions, missing symbols, +and text formatting. Default is \code{NULL}. See details below.} + +\item{update, quiet}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \description{ -\lifecycle{maturing} Use this function to update the way numeric columns and rows of \code{.$table_body} are formatted } @@ -42,12 +49,14 @@ an external object named \code{variable} in the following expression } } -\seealso{ -Review \link[=syntax]{list, formula, and selector syntax} used throughout gtsummary - -Other Advanced modifiers: -\code{\link{modify_column_indent}()}, -\code{\link{modify_column_merge}()}, -\code{\link{modify_table_styling}()} +\examples{ +# Example 1 ---------------------------------- +# show 'grade' p-values to 3 decimal places and estimates to 4 sig figs +lm(age ~ marker + grade, trial) |> + tbl_regression() \%>\% + modify_fmt_fun( + p.value = styfn_pvalue(digits = 3), + c(estimate, conf.low, conf.high) ~ styfn_sigfig(digits = 4), + rows = variable == "grade" + ) } -\concept{Advanced modifiers} diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd index 188809bf0e..fb8cb68a60 100644 --- a/man/modify_table_styling.Rd +++ b/man/modify_table_styling.Rd @@ -30,7 +30,7 @@ gtsummary object} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Selector of columns in \code{x$table_body}} -\item{rows}{(predicate \code{expression}) +\item{rows}{(predicate \code{expression})\cr Predicate expression to select rows in \code{x$table_body}. Can be used to style footnote, formatting functions, missing symbols, and text formatting. Default is \code{NULL}. See details below.} @@ -134,7 +134,6 @@ See \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition Other Advanced modifiers: \code{\link{modify_column_indent}()}, -\code{\link{modify_column_merge}()}, -\code{\link{modify_fmt_fun}()} +\code{\link{modify_column_merge}()} } \concept{Advanced modifiers} diff --git a/tests/testthat/test-modify_fmt_fun.R b/tests/testthat/test-modify_fmt_fun.R new file mode 100644 index 0000000000..6405d9743c --- /dev/null +++ b/tests/testthat/test-modify_fmt_fun.R @@ -0,0 +1,34 @@ +test_that("modify_fmt_fun() works", { + expect_error( + tbl <- lm(age ~ marker + grade, trial) |> + tbl_regression() %>% + modify_fmt_fun( + p.value = styfn_pvalue(digits = 3), + c(estimate, conf.low, conf.high) ~ styfn_sigfig(digits = 4), + rows = variable == "grade" + ), + NA + ) + + expect_equal( + tbl |> + getElement("table_styling") |> + getElement("fmt_fun") |> + dplyr::filter(column %in% "p.value") |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(fmt_fun) |> + unique(), + list(styfn_pvalue(digits = 3)) + ) + + expect_equal( + tbl |> + getElement("table_styling") |> + getElement("fmt_fun") |> + dplyr::filter(column %in% c("estimate", "conf.low", "conf.high")) |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(fmt_fun) |> + unique(), + list(styfn_sigfig(digits = 4)) + ) +}) From 3b3bc62102bc563362d9d6120685ac484bebc731 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 20 May 2024 18:42:35 -0700 Subject: [PATCH 73/74] v2.0 bold and italicize labels and levels (#1680) * progress * Update _pkgdown.yml --- NAMESPACE | 8 + R/bold_italicize_labels_levels.R | 149 ++++++++++++++++++ man/bold_italicize_labels_levels.Rd | 51 ++++++ pkgdown/_pkgdown.yml | 2 +- .../test-bold_italicize_labels_levels.R | 53 +++++++ tests/testthat/test-modify_fmt_fun.R | 24 +++ 6 files changed, 286 insertions(+), 1 deletion(-) create mode 100644 R/bold_italicize_labels_levels.R create mode 100644 man/bold_italicize_labels_levels.Rd create mode 100644 tests/testthat/test-bold_italicize_labels_levels.R diff --git a/NAMESPACE b/NAMESPACE index a92ad2d11f..dca5f7adc0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,10 @@ S3method(add_stat_label,tbl_summary) S3method(as.data.frame,gtsummary) S3method(as_tibble,gtsummary) S3method(assign_tests,tbl_summary) +S3method(bold_labels,gtsummary) +S3method(bold_levels,gtsummary) +S3method(italicize_labels,gtsummary) +S3method(italicize_levels,gtsummary) S3method(print,gtsummary) S3method(tbl_regression,default) export("%>%") @@ -35,11 +39,15 @@ export(as_tibble) export(assign_summary_digits) export(assign_summary_type) export(assign_tests) +export(bold_labels) +export(bold_levels) export(brdg_summary) export(card_summary) export(contains) export(ends_with) export(everything) +export(italicize_labels) +export(italicize_levels) export(last_col) export(matches) export(modify_caption) diff --git a/R/bold_italicize_labels_levels.R b/R/bold_italicize_labels_levels.R new file mode 100644 index 0000000000..817a58edc3 --- /dev/null +++ b/R/bold_italicize_labels_levels.R @@ -0,0 +1,149 @@ +#' Bold or Italicize +#' +#' Bold or italicize labels or levels in gtsummary tables +#' +#' @name bold_italicize_labels_levels +#' @param x (`gtsummary`) +#' An object of class 'gtsummary' +#' @author Daniel D. Sjoberg +#' +#' @return Functions return the same class of gtsummary object supplied +#' @examples +#' # Example 1 ---------------------------------- +#' tbl_summary(trial, include = c("trt", "age", "response")) |> +#' bold_labels() |> +#' bold_levels() |> +#' italicize_labels() |> +#' italicize_levels() +NULL + + +#' @export +#' @rdname bold_italicize_labels_levels +bold_labels <- function(x) { + UseMethod("bold_labels") +} + +#' @export +#' @rdname bold_italicize_labels_levels +italicize_labels <- function(x) { + UseMethod("italicize_labels") +} + +#' @export +#' @rdname bold_italicize_labels_levels +bold_levels <- function(x) { + UseMethod("bold_levels") +} + + +#' @export +#' @rdname bold_italicize_labels_levels +italicize_levels <- function(x) { + UseMethod("italicize_levels") +} + +#' @export +#' @rdname bold_italicize_labels_levels +bold_labels.gtsummary <- function(x) { + updated_call_list <- c(x$call_list, list(bold_labels = match.call())) + # input checks --------------------------------------------------------------- + if (!"row_type" %in% x$table_styling$header$column) { + cli::cli_inform("{.code bold_labels()} cannot be used in this context.") + return(x) + } + + # bold labels ---------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = .first_unhidden_column(x), + rows = .data$row_type == "label", + text_format = "bold" + ) + + x$call_list <- updated_call_list + + x +} + +#' @export +#' @rdname bold_italicize_labels_levels +bold_levels.gtsummary <- function(x) { + updated_call_list <- c(x$call_list, list(bold_levels = match.call())) + # input checks --------------------------------------------------------------- + if (!"row_type" %in% x$table_styling$header$column) { + cli::cli_inform("{.code bold_levels()} cannot be used in this context.") + return(x) + } + + # bold levels ---------------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = .first_unhidden_column(x), + rows = .data$row_type != "label", + text_format = "bold" + ) + + x$call_list <- updated_call_list + + x +} + + +#' @export +#' @rdname bold_italicize_labels_levels +italicize_labels.gtsummary <- function(x) { + updated_call_list <- c(x$call_list, list(italicize_labels = match.call())) + # input checks --------------------------------------------------------------- + if (!"row_type" %in% x$table_styling$header$column) { + cli::cli_inform("{.code italicize_labels()} cannot be used in this context.") + return(x) + } + + # italicize labels ----------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = .first_unhidden_column(x), + rows = .data$row_type == "label", + text_format = "italic" + ) + + x$call_list <- updated_call_list + + x +} + +#' @export +#' @rdname bold_italicize_labels_levels +italicize_levels.gtsummary <- function(x) { + updated_call_list <- c(x$call_list, list(italicize_levels = match.call())) + # input checks --------------------------------------------------------------- + if (!"row_type" %in% x$table_styling$header$column) { + cli::cli_inform("{.code italicize_levels()} cannot be used in this context.") + return(x) + } + + # italicize levels ----------------------------------------------------------- + x <- + modify_table_styling( + x, + columns = .first_unhidden_column(x), + rows = .data$row_type != "label", + text_format = "italic" + ) + + x$call_list <- updated_call_list + + x +} + + +.first_unhidden_column <- function(x) { + x$table_styling$header |> + dplyr::filter(!.data$hide) |> + dplyr::pull("column") |> + dplyr::first() +} diff --git a/man/bold_italicize_labels_levels.Rd b/man/bold_italicize_labels_levels.Rd new file mode 100644 index 0000000000..c55cebf1ff --- /dev/null +++ b/man/bold_italicize_labels_levels.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bold_italicize_labels_levels.R +\name{bold_italicize_labels_levels} +\alias{bold_italicize_labels_levels} +\alias{bold_labels} +\alias{italicize_labels} +\alias{bold_levels} +\alias{italicize_levels} +\alias{bold_labels.gtsummary} +\alias{bold_levels.gtsummary} +\alias{italicize_labels.gtsummary} +\alias{italicize_levels.gtsummary} +\title{Bold or Italicize} +\usage{ +bold_labels(x) + +italicize_labels(x) + +bold_levels(x) + +italicize_levels(x) + +\method{bold_labels}{gtsummary}(x) + +\method{bold_levels}{gtsummary}(x) + +\method{italicize_labels}{gtsummary}(x) + +\method{italicize_levels}{gtsummary}(x) +} +\arguments{ +\item{x}{(\code{gtsummary}) +An object of class 'gtsummary'} +} +\value{ +Functions return the same class of gtsummary object supplied +} +\description{ +Bold or italicize labels or levels in gtsummary tables +} +\examples{ +# Example 1 ---------------------------------- +tbl_summary(trial, include = c("trt", "age", "response")) |> + bold_labels() |> + bold_levels() |> + italicize_labels() |> + italicize_levels() +} +\author{ +Daniel D. Sjoberg +} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index f474c92892..b821203477 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -147,7 +147,7 @@ reference: - contents: - modify - modify_caption - # - bold_italicize_labels_levels + - bold_italicize_labels_levels # - bold_p # - sort_filter_p # - remove_row_type diff --git a/tests/testthat/test-bold_italicize_labels_levels.R b/tests/testthat/test-bold_italicize_labels_levels.R new file mode 100644 index 0000000000..36e5a5babf --- /dev/null +++ b/tests/testthat/test-bold_italicize_labels_levels.R @@ -0,0 +1,53 @@ +tbl <- tbl_summary(trial, include = age) + +test_that("bold_labels() works", { + expect_equal( + bold_labels(tbl) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(format_type == "bold") |> + getElement("rows") |> + getElement(1L) |> + quo_get_expr(), + expr(.data$row_type == "label") + ) +}) + +test_that("bold_levels() works", { + expect_equal( + bold_levels(tbl) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(format_type == "bold") |> + getElement("rows") |> + getElement(1L) |> + quo_get_expr(), + expr(.data$row_type != "label") + ) +}) + +test_that("italicize_labels() works", { + expect_equal( + italicize_labels(tbl) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(format_type == "italic") |> + getElement("rows") |> + getElement(1L) |> + quo_get_expr(), + expr(.data$row_type == "label") + ) +}) + +test_that("italicize_levels() works", { + expect_equal( + italicize_levels(tbl) |> + getElement("table_styling") |> + getElement("text_format") |> + dplyr::filter(format_type == "italic") |> + getElement("rows") |> + getElement(1L) |> + quo_get_expr(), + expr(.data$row_type != "label") + ) +}) diff --git a/tests/testthat/test-modify_fmt_fun.R b/tests/testthat/test-modify_fmt_fun.R index 6405d9743c..89bf9c6a68 100644 --- a/tests/testthat/test-modify_fmt_fun.R +++ b/tests/testthat/test-modify_fmt_fun.R @@ -20,6 +20,18 @@ test_that("modify_fmt_fun() works", { unique(), list(styfn_pvalue(digits = 3)) ) + expect_equal( + tbl |> + getElement("table_styling") |> + getElement("fmt_fun") |> + dplyr::filter(column %in% "p.value") |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(rows) |> + unique() |> + getElement(1L) |> + quo_get_expr(), + expr(variable == "grade") + ) expect_equal( tbl |> @@ -31,4 +43,16 @@ test_that("modify_fmt_fun() works", { unique(), list(styfn_sigfig(digits = 4)) ) + expect_equal( + tbl |> + getElement("table_styling") |> + getElement("fmt_fun") |> + dplyr::filter(column %in% c("estimate", "conf.low", "conf.high")) |> + dplyr::slice_tail(n = 1, by = "column") |> + dplyr::pull(rows) |> + unique() |> + getElement(1L) |> + quo_get_expr(), + expr(variable == "grade") + ) }) From b3d3e541a84480088c99fbf6e8fe823a608eca90 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 21 May 2024 17:04:50 +0200 Subject: [PATCH 74/74] update --- R/tbl_summary.R | 2 +- R/utils_examples.R | 40 +++++--- inst/example_outputs/tbl_summary_ex1.rds | Bin 1400 -> 1438 bytes inst/example_outputs/tbl_summary_ex2.rds | Bin 1523 -> 1579 bytes inst/example_outputs/tbl_summary_ex3.rds | Bin 1158 -> 1200 bytes man/tbl_summary.Rd | 115 +++++++++++------------ man/utils_examples.Rd | 23 +++-- tests/testthat/test-utils_examples.R | 10 +- 8 files changed, 110 insertions(+), 80 deletions(-) diff --git a/R/tbl_summary.R b/R/tbl_summary.R index ad76628840..6b8c75d294 100644 --- a/R/tbl_summary.R +++ b/R/tbl_summary.R @@ -150,7 +150,6 @@ #' statistic = list(all_continuous() ~ "{mean} ({sd})"), #' digits = list(age = c(0, 1)) #' ) -#' print(getOption("gtsummary_update_examples")) #' ``` #' \if{html}{\out{ #' ```{r, echo = FALSE, results = 'asis'} @@ -174,6 +173,7 @@ #' write_read_example_output(ex3, "tbl_summary") #' ``` #' }} +#' #' @md tbl_summary <- function(data, by = NULL, diff --git a/R/utils_examples.R b/R/utils_examples.R index ed40316cf2..2b3e2bdf28 100644 --- a/R/utils_examples.R +++ b/R/utils_examples.R @@ -3,20 +3,25 @@ #' This is still experimental. We are planning to potentially expand this to other #' html output. Principally based on [as_gt()] and [gt::as_raw_html()]. #' -#' @param tbl (`gtsummary` or `html`)\cr tables are converted to html. Any html code (table or not) -#' can be saved and retrieved for documentation purposes. -#' @param example_name (`string`)\cr usually the name of the function or file where the -#' table is used. -#' @param out_var_name (`string`)\cr the name of the variable that will be saved. It defaults -#' to the name of the variable passed to the function (`tbl`). -#' @param method (`string`)\cr saving method. Default is `"rds"` as it produces a smaller file, -#' but we are planning to extend this to other, non-html outputs like `"png"`. +#' @param tbl (`gtsummary` or `html`)\cr +#' Tables are converted to html. Any html code (table or not) can be saved and +#' retrieved for documentation purposes. +#' @param example_name (`string`)\cr +#' Usually the name of the function or file where the table is used. +#' @param out_var_name (`string`)\cr +#' The name of the variable that will be saved. It defaults to the name of the +#' variable passed to the function (`tbl`). +#' @param decoration_function (`NULL` or `function`)\cr +#' Function of the form `function(x) tab_options(x) |> tab_style()` where additional +#' specifications can be added to the table before saving it. If `NULL` only a white +#' `gt::cell_fill` is used. #' -#' @keywords internal #' @name utils_examples +#' @keywords internal write_example_output <- function(tbl, example_name = "example", - out_var_name = NULL) { + out_var_name = NULL, + decoration_function = NULL) { if(is.null(out_var_name)) out_var_name <- deparse(substitute(tbl)) if (getOption("gtsummary_update_examples", default = FALSE)) { if (is(tbl, "gtsummary")) { @@ -24,8 +29,21 @@ write_example_output <- function(tbl, as_gt() } if (is(tbl, "gt_tbl")) { + if (is.null(decoration_function)) { + decoration_function <- function(x) { + gt::tab_options(x) |> + gt::tab_style( + style = list( + gt::cell_fill(color = "white"), + gt::cell_text(color = "black"), + gt::cell_borders(color = "lightgrey", sides = c("top", "bottom")) + ), + locations = gt::cells_body() + ) + } + } tbl <- tbl |> - gt::tab_options() |> + decoration_function() |> gt::as_raw_html() } if (!is(tbl, "html")) { diff --git a/inst/example_outputs/tbl_summary_ex1.rds b/inst/example_outputs/tbl_summary_ex1.rds index 272d6d0340ca4e30e043aeb76616c8a3aab6be7b..e86c3ed87761ae67a8c93f6c0b6e3d0e2857e5e2 100644 GIT binary patch literal 1438 zcmV;P1!4LhiwFP!000001MOSgZre5#R@>yFz1kxX8u|xViYVRr918sZK*DPWoo;yB|TCk36rh?6{r$9}~U zR-j)}_L)AdsA-XWT%==`NYOh`UmF-8Fi@UgSd%hdfX1wdNa2MnNpQ|d50#|=B{UVskDK27~X(%A&o>HX2U}T}3w1<8?P%mQ+PQSne{!4&@7R(#Ubua0Om28Z| zv$$ZhEb>aFZ`3P58ZTx>^B@4gQUhlRjcN^Mz`k5SMO^AVIhOBblX{@lax&6rY0;(| zN`0>nD-LzaWfK;)`~@FWoda3#y)C$R`#O>u!k0o25Sv1Hrc zs&TEqo0PC7u&Zp*?LNMSEd;p~9*}s(Cm`t|noVI@VzXU`Am>S{PdrE`an?iHI{~U@ zQ1n8oX{1o}vMSUBT7ENgsk<8f3%qoYs#XY)E9i#{4q%Ja51({)AyLwm$ zLEj)?*xwV=uR~@?GSK>8vH1=S(0;eu0Hx{!3e0kzoX?mDV6F+I?TiUBg8X&Hwbx=68jMpxSth+o<$e{mNEHkt1LE2?%fPr5 zEOOnmeCYQjZXvqmVko zg2x0%YGnzav{mk1V~QH2kJ})9dRTS&9@JVMwf~XdFi2V=)kJz!V^H{%M_ZTo)8z5pmeaiJ@4=LIyTuXj)@QB3 z;k#aQx#=F!9npH@#i?uVCEc92mUj@M7H?E;6zs2cOc~ZHsw+pZf0l>qYYcMO#vq5c zXApNA4}zoLNkn1M&))kT^#0&^fS_!)7|rwH@^OH^_tbH4S%~Px&~bL|t1GBG&O`Xz snTj-l&qw-Ns{F0B?<(s+LEc-vUmK*$55w|W3RM327w|6&pZGce0Iid_#<0#6kFa}pm7wZFnLHG9-Z@@k92eV`>thKTh{j0 z6KiV+n%2(Mr#H?y$bNv%6U+MZnPs`pI|02xG`O&b0ZIG_-|)ajTuei9VJA2UXgqX6 zG7#-%a_eP+lnzHliC{_F%?tWW2o`A>yCLZyWE1DMjmLt``%~SY&_IlIb3~MC)wa94 z2*Gbh;C@JuA7akIPSI0+8wFTk=kpk+f;j=@Qs^Wp^9ko*!G%4*Azzr*XH0OB;$${z z9@UwU{xucOfW^Y$5lkC_jyA%vpg5$MlfXkx#J)I;-`<%uO!1WaI3ylYLjxSqaN0(E z$_0s>F>RoOk7URQx_W!iKpz-*hc(czB)lPl`nZ8EQ`n|~IF7l)NlFK>;xb9#v0t%} zrRe8~{Xq|MYDy#@r%|7UQuGeg7Z!R59F&9@Y*NniP@km%NgbbsAx=1HqpanjkjBI@ zfj}`!BOH1t!s(F48VX2-ClhHf7@03OZKLPM>c_Z)(=V`rdkRp{g2{q%JxfMnF6(3e zdYH0t95|WMH|obj8ZTx?^B@4gOao^j4GIHh!I3l|C(iU_}CfX=v6Q1Ds!gg($uCq4xSpp#gk*yAd{ZM$ol`J0a4~6$?gj4Jbpe7ECCC3iu zgG=MRNC`_4JI@x)=H5MQA;_(8fW%`y07)Cscm!sN?>lq|&OAx=p##UsFm59q9S`MC zP;?^IEF7WeG%wTyT$pDFSjlonEgI1vAhGe6*;Ott%X@UACddfNO>Jbl3Nqb}4t2K( zf{sBzw{s{){|}iyi9zds#pXM7fsUHZ1yHIvpum{3|9Q-W2YU_R*p8VXJvhIvxfUDz z>ds_D1#w`hPuek?z-__H9Z*z&YkV({Oan~4dbagAkxf@yr8~L}Hq}YYdN!RU2+(LFsV{=IktyJ9;4%J0LUm5x=m@Zz?ds6s-?*h4d&a%r;M+8VZf~4^5 zA?_0(sktYB(&lIH5?2%;eO?CX^EDu?@8*&b7TmVV&2BX}KMcBvAerTdorWF`r5uZ`|Ju%M+ymf|N9G^GP$=OR4{fzr+R@i)u zRAGg`|I)9k_!>^xxMqlriGEdvaNU|19vL*M5W_DiM7XAdjfr_xI_UJ%ZcPY}3>@p+ z6yDaPurYD3N(!gv@F}9TSAT?fYyeq{7;0wNoWR%2Py^&EGDA%bn-lrU)X)NIII5}P z(E+3iHGCRJEJYs(Pgu9 zr21re-R2r4NoIMm7Ng*Q2evoJx1d66uOD+%^IoZG;m^aZIrwp^w}#yKNHTUObPqj0BM~F$)4S(;=mP`mus!q>i7$wx0p3F=93HcW1Wtr22&Y5nagwGm z?KdoD9Q`n6pXu|0ni9#`Y&>AG61@lYOC5a#21;WLW75X+(SY%ga5rFaj8j3{C@=Xa zrU`Mgg+K}8V;uWvjCn*80|lg)Cl?toWU@d#w2huN^(!-npjYq!?+~D11k)Ae<}S4o z3)uh%=MiUta0ojTh!}2H?V~ym(m3iPs9);ZA6n13`y0;91PKJP9XJ3x~88QQsfY!f@%~L*!(8&rWRdvA8zAiuY>i&DwMX!!^Pf(i; z^4XUOlRk`K2*EsIlJp^}oeLw*P;DyH5tYP+t^sK$Yzlh_zYw;l1cL>B5w96sP49d} zVv?$&X9jC3rVL}UuCz(6WH5UlXUb4McPE3}g&PfcZ`+`>Q-G**4V`n06c+jDVCTAF z>MvVF*@X!zDNEG)QnjCjEmQ%`D1-CTHY@{lDQwgXCTY*>Cns2;-Dnzs64%FxeSMxVCyN0KXR9aqz7lTmk)d!LT6bpZ$Pg(*5Ds&X z@qhr0Ei3_~x7ebuF~t(PkIT?~d=GS+BfKJqRqw65yN|&c)dv}O+VQUA$h=yTOp#A{mDk&Q9S%KrTqEGe)KI*AB)Be>!c7KOyJ@0EZt z56BjdUk{F1y!hV&GLL?(Bed(aULL);36Kp7NDIh+ACPqe$b9o+!+J$wYs0$J`{Q@> z{*;`<-aWCQ-7;wvnDoeobPL2P0I_95`6j^ChH|I(BL~>o0B(7+3cRU4g0?Z-VzE+K zv|+sBh_zvSaUy?bL%F5TD$r;10PQvpckHL^7LV1yV-xV$*s&k7Zv<*>NH2tR8`CX^ zR)a$uz@beW(=8q=g2zL^Z8m%cGUx(Z(^_ZM?E^-Quwtc+_#dW#js0pw`B9`z`m1LDCXw zMx-{PTOd{eh|Aw{hpYN``g!U+l`^0tgTVR}UAf)vkYS>9u1j$ErWv?yOL2BjwBDN2 z?S_0072D@-zSd literal 1523 zcmVyFx#}YjD$=Gv)L6FjQ_C@s{%yTjF*Gf( zJA;;Jn~NkWA|1!Q+N11Q_F%&fNy(NR#gVraNG!z-Odg6y)cL-14(aCjw;jVUo)}wC z9vM%zp=oS?`})y30ogO?JTiX2LvH@d)ix@}q z(d1FBDH&W)VGUU*EFQpRW6;q-I20876m#M^$O_nZi}C9lSB+vk<1Y4zgVfLv2h^W+ z5T9{D0&7C|(aUo(Vg!Br^l~44VPGA$kA5cp6%o|M`{*o&+w3EbLvC>r(;>__iz0aJ zcg$xo`Vg?+>C23o0?GL-7%*RoK7;z)L5_7Nl|*78 z8({Zh6thX_S*g;G>c>HvFUcK~2LS@68aVT*mm5eXH01&^;#BY1iG0n6)B`P+6OyHo z0&RLA)%U(7U-Loj3dO5S#tKv>Be$$k;!wCmHBg{V$(I&rqQOXsPR+!&%H_IZOt6=F zMlwHpFLjl?F3vb5DC*03;1JwgG5P-h>_-@QNoOeo+jkgvO-9*wF)A^RIgJ?L0Wr_O@9fF)EL%nZ7IvIr> zq|tFuHiM!=sb(pKqNA)(2jJXwNdQ)|OsYj=>Uktg?3LVAPA~F%bfqqk2+Et9DCsK7 z^tu}AUY-QqgaN(off)ZcX1XKCp)zbn37vD>u!PWsw2@CRiF$TdG8nvHF7|!|fwyIXfZb@; zQJ{_j_bLj!y%`07rVly{Kr2?qi34?>&?k!l^JdE@`MwlB;3GrkIJD}_)D<3*h9EIK zyN?G1!q~zR5cC#X^cAMavHPTm-6w0XTOZ+Na9A?iU1qk+nfYNvjsW~xekM|K^PKv% zp0>1A{uK)f4vx-71c(o;&%w?G7Ja(__cZs_$lpuk=TZI^?9-UuK1O?X`}Ogw+pure z*l#%Y4UK)8{p!51`3xzO7ykNFzrKYRu+IwX+^{j|myHj{bxx=p=IuHcRE!yAa=}kA zAY5mFjlsNZG>{+d)JdSau-AE@I^5H-TH%~3PRrk=$pIs z=R{Q_$XYp}P70d?eCf#0gvijUlR_1tKLY3v>!eUQf~=Pm>a4Ii$d?Wcc4og=XN5{Z zUmq2!NsuyG;p-$|G5SJy#6n*Gf5PT~Up6{4PtacTO`RAj2)#-S?K&}3jv)2l8dVwn z(&3>_36;Y<|F=f)F3T$BU!fpNM+z!QR+nn8QE8M+&(~Gt%=JSnvF|E%UlYwcYx{30 zoxeK+&nx7-0yHx9ZmpHTq#mRkC{zCPM%H-coV8u#tnKp7DvNv`ToDrbg}{>c&fmY< zNARBRke8~G7{*Zpuy(JYQ`)2RzW&MEG?8Hys3 z#y-U(*$%Q2@*I8!B5ynpNZMMQ87nzF+>!HU{oWN5IS#z zmkX`k3%l1X{avWcftK4zaY<8Q%_<6e z-!=7jp|q(`y}MjjVKUb|utyz-$}Jj2g*hWHZP0~5Y(!l*_pM2}jvQkY6`7IGUtPGLRhV! z@Isp@l~A}`6pvQA}Stw-R)K1k~H zD&v3a6DCn`){oPl#k-qWrsxOeQ-!HU2~!VZFgHc@0b-8l4?wDMA5xouc+cvlbhU0N zRgvo$t1MJ0xQ0O?k?aQ*AS`M^4Z|-7!<=dVw?JIfjREf&EEeUVCeAHIY)zbQ@6X@u z_XbABqfNV{pZtn*1Tg>4#o?r?mX?&KvuAfV5D%}bytzYtY1+g`g)-U;63eB2K zEtv+VmltpnoSvV1&^Wzl)UWzG0pFTg>sS44!(>gV1*Hao2hG#g)f$(oUwsuJzx;Zn zy83#80_<5tCOya5e`@aU?mLI-cYiDss(z2`onHOFrav%eOzdduDZ~o}UYz!>!xzQwv(+hT?au=kUa@uoq62~k{ zd`^d|)5x!aN>H$5v@B5~?=%+$p-@VsRwl-@7;-W3uR7#XiFto&`x6$ck!_BsF>Tsz ze-{A%x{8FHLd1!bJvUJU({~{ziufNdNuh)vGpU7sUWkZFi96`IL&D|CuuupkRYCHZ zw!Bn-Lc?`a|^eE4zCgP#O?M|ki9UkNS> z_&ycCvb_Z}Yb5WdX(+fBy+!j&69Yg8<(%N2jPn8rMG@1&j|Ar=m$U;_D*(X(6l zOcW{M0i>izSZ1LBCOnnMf}xZ}deIJi-7>$@9g=;*1)3)a1uK}W7`LNzB<8Y^L>EaR zF0H;4EHJloO8h1{TDX-LtknW-4<*^X+7GMYG15RaExA zYw2UAw5hOuccpHP$x?I89(5enZqX>#m^1Q~4Z08}M$~gl-;(?2 zL9NhRbfFLvnUk#NHeH>rv$l*xjv+&lYYM`1t^(vrktNR)6}%def;fBOsWQ#`Q+iTcD(JSR6iDz<%k`AzJgxgYIcIW_Wo~C;4V>wB(4%p}fuvkIi zr8cutLg8dlXbE^}TuH!2woqze#NwD{rN7Em_4IXl4`VYxM^G>7LfJKt>340Y`^zBc zmI&x~57p?uAv2;GTK%`!d<#7|YBXw4-cwN8=-&mFC0=I0ED^8}D};TPPy{@peJR{h5jAM6iFZZ6b;Q5Oh|l=( znwZbnFf95e>=o(Nbnx)Ou?Zdg`MW*NY0O9l`|p|_ylcIvDdNGPU{i`XK85{O+k=;< zFKVWEWEi;c@;41)qT;8V4uGu-`a1I`W`-aNMjPHXa*N>W7U-9sbRUqS5f6bV>K)cx0uV@e(hcO%X9cTNg`G#rRd4}ihkxDt9ckOpg`hQ8kW59zA{o&Ko YrAfB^EUMmXV&|{F0j)2y-Z>=z08rO2X8-^I diff --git a/man/tbl_summary.Rd b/man/tbl_summary.Rd index e7b8635c6c..c0aec87524 100644 --- a/man/tbl_summary.Rd +++ b/man/tbl_summary.Rd @@ -167,7 +167,7 @@ Basic \code{tbl_summary} function: tbl_summary() }\if{html}{\out{
}} -\if{html}{\out{
+\if{html}{\out{
@@ -177,27 +177,27 @@ Basic \code{tbl_summary} function: - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + - +
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
Age47 (38, 57)
    Unknown11
Grade
    I68 (34%)
    II68 (34%)
    III64 (32%)
Tumor Response61 (32%)
    Unknown7
1 Median (Q1, Q3), n (%)1 Median (Q1, Q3); n (%)
@@ -214,10 +214,9 @@ Customizing the `tbl_summary` function: statistic = list(all_continuous() ~ "\{mean\} (\{sd\})"), digits = list(age = c(0, 1)) ) - print(getOption("gtsummary_update_examples")) }\if{html}{\out{
}} -\if{html}{\out{
+\if{html}{\out{
@@ -230,35 +229,35 @@ N = 102 - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + - +
Patient Age47 (14.7)47 (14.0)
    Unknown74
Grade

    I35 (36%)33 (32%)
    II32 (33%)36 (35%)
    III31 (32%)33 (32%)
Tumor Response28 (29%)33 (34%)
    Unknown34
Patient Age47 (14.7)47 (14.0)
    Unknown74
Grade

    I35 (36%)33 (32%)
    II32 (33%)36 (35%)
    III31 (32%)33 (32%)
Tumor Response28 (29%)33 (34%)
    Unknown34
1 Mean (SD), n (%)1 Mean (SD); n (%)
@@ -276,7 +275,7 @@ Multiple statistics for continuous variables: ) }\if{html}{\out{
}} -\if{html}{\out{
+\if{html}{\out{
@@ -286,18 +285,18 @@ Multiple statistics for continuous variables: - - - - - - - - - - - - + + + + + + + + + + + + diff --git a/man/utils_examples.Rd b/man/utils_examples.Rd index 3624815529..49cd7c1d08 100644 --- a/man/utils_examples.Rd +++ b/man/utils_examples.Rd @@ -10,7 +10,8 @@ write_example_output( tbl, example_name = "example", - out_var_name = deparse(substitute(tbl)) + out_var_name = NULL, + decoration_function = NULL ) read_example_output(out_var_name, example_name = "example") @@ -22,17 +23,21 @@ write_read_example_output( ) } \arguments{ -\item{tbl}{(\code{gtsummary} or \code{html})\cr tables are converted to html. Any html code (table or not) -can be saved and retrieved for documentation purposes.} +\item{tbl}{(\code{gtsummary} or \code{html})\cr +Tables are converted to html. Any html code (table or not) can be saved and +retrieved for documentation purposes.} -\item{example_name}{(\code{string})\cr usually the name of the function or file where the -table is used.} +\item{example_name}{(\code{string})\cr +Usually the name of the function or file where the table is used.} -\item{out_var_name}{(\code{string})\cr the name of the variable that will be saved. It defaults -to the name of the variable passed to the function (\code{tbl}).} +\item{out_var_name}{(\code{string})\cr +The name of the variable that will be saved. It defaults to the name of the +variable passed to the function (\code{tbl}).} -\item{method}{(\code{string})\cr saving method. Default is \code{"rds"} as it produces a smaller file, -but we are planning to extend this to other, non-html outputs like \code{"png"}.} +\item{decoration_function}{(\code{NULL} or \code{function})\cr +Function of the form \code{function(x) tab_options(x) |> tab_style()} where additional +specifications can be added to the table before saving it. If \code{NULL} only a white +\code{gt::cell_fill} is used.} } \description{ This is still experimental. We are planning to potentially expand this to other diff --git a/tests/testthat/test-utils_examples.R b/tests/testthat/test-utils_examples.R index 31064d5c98..95c4bf22d2 100644 --- a/tests/testthat/test-utils_examples.R +++ b/tests/testthat/test-utils_examples.R @@ -6,9 +6,17 @@ test_that("writing and reading examples work", { tbl_summary() # Direct html - html_tbl <- tbl_to_write |> + tbl_to_write |> as_gt() |> gt::tab_options() |> + gt::tab_style( + style = list( + gt::cell_fill(color = "white"), + gt::cell_text(color = "black"), + gt::cell_borders(color = "lightgrey", sides = c("top", "bottom")) + ), + locations = gt::cells_body() + ) #|> gt::as_raw_html() write_example_output(html_tbl) read_html_tbl <- read_example_output("html_tbl")
Age
    Median (Q1, Q3)47 (38, 57)
    Min, Max6, 83
Marker Level (ng/mL)
    Median (Q1, Q3)0.64 (0.22, 1.41)
    Min, Max0.00, 3.87
Age
    Median (Q1, Q3)47 (38, 57)
    Min, Max6, 83
Marker Level (ng/mL)
    Median (Q1, Q3)0.64 (0.22, 1.41)
    Min, Max0.00, 3.87