broom.helpers/0000755000176200001440000000000014464210122013025 5ustar liggesusersbroom.helpers/NAMESPACE0000644000176200001440000001531014464175037014263 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(model_compute_terms_contributions,default) S3method(model_get_assign,default) S3method(model_get_assign,model_fit) S3method(model_get_assign,vglm) S3method(model_get_coefficients_type,LORgee) S3method(model_get_coefficients_type,biglm) S3method(model_get_coefficients_type,clm) S3method(model_get_coefficients_type,clmm) S3method(model_get_coefficients_type,clogit) S3method(model_get_coefficients_type,coxph) S3method(model_get_coefficients_type,crr) S3method(model_get_coefficients_type,default) S3method(model_get_coefficients_type,fixest) S3method(model_get_coefficients_type,geeglm) S3method(model_get_coefficients_type,glm) S3method(model_get_coefficients_type,glmerMod) S3method(model_get_coefficients_type,model_fit) S3method(model_get_coefficients_type,multinom) S3method(model_get_coefficients_type,negbin) S3method(model_get_coefficients_type,polr) S3method(model_get_coefficients_type,svyolr) S3method(model_get_coefficients_type,tidycrr) S3method(model_get_contrasts,betareg) S3method(model_get_contrasts,default) S3method(model_get_contrasts,hurdle) S3method(model_get_contrasts,model_fit) S3method(model_get_contrasts,zeroinfl) S3method(model_get_model,default) S3method(model_get_model,mira) S3method(model_get_model_frame,biglm) S3method(model_get_model_frame,coxph) S3method(model_get_model_frame,default) S3method(model_get_model_frame,fixest) S3method(model_get_model_frame,model_fit) S3method(model_get_model_frame,survreg) S3method(model_get_model_matrix,LORgee) S3method(model_get_model_matrix,betareg) S3method(model_get_model_matrix,biglm) S3method(model_get_model_matrix,brmsfit) S3method(model_get_model_matrix,clm) S3method(model_get_model_matrix,default) S3method(model_get_model_matrix,fixest) S3method(model_get_model_matrix,glmmTMB) S3method(model_get_model_matrix,model_fit) S3method(model_get_model_matrix,multinom) S3method(model_get_model_matrix,plm) S3method(model_get_n,LORgee) S3method(model_get_n,coxph) S3method(model_get_n,default) S3method(model_get_n,glm) S3method(model_get_n,glmerMod) S3method(model_get_n,model_fit) S3method(model_get_n,multinom) S3method(model_get_n,survreg) S3method(model_get_n,tidycrr) S3method(model_get_nlevels,default) S3method(model_get_offset,default) S3method(model_get_pairwise_contrasts,betareg) S3method(model_get_pairwise_contrasts,default) S3method(model_get_pairwise_contrasts,hurdle) S3method(model_get_pairwise_contrasts,zeroinfl) S3method(model_get_response,default) S3method(model_get_response,glm) S3method(model_get_response,glmerMod) S3method(model_get_response,model_fit) S3method(model_get_response_variable,default) S3method(model_get_terms,betareg) S3method(model_get_terms,brmsfit) S3method(model_get_terms,default) S3method(model_get_terms,glmmTMB) S3method(model_get_terms,model_fit) S3method(model_get_weights,default) S3method(model_get_weights,model_fit) S3method(model_get_weights,svyglm) S3method(model_get_xlevels,brmsfit) S3method(model_get_xlevels,default) S3method(model_get_xlevels,felm) S3method(model_get_xlevels,glmerMod) S3method(model_get_xlevels,glmmTMB) S3method(model_get_xlevels,lmerMod) S3method(model_get_xlevels,model_fit) S3method(model_get_xlevels,plm) S3method(model_identify_variables,aov) S3method(model_identify_variables,clm) S3method(model_identify_variables,clmm) S3method(model_identify_variables,default) S3method(model_identify_variables,gam) S3method(model_identify_variables,lavaan) S3method(model_identify_variables,logitr) S3method(model_identify_variables,model_fit) S3method(model_list_contrasts,default) S3method(model_list_higher_order_variables,default) S3method(model_list_terms_levels,default) S3method(model_list_variables,default) S3method(model_list_variables,lavaan) S3method(model_list_variables,logitr) export("%>%") export(.assert_package) export(.clean_backticks) export(.escape_regex) export(.formula_list_to_named_list) export(.generic_selector) export(.get_all_packages_dependencies) export(.get_min_version_required) export(.get_package_dependencies) export(.is_selector_scoped) export(.select_to_varnames) export(all_categorical) export(all_continuous) export(all_contrasts) export(all_dichotomous) export(all_interaction) export(all_intercepts) export(all_of) export(all_ran_pars) export(all_ran_vals) export(any_of) export(contains) export(ends_with) export(everything) export(last_col) export(matches) export(model_compute_terms_contributions) export(model_get_assign) export(model_get_coefficients_type) export(model_get_contrasts) export(model_get_model) export(model_get_model_frame) export(model_get_model_matrix) export(model_get_n) export(model_get_nlevels) export(model_get_offset) export(model_get_pairwise_contrasts) export(model_get_response) export(model_get_response_variable) export(model_get_terms) export(model_get_weights) export(model_get_xlevels) export(model_identify_variables) export(model_list_contrasts) export(model_list_higher_order_variables) export(model_list_terms_levels) export(model_list_variables) export(num_range) export(one_of) export(plot_marginal_predictions) export(seq_range) export(starts_with) export(tidy_add_coefficients_type) export(tidy_add_contrasts) export(tidy_add_estimate_to_reference_rows) export(tidy_add_header_rows) export(tidy_add_n) export(tidy_add_pairwise_contrasts) export(tidy_add_reference_rows) export(tidy_add_term_labels) export(tidy_add_variable_labels) export(tidy_all_effects) export(tidy_and_attach) export(tidy_attach_model) export(tidy_avg_comparisons) export(tidy_avg_slopes) export(tidy_broom) export(tidy_detach_model) export(tidy_disambiguate_terms) export(tidy_get_model) export(tidy_ggpredict) export(tidy_identify_variables) export(tidy_marginal_contrasts) export(tidy_marginal_means) export(tidy_marginal_predictions) export(tidy_margins) export(tidy_multgee) export(tidy_parameters) export(tidy_plus_plus) export(tidy_remove_intercept) export(tidy_select_variables) export(tidy_with_broom_or_parameters) export(tidy_zeroinfl) export(variables_to_contrast) export(variables_to_predict) export(vars) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_code) importFrom(cli,cli_ul) importFrom(dplyr,`%>%`) importFrom(dplyr,add_row) importFrom(dplyr,all_of) importFrom(dplyr,any_of) importFrom(dplyr,contains) importFrom(dplyr,ends_with) importFrom(dplyr,everything) importFrom(dplyr,last_col) importFrom(dplyr,matches) importFrom(dplyr,num_range) importFrom(dplyr,one_of) importFrom(dplyr,starts_with) importFrom(dplyr,vars) importFrom(lifecycle,deprecate_soft) importFrom(purrr,"%||%") importFrom(rlang,.data) importFrom(rlang,.env) broom.helpers/README.md0000644000176200001440000003574614360056067014336 0ustar liggesusers # broom.helpers [![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) [![R-CMD-check](https://github.com/larmarange/broom.helpers/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/larmarange/broom.helpers/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/larmarange/broom.helpers/branch/main/graph/badge.svg)](https://app.codecov.io/gh/larmarange/broom.helpers?branch=main) [![CRAN status](https://www.r-pkg.org/badges/version/broom.helpers)](https://CRAN.R-project.org/package=broom.helpers) [![DOI](https://zenodo.org/badge/286680847.svg)](https://zenodo.org/badge/latestdoi/286680847) The broom.helpers package provides suite of functions to work with regression model `broom::tidy()` tibbles. The suite includes functions to group regression model terms by variable, insert reference and header rows for categorical variables, add variable labels, and more. `broom.helpers` is used, in particular, by `gtsummary::tbl_regression()` for producing [nice formatted tables of model coefficients](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html) and by `ggstats::ggcoef_model()` for [plotting model coefficients](https://larmarange.github.io/ggstats/articles/ggcoef_model.html). ## Installation & Documentation To install **stable version**: ``` r install.packages("broom.helpers") ``` Documentation of stable version: To install **development version**: ``` r remotes::install_github("larmarange/broom.helpers") ``` Documentation of development version: ## Examples ### all-in-one wrapper ``` r mod1 <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) library(broom.helpers) ex1 <- mod1 %>% tidy_plus_plus() ex1 #> # A tibble: 4 × 17 #> term varia…¹ var_l…² var_c…³ var_t…⁴ var_n…⁵ contr…⁶ contr…⁷ refer…⁸ label #> #> 1 Sepal.W… Sepal.… Sepal.… numeric contin… NA NA Sepa… #> 2 Species… Species Species factor catego… 3 contr.… treatm… TRUE seto… #> 3 Species… Species Species factor catego… 3 contr.… treatm… FALSE vers… #> 4 Species… Species Species factor catego… 3 contr.… treatm… FALSE virg… #> # … with 7 more variables: n_obs , estimate , std.error , #> # statistic , p.value , conf.low , conf.high , and #> # abbreviated variable names ¹​variable, ²​var_label, ³​var_class, ⁴​var_type, #> # ⁵​var_nlevels, ⁶​contrasts, ⁷​contrasts_type, ⁸​reference_row dplyr::glimpse(ex1) #> Rows: 4 #> Columns: 17 #> $ term "Sepal.Width", "Speciessetosa", "Speciesversicolor", "S… #> $ variable "Sepal.Width", "Species", "Species", "Species" #> $ var_label "Sepal.Width", "Species", "Species", "Species" #> $ var_class "numeric", "factor", "factor", "factor" #> $ var_type "continuous", "categorical", "categorical", "categorica… #> $ var_nlevels NA, 3, 3, 3 #> $ contrasts NA, "contr.treatment", "contr.treatment", "contr.treatm… #> $ contrasts_type NA, "treatment", "treatment", "treatment" #> $ reference_row NA, TRUE, FALSE, FALSE #> $ label "Sepal.Width", "setosa", "versicolor", "virginica" #> $ n_obs 150, 50, 50, 50 #> $ estimate 0.8035609, 0.0000000, 1.4587431, 1.9468166 #> $ std.error 0.1063390, NA, 0.1121079, 0.1000150 #> $ statistic 7.556598, NA, 13.011954, 19.465255 #> $ p.value 4.187340e-12, NA, 3.478232e-26, 2.094475e-42 #> $ conf.low 0.5933983, NA, 1.2371791, 1.7491525 #> $ conf.high 1.013723, NA, 1.680307, 2.144481 mod2 <- glm( response ~ poly(age, 3) + stage + grade * trt, na.omit(gtsummary::trial), family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.sum ) ) ex2 <- mod2 %>% tidy_plus_plus( exponentiate = TRUE, variable_labels = c(age = "Age (in years)"), add_header_rows = TRUE, show_single_row = "trt" ) ex2 #> # A tibble: 17 × 19 #> term varia…¹ var_l…² var_c…³ var_t…⁴ var_n…⁵ heade…⁶ contr…⁷ contr…⁸ refer…⁹ #> #> 1 age Age (i… nmatri… contin… NA TRUE NA #> 2 poly… age Age (i… nmatri… contin… NA FALSE NA #> 3 poly… age Age (i… nmatri… contin… NA FALSE NA #> 4 poly… age Age (i… nmatri… contin… NA FALSE NA #> 5 stage T Stage factor catego… 4 TRUE contr.… treatm… NA #> 6 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 7 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 8 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… TRUE #> 9 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 10 grade Grade factor catego… 3 TRUE contr.… sum NA #> 11 grad… grade Grade factor catego… 3 FALSE contr.… sum FALSE #> 12 grad… grade Grade factor catego… 3 FALSE contr.… sum FALSE #> 13 grad… grade Grade factor catego… 3 FALSE contr.… sum TRUE #> 14 trtD… trt Chemot… charac… dichot… 2 NA contr.… treatm… FALSE #> 15 grade:… Grade … intera… NA TRUE NA #> 16 grad… grade:… Grade … intera… NA FALSE NA #> 17 grad… grade:… Grade … intera… NA FALSE NA #> # … with 9 more variables: label , n_obs , n_event , #> # estimate , std.error , statistic , p.value , #> # conf.low , conf.high , and abbreviated variable names ¹​variable, #> # ²​var_label, ³​var_class, ⁴​var_type, ⁵​var_nlevels, ⁶​header_row, ⁷​contrasts, #> # ⁸​contrasts_type, ⁹​reference_row dplyr::glimpse(ex2) #> Rows: 17 #> Columns: 19 #> $ term NA, "poly(age, 3)1", "poly(age, 3)2", "poly(age, 3)3", … #> $ variable "age", "age", "age", "age", "stage", "stage", "stage", … #> $ var_label "Age (in years)", "Age (in years)", "Age (in years)", "… #> $ var_class "nmatrix.3", "nmatrix.3", "nmatrix.3", "nmatrix.3", "fa… #> $ var_type "continuous", "continuous", "continuous", "continuous",… #> $ var_nlevels NA, NA, NA, NA, 4, 4, 4, 4, 4, 3, 3, 3, 3, 2, NA, NA, NA #> $ header_row TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, F… #> $ contrasts NA, NA, NA, NA, "contr.treatment(base=3)", "contr.treat… #> $ contrasts_type NA, NA, NA, NA, "treatment", "treatment", "treatment", … #> $ reference_row NA, NA, NA, NA, NA, FALSE, FALSE, TRUE, FALSE, NA, FALS… #> $ label "Age (in years)", "Age (in years)", "Age (in years)²", … #> $ n_obs NA, 92, 56, 80, NA, 46, 50, 35, 42, NA, 63, 53, 57, 90,… #> $ n_event NA, 31, 17, 22, NA, 17, 12, 13, 12, NA, 20, 16, 18, 30,… #> $ estimate NA, 20.2416394, 1.2337899, 0.4931553, NA, 1.0047885, 0.… #> $ std.error NA, 2.3254455, 2.3512842, 2.3936657, NA, 0.4959893, 0.5… #> $ statistic NA, 1.29340459, 0.08935144, -0.29533409, NA, 0.00963137… #> $ p.value NA, 0.1958712, 0.9288026, 0.7677387, NA, 0.9923154, 0.1… #> $ conf.low NA, 0.225454425, 0.007493208, 0.004745694, NA, 0.379776… #> $ conf.high NA, 2315.587655, 100.318341, 74.226179, NA, 2.683385, 1… ``` ### fine control ``` r ex3 <- mod1 %>% # perform initial tidying of model tidy_and_attach() %>% # add reference row tidy_add_reference_rows() %>% # add term labels tidy_add_term_labels() %>% # remove intercept tidy_remove_intercept ex3 #> # A tibble: 4 × 16 #> term varia…¹ var_l…² var_c…³ var_t…⁴ var_n…⁵ contr…⁶ contr…⁷ refer…⁸ label #> #> 1 Sepal.W… Sepal.… Sepal.… numeric contin… NA NA Sepa… #> 2 Species… Species Species factor catego… 3 contr.… treatm… TRUE seto… #> 3 Species… Species Species factor catego… 3 contr.… treatm… FALSE vers… #> 4 Species… Species Species factor catego… 3 contr.… treatm… FALSE virg… #> # … with 6 more variables: estimate , std.error , statistic , #> # p.value , conf.low , conf.high , and abbreviated variable #> # names ¹​variable, ²​var_label, ³​var_class, ⁴​var_type, ⁵​var_nlevels, #> # ⁶​contrasts, ⁷​contrasts_type, ⁸​reference_row dplyr::glimpse(ex3) #> Rows: 4 #> Columns: 16 #> $ term "Sepal.Width", "Speciessetosa", "Speciesversicolor", "S… #> $ variable "Sepal.Width", "Species", "Species", "Species" #> $ var_label "Sepal.Width", "Species", "Species", "Species" #> $ var_class "numeric", "factor", "factor", "factor" #> $ var_type "continuous", "categorical", "categorical", "categorica… #> $ var_nlevels NA, 3, 3, 3 #> $ contrasts NA, "contr.treatment", "contr.treatment", "contr.treatm… #> $ contrasts_type NA, "treatment", "treatment", "treatment" #> $ reference_row NA, TRUE, FALSE, FALSE #> $ label "Sepal.Width", "setosa", "versicolor", "virginica" #> $ estimate 0.8035609, NA, 1.4587431, 1.9468166 #> $ std.error 0.1063390, NA, 0.1121079, 0.1000150 #> $ statistic 7.556598, NA, 13.011954, 19.465255 #> $ p.value 4.187340e-12, NA, 3.478232e-26, 2.094475e-42 #> $ conf.low 0.5933983, NA, 1.2371791, 1.7491525 #> $ conf.high 1.013723, NA, 1.680307, 2.144481 ex4 <- mod2 %>% # perform initial tidying of model tidy_and_attach(exponentiate = TRUE) %>% # add variable labels, including a custom value for age tidy_add_variable_labels(labels = c(age = "Age in years")) %>% # add reference rows for categorical variables tidy_add_reference_rows() %>% # add a, estimate value of reference terms tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% # add header rows for categorical variables tidy_add_header_rows() ex4 #> # A tibble: 20 × 17 #> term varia…¹ var_l…² var_c…³ var_t…⁴ var_n…⁵ heade…⁶ contr…⁷ contr…⁸ refer…⁹ #> #> 1 (Int… (Inter… (Inter… interc… NA NA NA #> 2 age Age in… nmatri… contin… NA TRUE NA #> 3 poly… age Age in… nmatri… contin… NA FALSE NA #> 4 poly… age Age in… nmatri… contin… NA FALSE NA #> 5 poly… age Age in… nmatri… contin… NA FALSE NA #> 6 stage T Stage factor catego… 4 TRUE contr.… treatm… NA #> 7 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 8 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 9 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… TRUE #> 10 stag… stage T Stage factor catego… 4 FALSE contr.… treatm… FALSE #> 11 grade Grade factor catego… 3 TRUE contr.… sum NA #> 12 grad… grade Grade factor catego… 3 FALSE contr.… sum FALSE #> 13 grad… grade Grade factor catego… 3 FALSE contr.… sum FALSE #> 14 grad… grade Grade factor catego… 3 FALSE contr.… sum TRUE #> 15 trt Chemot… charac… dichot… 2 TRUE contr.… treatm… NA #> 16 trtD… trt Chemot… charac… dichot… 2 FALSE contr.… treatm… TRUE #> 17 trtD… trt Chemot… charac… dichot… 2 FALSE contr.… treatm… FALSE #> 18 grade:… Grade … intera… NA TRUE NA #> 19 grad… grade:… Grade … intera… NA FALSE NA #> 20 grad… grade:… Grade … intera… NA FALSE NA #> # … with 7 more variables: label , estimate , std.error , #> # statistic , p.value , conf.low , conf.high , and #> # abbreviated variable names ¹​variable, ²​var_label, ³​var_class, ⁴​var_type, #> # ⁵​var_nlevels, ⁶​header_row, ⁷​contrasts, ⁸​contrasts_type, ⁹​reference_row dplyr::glimpse(ex4) #> Rows: 20 #> Columns: 17 #> $ term "(Intercept)", NA, "poly(age, 3)1", "poly(age, 3)2", "p… #> $ variable "(Intercept)", "age", "age", "age", "age", "stage", "st… #> $ var_label "(Intercept)", "Age in years", "Age in years", "Age in … #> $ var_class NA, "nmatrix.3", "nmatrix.3", "nmatrix.3", "nmatrix.3",… #> $ var_type "intercept", "continuous", "continuous", "continuous", … #> $ var_nlevels NA, NA, NA, NA, NA, 4, 4, 4, 4, 4, 3, 3, 3, 3, 2, 2, 2,… #> $ header_row NA, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALS… #> $ contrasts NA, NA, NA, NA, NA, "contr.treatment(base=3)", "contr.t… #> $ contrasts_type NA, NA, NA, NA, NA, "treatment", "treatment", "treatmen… #> $ reference_row NA, NA, NA, NA, NA, NA, FALSE, FALSE, TRUE, FALSE, NA, … #> $ label "(Intercept)", "Age in years", "Age in years", "Age in … #> $ estimate 0.5266376, NA, 20.2416394, 1.2337899, 0.4931553, NA, 1.… #> $ std.error 0.4130930, NA, 2.3254455, 2.3512842, 2.3936657, NA, 0.4… #> $ statistic -1.55229592, NA, 1.29340459, 0.08935144, -0.29533409, N… #> $ p.value 0.1205914, NA, 0.1958712, 0.9288026, 0.7677387, NA, 0.9… #> $ conf.low 0.227717775, NA, 0.225454425, 0.007493208, 0.004745694,… #> $ conf.high 1.164600, NA, 2315.587655, 100.318341, 74.226179, NA, 2… ``` broom.helpers/data/0000755000176200001440000000000014464175037013755 5ustar liggesusersbroom.helpers/data/supported_models.rda0000644000176200001440000000220314464175055020032 0ustar liggesusersBZh91AY&SY'7Fe\w?@A@;lackRS53ROiЧP=MP =F)OPhqddd#F C@D=OH4hLLC!C@  d1 HL Lښh4 4H@p ћ2<*"V$'7x,5Mn AL0ÙԅFFt El$8ᬁcІ@chcBgpIG6mjNB`lfLx7i 61|Zl!۾TG;+H'Go՘r8CٟN!pQ1ee5VxXoi# &Naus*˽ckcd +[z}ġs.Lq5 0i"[&!(jX]@u=2B,#'/E-5Tjhw=;޾%3)] <1bXs (R|*'f3_&T!Ɔǵ)i"t&R L*sJ̊x[q. Fg2jRDlnf\ZYl 1˜'h #})ʫx6ҀF%:x kF`$nkO8E*.5' acK).RPbvT+KI>)iJs8gϲ͗eX E9p5T(9ΖL2hC!<5Q]t ZVBk;Zȅ eJEŰKDNN4,.b6;*jESc}GRsf3( \7e0C/H(W ݧrޑqt2L<ݤ:VXUɯDnlhK` #z)ȅ4\(WeT:@Q!7UUAq2aH tRbroom.helpers/man/0000755000176200001440000000000014464175037013617 5ustar liggesusersbroom.helpers/man/tidy_disambiguate_terms.Rd0000644000176200001440000000421114457461242021003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_disambiguate_terms.R \name{tidy_disambiguate_terms} \alias{tidy_disambiguate_terms} \title{Disambiguate terms} \usage{ tidy_disambiguate_terms(x, sep = ".", model = tidy_get_model(x), quiet = FALSE) } \arguments{ \item{x}{a tidy tibble} \item{sep}{character, separator added between group name and term} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} } \description{ For mixed models, the \code{term} column returned by \code{broom.mixed} may have duplicated values for random-effect parameters and random-effect values. In such case, the terms could be disambiguated be prefixing them with the value of the \code{group} column. \code{tidy_disambiguate_terms()} will not change any term if there is no \code{group} column in \code{x}. The original term value is kept in a new column \code{original_term}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if ( .assert_package("lme4", boolean = TRUE) && .assert_package("broom.mixed", boolean = TRUE) && .assert_package("gtsummary", boolean = TRUE) ) { mod <- lme4::lmer(marker ~ stage + (1 | grade) + (death | response), gtsummary::trial) mod \%>\% tidy_and_attach() \%>\% tidy_disambiguate_terms() } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_add_reference_rows.Rd0000644000176200001440000000720614463417025020757 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_reference_rows.R \name{tidy_add_reference_rows} \alias{tidy_add_reference_rows} \title{Add references rows for categorical variables} \usage{ tidy_add_reference_rows( x, no_reference_row = NULL, model = tidy_get_model(x), quiet = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{no_reference_row}{a vector indicating the name of variables for those no reference row should be added. Accepts \link[dplyr:select]{tidyselect} syntax. Default is \code{NULL}. See also \code{\link[=all_categorical]{all_categorical()}} and \code{\link[=all_dichotomous]{all_dichotomous()}}} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} } \description{ For categorical variables with a treatment contrast (\code{\link[stats:contrast]{stats::contr.treatment()}}), a SAS contrast (\code{\link[stats:contrast]{stats::contr.SAS()}}) a sum contrast (\code{\link[stats:contrast]{stats::contr.sum()}}), or successive differences contrast (\code{\link[MASS:contr.sdif]{MASS::contr.sdif()}}) add a reference row. } \details{ The added \code{reference_row} column will be equal to: \itemize{ \item \code{TRUE} for a reference row; \item \code{FALSE} for a normal row of a variable with a reference row; \item \code{NA} for variables without a reference row. } If the \code{contrasts} column is not yet available in \code{x}, \code{\link[=tidy_add_contrasts]{tidy_add_contrasts()}} will be automatically applied. \code{tidy_add_reference_rows()} will not populate the label of the reference term. It is therefore better to apply \code{\link[=tidy_add_term_labels]{tidy_add_term_labels()}} after \code{tidy_add_reference_rows()} rather than before. Similarly, it is better to apply \code{tidy_add_reference_rows()} before \code{\link[=tidy_add_n]{tidy_add_n()}}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("gtsummary", boolean = TRUE)) { df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) res <- df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.SAS") ) \%>\% tidy_and_attach() res \%>\% tidy_add_reference_rows() res \%>\% tidy_add_reference_rows(no_reference_row = all_dichotomous()) res \%>\% tidy_add_reference_rows(no_reference_row = "Class") glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) \%>\% tidy_and_attach() \%>\% tidy_add_reference_rows() } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_list_terms_levels.Rd0000644000176200001440000000706714463417025021032 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_list_terms_levels.R \name{model_list_terms_levels} \alias{model_list_terms_levels} \alias{model_list_terms_levels.default} \title{List levels of categorical terms} \usage{ model_list_terms_levels( model, label_pattern = "{level}", variable_labels = NULL, sdif_term_level = c("diff", "ratio") ) \method{model_list_terms_levels}{default}( model, label_pattern = "{level}", variable_labels = NULL, sdif_term_level = c("diff", "ratio") ) } \arguments{ \item{model}{a model object} \item{label_pattern}{a \link[glue:glue]{glue pattern} for term labels (see examples)} \item{variable_labels}{an optional named list or named vector of custom variable labels passed to \code{\link[=model_list_variables]{model_list_variables()}}} \item{sdif_term_level}{for successive differences contrasts, how should term levels be named? \code{"diff"} for \code{"B - A"} (default), \code{"ratio"} for \code{"B / A"}} } \value{ A tibble with ten columns: \itemize{ \item \code{variable}: variable \item \code{contrasts_type}: type of contrasts ("sum" or "treatment") \item \code{term}: term name \item \code{level}: term level \item \code{level_rank}: rank of the level \item \code{reference}: logical indicating which term is the reference level \item \code{reference_level}: level of the reference term \item \code{var_label}: variable label obtained with \code{\link[=model_list_variables]{model_list_variables()}} \item \code{var_nlevels}: number of levels in this variable \item \code{dichotomous}: logical indicating if the variable is dichotomous \item \code{label}: term label (by default equal to term level) The first nine columns can be used in \code{label_pattern}. } } \description{ Only for categorical variables with treatment, SAS, sum or successive differences contrasts (cf. \code{\link[MASS:contr.sdif]{MASS::contr.sdif()}}), and categorical variables with no contrast. } \examples{ glm( am ~ mpg + factor(cyl), data = mtcars, family = binomial, contrasts = list(`factor(cyl)` = contr.sum) ) \%>\% model_list_terms_levels() df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.helmert") ) mod \%>\% model_list_terms_levels() mod \%>\% model_list_terms_levels("{level} vs {reference_level}") mod \%>\% model_list_terms_levels("{variable} [{level} - {reference_level}]") mod \%>\% model_list_terms_levels( "{ifelse(reference, level, paste(level, '-', reference_level))}" ) } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_with_broom_or_parameters.Rd0000644000176200001440000000176614464175037022245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_with_broom_or_parameters} \alias{tidy_with_broom_or_parameters} \title{Tidy a model with broom or parameters} \usage{ tidy_with_broom_or_parameters(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{broom::tidy()} or \code{parameters::model_parameters()}} } \description{ Try to tidy a model with \code{broom::tidy()}. If it fails, will try to tidy the model using \code{parameters::model_parameters()} through \code{tidy_parameters()}. } \seealso{ Other custom_tieders: \code{\link{tidy_broom}()}, \code{\link{tidy_multgee}()}, \code{\link{tidy_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/assert_package.Rd0000644000176200001440000000473114357760764017077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/assert_package.R \name{assert_package} \alias{assert_package} \alias{.assert_package} \alias{.get_package_dependencies} \alias{.get_all_packages_dependencies} \alias{.get_min_version_required} \title{Check a package installation status or minimum required version} \usage{ .assert_package(pkg, fn = NULL, pkg_search = "broom.helpers", boolean = FALSE) .get_package_dependencies(pkg_search = "broom.helpers") .get_all_packages_dependencies( pkg_search = NULL, remove_duplicates = FALSE, lib.loc = NULL ) .get_min_version_required(pkg, pkg_search = "broom.helpers") } \arguments{ \item{pkg}{Package required} \item{fn}{Calling function from the user perspective. Used to write informative error messages.} \item{pkg_search}{the package the function will search for a minimum required version from.} \item{boolean}{logical indicating whether to return a \code{TRUE}/\code{FALSE}, rather than error when package/package version not available. Default is \code{FALSE}, which will return an error if \code{pkg} is not installed.} \item{remove_duplicates}{if several versions of a package are installed, should only the first one be returned?} \item{lib.loc}{location of \code{R} library trees to search through, see \code{utils::installed.packages()}.} } \value{ logical or error for \code{.assert_package()}, \code{NULL} or character with the minimum version required for \code{.get_min_version_required()}, a tibble for \code{.get_package_dependencies()}. } \description{ The function \code{.assert_package()} checks whether a package is installed and returns an error or \code{FALSE} if not available. If a package search is provided, the function will check whether a minimum version of a package is required. The function \code{.get_package_dependencies()} returns a tibble with all dependencies of a specific package. Finally, \code{.get_min_version_required()} will return, if any, the minimum version of \code{pkg} required by \code{pkg_search}, \code{NULL} if no minimum version required. } \details{ \code{get_all_packages_dependencies()} could be used to get the list of dependencies of all installed packages. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} .assert_package("broom", boolean = TRUE) .get_package_dependencies() .get_min_version_required("brms") \dontshow{\}) # examplesIf} } broom.helpers/man/tidy_marginal_contrasts.Rd0000644000176200001440000001603514370455163021033 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_marginal_contrasts} \alias{tidy_marginal_contrasts} \alias{variables_to_contrast} \title{Marginal Contrasts with \code{marginaleffects::avg_comparisons()}} \usage{ tidy_marginal_contrasts( x, variables_list = "auto", conf.int = TRUE, conf.level = 0.95, ... ) variables_to_contrast( model, interactions = TRUE, cross = FALSE, var_categorical = "reference", var_continuous = 1, by_categorical = unique, by_continuous = stats::fivenum ) } \arguments{ \item{x}{a model} \item{variables_list}{a list whose elements will be sequentially passed to \code{variables} in \code{marginaleffects::avg_comparisons()} (see details below); alternatively, it could also be the string \code{"auto"} (default), \code{"cross"} or \code{"no_interaction"}} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{marginaleffects::avg_comparisons()}} \item{model}{a model} \item{interactions}{should combinations of variables corresponding to interactions be returned?} \item{cross}{if \code{interaction} is \code{TRUE}, should "cross-contrasts" be computed? (if \code{FALSE}, only the last term of an interaction is passed to \code{variable} and the other terms are passed to \code{by})} \item{var_categorical}{default \code{variable} value for categorical variables} \item{var_continuous}{default \code{variable} value for continuous variables} \item{by_categorical}{default \code{by} value for categorical variables} \item{by_continuous}{default \code{by} value for continuous variables} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{marginaleffects::avg_comparisons()} to estimate marginal contrasts for each variable of a model and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{marginaleffects::avg_comparisons()} for a list of supported models. } \details{ Marginal contrasts are obtained by calling, for each variable or combination of variables, \code{marginaleffects::avg_comparisons()}. \code{tidy_marginal_contrasts()} will compute marginal contrasts for each variable or combination of variables, before stacking the results in a unique tibble. This is why \code{tidy_marginal_contrasts()} has a \code{variables_list} argument consisting of a list of specifications that will be passed sequentially to the \code{variables} and the \code{by} argument of \code{marginaleffects::avg_comparisons()}. Considering a single categorical variable named \code{cat}, \code{tidy_marginal_contrasts()} will call \code{avg_comparisons(model, variables = list(cat = "reference"))} to obtain average marginal contrasts for this variable. Considering a single continuous variable named \code{cont}, \code{tidy_marginalcontrasts()} will call \code{avg_comparisons(model, variables = list(cont = 1))} to obtain average marginal contrasts for an increase of one unit. For a combination of variables, there are several possibilities. You could compute "cross-contrasts" by providing simultaneously several variables to \code{variables} and specifying \code{cross = TRUE} to \code{marginaleffects::avg_comparisons()}. Alternatively, you could compute the contrasts of a first variable specified to \code{variables} for the different values of a second variable specified to \code{by}. The helper function \code{variables_to_contrast()} could be used to automatically generate a suitable list to be used with \code{variables_list}. Each combination of variables should be a list with two named elements: \code{"variables"} a list of named elements passed to \code{variables} and \code{"by"} a list of named elements used for creating a relevant \code{datagrid} and whose names are passed to \code{by}. \code{variables_list}'s default value, \code{"auto"}, calls \code{variables_to_contrast(interactions = TRUE, cross = FALSE)} while \code{"no_interaction"} is a shortcut for \code{variables_to_contrast(interactions = FALSE)}. \code{"cross"} calls \code{variables_to_contrast(interactions = TRUE, cross = TRUE)} You can also provide custom specifications (see examples). By default, \emph{average marginal contrasts} are computed: contrasts are computed using a counterfactual grid for each value of the variable of interest, before averaging the results. \emph{Marginal contrasts at the mean} could be obtained by indicating \code{newdata = "mean"}. Other assumptions are possible, see the help file of \code{marginaleffects::avg_comparisons()}. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Average Marginal Contrasts df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_marginal_contrasts(mod) tidy_plus_plus(mod, tidy_fun = tidy_marginal_contrasts) mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) tidy_marginal_contrasts(mod2) tidy_marginal_contrasts( mod2, variables_list = variables_to_predict( mod2, continuous = 3, categorical = "pairwise" ) ) # Model with interactions mod3 <- glm( Survived ~ Sex * Age + Class, data = df, family = binomial ) tidy_marginal_contrasts(mod3) tidy_marginal_contrasts(mod3, "no_interaction") tidy_marginal_contrasts(mod3, "cross") tidy_marginal_contrasts( mod3, variables_list = list( list(variables = list(Class = "pairwise"), by = list(Sex = unique)), list(variables = list(Age = "all")), list(variables = list(Class = "sequential", Sex = "reference")) ) ) mod4 <- lm(Sepal.Length ~ Petal.Length * Petal.Width + Species, data = iris) tidy_marginal_contrasts(mod4) tidy_marginal_contrasts( mod4, variables_list = list( list( variables = list(Species = "sequential"), by = list(Petal.Length = c(2, 5)) ), list( variables = list(Petal.Length = 2), by = list(Species = unique, Petal.Width = 2:4) ) ) ) # Marginal Contrasts at the Mean tidy_marginal_contrasts(mod, newdata = "mean") tidy_marginal_contrasts(mod3, newdata = "mean") \dontshow{\}) # examplesIf} } \seealso{ \code{marginaleffects::avg_comparisons()}, \code{tidy_avg_comparisons()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_terms.Rd0000644000176200001440000000400114464175037017252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_terms.R \name{model_get_terms} \alias{model_get_terms} \alias{model_get_terms.default} \alias{model_get_terms.brmsfit} \alias{model_get_terms.glmmTMB} \alias{model_get_terms.model_fit} \alias{model_get_terms.betareg} \title{Get the terms of a model} \usage{ model_get_terms(model) \method{model_get_terms}{default}(model) \method{model_get_terms}{brmsfit}(model) \method{model_get_terms}{glmmTMB}(model) \method{model_get_terms}{model_fit}(model) \method{model_get_terms}{betareg}(model) } \arguments{ \item{model}{a model object} } \description{ Return the result of \code{\link[stats:terms]{stats::terms()}} applied to the model or \code{NULL} if it is not possible to get terms from \code{model}. } \details{ For models fitted with \code{glmmTMB::glmmTMB()}, it will return a terms object taking into account all components ("cond" and "zi"). For a more restricted terms object, please refer to \code{glmmTMB::terms.glmmTMB()}. } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_terms() } \seealso{ \code{\link[stats:terms]{stats::terms()}} Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/supported_models.Rd0000644000176200001440000000702114464175037017476 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{supported_models} \alias{supported_models} \title{Listing of Supported Models} \format{ A data frame with one row per supported model \describe{ \item{model}{Model} \item{notes}{Notes} } } \usage{ supported_models } \description{ Listing of Supported Models } \section{Supported models}{ \tabular{ll}{ model \tab notes \cr \code{betareg::betareg()} \tab Use \code{tidy_parameters()} as \code{tidy_fun} with \code{component} argument to control with coefficients to return. \verb{broom::tidy() does not support the }exponentiate\verb{argument for betareg models, use}tidy_parameters() instead.` \cr \code{biglm::bigglm()} \tab \cr \code{biglmm::bigglm()} \tab \cr \code{brms::brm()} \tab \code{broom.mixed} package required \cr \code{cmprsk::crr()} \tab Limited support. It is recommended to use \code{tidycmprsk::crr()} instead. \cr \code{fixest::feglm()} \tab May fail with R <= 4.0. \cr \code{fixest::femlm()} \tab May fail with R <= 4.0. \cr \code{fixest::feNmlm()} \tab May fail with R <= 4.0. \cr \code{fixest::feols()} \tab May fail with R <= 4.0. \cr \code{gam::gam()} \tab \cr \code{geepack::geeglm()} \tab \cr \code{glmmTMB::glmmTMB()} \tab \code{broom.mixed} package required \cr \code{lavaan::lavaan()} \tab Limited support for categorical variables \cr \code{lfe::felm()} \tab \cr \code{lme4::glmer.nb()} \tab \code{broom.mixed} package required \cr \code{lme4::glmer()} \tab \code{broom.mixed} package required \cr \code{lme4::lmer()} \tab \code{broom.mixed} package required \cr \code{logitr::logitr()} \tab Requires logitr >= 0.8.0 \cr \code{MASS::glm.nb()} \tab \cr \code{MASS::polr()} \tab \cr \code{mgcv::gam()} \tab Use default tidier \code{broom::tidy()} for smooth terms only, or \code{gtsummary::tidy_gam()} to include parametric terms \cr \code{mice::mira} \tab Limited support. If \code{mod} is a \code{mira} object, use \code{tidy_plus_plus(mod, tidy_fun = function(x, ...) mice::pool(x) \%>\% mice::tidy(...))} \cr \code{multgee::nomLORgee()} \tab Experimental support. Use \code{tidy_multgee()} as \code{tidy_fun}. \cr \code{multgee::ordLORgee()} \tab Experimental support. Use \code{tidy_multgee()} as \code{tidy_fun}. \cr \code{nnet::multinom()} \tab \cr \code{ordinal::clm()} \tab Limited support for models with nominal predictors. \cr \code{ordinal::clmm()} \tab Limited support for models with nominal predictors. \cr \code{parsnip::model_fit} \tab Supported as long as the type of model and the engine is supported. \cr \code{plm::plm()} \tab \cr \code{pscl::hurdle()} \tab Use \code{tidy_zeroinfl()} as \code{tidy_fun}. \cr \code{pscl::zeroinfl()} \tab Use \code{tidy_zeroinfl()} as \code{tidy_fun}. \cr \code{rstanarm::stan_glm()} \tab \code{broom.mixed} package required \cr \code{stats::aov()} \tab Reference rows are not relevant for such models. \cr \code{stats::glm()} \tab \cr \code{stats::lm()} \tab \cr \code{stats::nls()} \tab Limited support \cr \code{survey::svycoxph()} \tab \cr \code{survey::svyglm()} \tab \cr \code{survey::svyolr()} \tab \cr \code{survival::clogit()} \tab \cr \code{survival::coxph()} \tab \cr \code{survival::survreg()} \tab \cr \code{tidycmprsk::crr()} \tab \cr \code{VGAM::vglm()} \tab Limited support. It is recommended to use \code{tidy_parameters()} as \code{tidy_fun}. \cr } } \keyword{datasets} broom.helpers/man/model_get_nlevels.Rd0000644000176200001440000000273414360056067017577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_nlevels.R \name{model_get_nlevels} \alias{model_get_nlevels} \alias{model_get_nlevels.default} \title{Get the number of levels for each factor used in \code{xlevels}} \usage{ model_get_nlevels(model) \method{model_get_nlevels}{default}(model) } \arguments{ \item{model}{a model object} } \value{ a tibble with two columns: \code{"variable"} and \code{"var_nlevels"} } \description{ Get the number of levels for each factor used in \code{xlevels} } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_nlevels() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/model_get_model_frame.Rd0000644000176200001440000000417514360056067020402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_model_frame.R \name{model_get_model_frame} \alias{model_get_model_frame} \alias{model_get_model_frame.default} \alias{model_get_model_frame.coxph} \alias{model_get_model_frame.survreg} \alias{model_get_model_frame.biglm} \alias{model_get_model_frame.model_fit} \alias{model_get_model_frame.fixest} \title{Get the model frame of a model} \usage{ model_get_model_frame(model) \method{model_get_model_frame}{default}(model) \method{model_get_model_frame}{coxph}(model) \method{model_get_model_frame}{survreg}(model) \method{model_get_model_frame}{biglm}(model) \method{model_get_model_frame}{model_fit}(model) \method{model_get_model_frame}{fixest}(model) } \arguments{ \item{model}{a model object} } \description{ The structure of the object returned by \code{\link[stats:model.frame]{stats::model.frame()}} could slightly differ for certain types of models. \code{model_get_model_frame()} will always return an object with the same data structure or \code{NULL} if it is not possible to compute model frame from \code{model}. } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_model_frame() \%>\% head() } \seealso{ \code{\link[stats:model.frame]{stats::model.frame()}} Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_add_pairwise_contrasts.Rd0000644000176200001440000001011114464175037021664 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_pairwise_contrasts.R \name{tidy_add_pairwise_contrasts} \alias{tidy_add_pairwise_contrasts} \title{Add pairwise contrasts for categorical variables} \usage{ tidy_add_pairwise_contrasts( x, variables = all_categorical(), keep_model_terms = FALSE, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = attr(x, "conf.level"), emmeans_args = list(), model = tidy_get_model(x), quiet = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{variables}{a vector indicating the name of variables for those pairwise contrasts should be added. Accepts \link[dplyr:select]{tidyselect} syntax. Default is \code{\link[=all_categorical]{all_categorical()}}} \item{keep_model_terms}{keep terms from the model?} \item{pairwise_reverse}{determines whether to use \code{"pairwise"} (if \code{TRUE}) or \code{"revpairwise"} (if \code{FALSE}), see \code{\link[emmeans:contrast]{emmeans::contrast()}}} \item{contrasts_adjust}{optional adjustment method when computing contrasts, see \code{\link[emmeans:contrast]{emmeans::contrast()}} (if \code{NULL}, use \code{emmeans} default)} \item{conf.level}{confidence level, by default use the value indicated previously in \code{\link[=tidy_and_attach]{tidy_and_attach()}}} \item{emmeans_args}{list of additional parameter to pass to \code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Computes pairwise contrasts with \code{\link[emmeans:emmeans]{emmeans::emmeans()}} and add them to the results tibble. Works only with models supported by \code{emmeans}, see \code{vignette("models", package = "emmeans")}. } \note{ If the \code{contrasts} column is not yet available in \code{x}, \code{\link[=tidy_add_contrasts]{tidy_add_contrasts()}} will be automatically applied. \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} For multi-components models, such as zero-inflated Poisson or beta regression, support of pairwise contrasts is still experimental. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("emmeans", boolean = TRUE)) { mod1 <- lm(Sepal.Length ~ Species, data = iris) mod1 \%>\% tidy_and_attach() \%>\% tidy_add_pairwise_contrasts() mod1 \%>\% tidy_and_attach() \%>\% tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) mod1 \%>\% tidy_and_attach() \%>\% tidy_add_pairwise_contrasts(keep_model_terms = TRUE) mod1 \%>\% tidy_and_attach() \%>\% tidy_add_pairwise_contrasts(contrasts_adjust = "none") if (.assert_package("gtsummary", boolean = TRUE)) { mod2 <- glm( response ~ age + trt + grade, data = gtsummary::trial, family = binomial ) mod2 \%>\% tidy_and_attach(exponentiate = TRUE) \%>\% tidy_add_pairwise_contrasts() } } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/dot-clean_backticks.Rd0000644000176200001440000000123114357760764017777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpers.R \name{.clean_backticks} \alias{.clean_backticks} \title{Remove backticks around variable names} \usage{ .clean_backticks(x, variable_names = x) } \arguments{ \item{x}{a character vector to be cleaned} \item{variable_names}{list of variable names, could be obtained with \link[=model_list_variables]{model_list_variables(only_variable = TRUE)} to properly take into account interaction only terms/variables} } \description{ Remove backticks around variable names } \seealso{ Other other_helpers: \code{\link{.escape_regex}()} } \concept{other_helpers} broom.helpers/man/model_identify_variables.Rd0000644000176200001440000000576714360056067021144 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_identify_variables.R \name{model_identify_variables} \alias{model_identify_variables} \alias{model_identify_variables.default} \alias{model_identify_variables.lavaan} \alias{model_identify_variables.aov} \alias{model_identify_variables.clm} \alias{model_identify_variables.clmm} \alias{model_identify_variables.gam} \alias{model_identify_variables.model_fit} \alias{model_identify_variables.logitr} \title{Identify for each coefficient of a model the corresponding variable} \usage{ model_identify_variables(model) \method{model_identify_variables}{default}(model) \method{model_identify_variables}{lavaan}(model) \method{model_identify_variables}{aov}(model) \method{model_identify_variables}{clm}(model) \method{model_identify_variables}{clmm}(model) \method{model_identify_variables}{gam}(model) \method{model_identify_variables}{model_fit}(model) \method{model_identify_variables}{logitr}(model) } \arguments{ \item{model}{a model object} } \value{ A tibble with four columns: \itemize{ \item \code{term}: coefficients of the model \item \code{variable}: the corresponding variable \item \code{var_class}: class of the variable (cf. \code{\link[stats:checkMFClasses]{stats::.MFclass()}}) \item \code{var_type}: \code{"continuous"}, \code{"dichotomous"} (categorical variable with 2 levels), \code{"categorical"} (categorical variable with 3 or more levels), \code{"intercept"} or \code{"interaction"} \item \code{var_nlevels}: number of original levels for categorical variables } } \description{ It will also identify interaction terms and intercept(s). } \examples{ Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% glm( Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial ) \%>\% model_identify_variables() iris \%>\% lm( Sepal.Length ~ poly(Sepal.Width, 2) + Species, data = ., contrasts = list(Species = contr.sum) ) \%>\% model_identify_variables() } \seealso{ \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_parameters.Rd0000644000176200001440000000275214464175037017310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_parameters} \alias{tidy_parameters} \title{Tidy a model with parameters package} \usage{ tidy_parameters(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{\link[parameters:model_parameters]{parameters::model_parameters()}}} } \description{ Use \code{\link[parameters:model_parameters]{parameters::model_parameters()}} to tidy a model and apply \code{parameters::standardize_names(style = "broom")} to the output } \note{ For \code{\link[betareg:betareg]{betareg::betareg()}}, the component column in the results is standardized with \code{\link[broom:reexports]{broom::tidy()}}, using \code{"mean"} and \code{"precision"} values. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("parameters", boolean = TRUE)) { lm(Sepal.Length ~ Sepal.Width + Species, data = iris) \%>\% tidy_parameters() } \dontshow{\}) # examplesIf} } \seealso{ Other custom_tieders: \code{\link{tidy_broom}()}, \code{\link{tidy_multgee}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/tidy_add_n.Rd0000644000176200001440000001356414457461242016213 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_n.R \name{tidy_add_n} \alias{tidy_add_n} \title{Add the (weighted) number of observations} \usage{ tidy_add_n(x, model = tidy_get_model(x)) } \arguments{ \item{x}{a tidy tibble} \item{model}{the corresponding model, if not attached to \code{x}} } \description{ Add the number of observations in a new column \code{n_obs}, taking into account any weights if they have been defined. } \details{ For continuous variables, it corresponds to all valid observations contributing to the model. For categorical variables coded with treatment or sum contrasts, each model term could be associated to only one level of the original categorical variable. Therefore, \code{n_obs} will correspond to the number of observations associated with that level. \code{n_obs} will also be computed for reference rows. For polynomial contrasts (defined with \code{\link[stats:contrast]{stats::contr.poly()}}), all levels will contribute to the computation of each model term. Therefore, \code{n_obs} will be equal to the total number of observations. For Helmert and custom contrasts, only rows contributing positively (i.e. with a positive contrast) to the computation of a term will be considered for estimating \code{n_obs}. The result could therefore be difficult to interpret. For a better understanding of which observations are taken into account to compute \code{n_obs} values, you could look at \code{\link[=model_compute_terms_contributions]{model_compute_terms_contributions()}}. For interaction terms, only rows contributing to all the terms of the interaction will be considered to compute \code{n_obs}. For binomial logistic models, \code{tidy_add_n()} will also return the corresponding number of events (\code{n_event}) for each term, taking into account any defined weights. Observed proportions could be obtained as \code{n_obs / n_event}. Similarly, a number of events will be computed for multinomial logistic models (\code{nnet::multinom()}) for each level of the outcome (\code{y.level}), corresponding to the number of observations equal to that outcome level. For Poisson models, \code{n_event} will be equal to the number of counts per term. In addition, a third column \code{exposure} will be computed. If no offset is defined, exposure is assumed to be equal to 1 (eventually multiplied by weights) per observation. If an offset is defined, \code{exposure} will be equal to the (weighted) sum of the exponential of the offset (as a reminder, to model the effect of \code{x} on the ratio \code{y / z}, a Poisson model will be defined as \code{glm(y ~ x + offset(log(z)), family = poisson)}). Observed rates could be obtained with \code{n_event / exposure}. For Cox models (\code{\link[survival:coxph]{survival::coxph()}}), an individual could be coded with several observations (several rows). \code{n_obs} will correspond to the weighted number of observations which could be different from the number of individuals. \code{tidy_add_n()} will also compute a (weighted) number of events (\code{n_event}) according to the definition of the \code{\link[survival:Surv]{survival::Surv()}} object. Exposure time is also returned in \code{exposure} column. It is equal to the (weighted) sum of the time variable if only one variable time is passed to \code{\link[survival:Surv]{survival::Surv()}}, and to the (weighted) sum of \code{time2 - time} if two time variables are defined in \code{\link[survival:Surv]{survival::Surv()}}. For competing risk regression models (\code{\link[tidycmprsk:crr]{tidycmprsk::crr()}}), \code{n_event} takes into account only the event of interest defined by \code{failcode.} The (weighted) total number of observations (\code{N_obs}), of events (\code{N_event}) and of exposure time (\code{Exposure}) are stored as attributes of the returned tibble. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} lm(Petal.Length ~ ., data = iris) \%>\% tidy_and_attach() \%>\% tidy_add_n() lm(Petal.Length ~ ., data = iris, contrasts = list(Species = contr.sum)) \%>\% tidy_and_attach() \%>\% tidy_add_n() lm(Petal.Length ~ ., data = iris, contrasts = list(Species = contr.poly)) \%>\% tidy_and_attach() \%>\% tidy_add_n() lm(Petal.Length ~ poly(Sepal.Length, 2), data = iris) \%>\% tidy_and_attach() \%>\% tidy_add_n() df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.helmert") ) \%>\% tidy_and_attach() \%>\% tidy_add_n() df \%>\% glm( Survived ~ Class * (Age:Sex), data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.helmert") ) \%>\% tidy_and_attach() \%>\% tidy_add_n() glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) \%>\% tidy_and_attach() \%>\% tidy_add_n() glm( response ~ trt * grade + offset(log(ttdeath)), gtsummary::trial, family = poisson ) \%>\% tidy_and_attach() \%>\% tidy_add_n() \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/dot-select_to_varnames.Rd0000644000176200001440000000221014357760764020552 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/select_utilities.R \name{.select_to_varnames} \alias{.select_to_varnames} \title{Variable selector} \usage{ .select_to_varnames( select, data = NULL, var_info = NULL, arg_name = NULL, select_single = FALSE ) } \arguments{ \item{select}{A single object selecting variables, e.g. \code{c(age, stage)}, \code{starts_with("age")}} \item{data}{A data frame to select columns from. Default is NULL} \item{var_info}{A data frame of variable names and attributes. May also pass a character vector of variable names. Default is NULL} \item{arg_name}{Optional string indicating the source argument name. This helps in the error messaging. Default is NULL.} \item{select_single}{Logical indicating whether the result must be a single variable. Default is \code{FALSE}} } \value{ A character vector of variable names } \description{ Function takes \code{select()}-like inputs and converts the selector to a character vector of variable names. Functions accepts tidyselect syntax, and additional selector functions defined within the package } broom.helpers/man/tidy_marginal_predictions.Rd0000644000176200001440000001560514370455163021340 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_marginal_predictions} \alias{tidy_marginal_predictions} \alias{variables_to_predict} \alias{plot_marginal_predictions} \title{Marginal Predictions with \code{marginaleffects::avg_predictions()}} \usage{ tidy_marginal_predictions( x, variables_list = "auto", conf.int = TRUE, conf.level = 0.95, ... ) variables_to_predict( model, interactions = TRUE, categorical = unique, continuous = stats::fivenum ) plot_marginal_predictions(x, variables_list = "auto", conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{variables_list}{a list whose elements will be sequentially passed to \code{variables} in \code{marginaleffects::avg_predictions()} (see details below); alternatively, it could also be the string \code{"auto"} (default) or \code{"no_interaction"}} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{marginaleffects::avg_predictions()}} \item{model}{a model} \item{interactions}{should combinations of variables corresponding to interactions be returned?} \item{categorical}{default value for categorical variables} \item{continuous}{default value for continuous variables} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{marginaleffects::avg_predictions()} to estimate marginal predictions for each variable of a model and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{marginaleffects::avg_predictions()} for a list of supported models. } \details{ Marginal predictions are obtained by calling, for each variable, \code{marginaleffects::avg_predictions()} with the same variable being used for the \code{variables} and the \code{by} argument. Considering a categorical variable named \code{cat}, \code{tidy_marginal_predictions()} will call \code{avg_predictions(model, variables = list(cat = unique), by = "cat")} to obtain average marginal predictions for this variable. Considering a continuous variable named \code{cont}, \code{tidy_marginal_predictions()} will call \code{avg_predictions(model, variables = list(cont = "fivenum"), by = "cont")} to obtain average marginal predictions for this variable at the minimum, the first quartile, the median, the third quartile and the maximum of the observed values of \code{cont}. By default, \emph{average marginal predictions} are computed: predictions are made using a counterfactual grid for each value of the variable of interest, before averaging the results. \emph{Marginal predictions at the mean} could be obtained by indicating \code{newdata = "mean"}. Other assumptions are possible, see the help file of \code{marginaleffects::avg_predictions()}. \code{tidy_marginal_predictions()} will compute marginal predictions for each variable or combination of variables, before stacking the results in a unique tibble. This is why \code{tidy_marginal_predictions()} has a \code{variables_list} argument consisting of a list of specifications that will be passed sequentially to the \code{variables} argument of \code{marginaleffects::avg_predictions()}. The helper function \code{variables_to_predict()} could be used to automatically generate a suitable list to be used with \code{variables_list}. By default, all unique values are retained for categorical variables and \code{fivenum} (i.e. Tukey's five numbers, minimum, quartiles and maximum) for continuous variables. When \code{interactions = FALSE}, \code{variables_to_predict()} will return a list of all individual variables used in the model. If \code{interactions = FALSE}, it will search for higher order combinations of variables (see \code{model_list_higher_order_variables()}). \code{variables_list}'s default value, \code{"auto"}, calls \code{variables_to_predict(interactions = TRUE)} while \code{"no_interaction"} is a shortcut for \code{variables_to_predict(interactions = FALSE)}. You can also provide custom specifications (see examples). \code{plot_marginal_predictions()} works in a similar way and returns a list of plots that could be combined with \code{patchwork::wrap_plots()} (see examples). For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Average Marginal Predictions df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_marginal_predictions(mod) tidy_plus_plus(mod, tidy_fun = tidy_marginal_predictions) if (require("patchwork")) { plot_marginal_predictions(mod) \%>\% patchwork::wrap_plots() plot_marginal_predictions(mod) \%>\% patchwork::wrap_plots() & ggplot2::scale_y_continuous(limits = c(0, 1), label = scales::percent) } mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) tidy_marginal_predictions(mod2) if (require("patchwork")) { plot_marginal_predictions(mod2) \%>\% patchwork::wrap_plots() } tidy_marginal_predictions( mod2, variables_list = variables_to_predict(mod2, continuous = "threenum") ) tidy_marginal_predictions( mod2, variables_list = list( list(Petal.Width = c(0, 1, 2, 3)), list(Species = unique) ) ) tidy_marginal_predictions( mod2, variables_list = list(list(Species = unique, Petal.Width = 1:3)) ) # Model with interactions mod3 <- glm( Survived ~ Sex * Age + Class, data = df, family = binomial ) tidy_marginal_predictions(mod3) tidy_marginal_predictions(mod3, "no_interaction") if (require("patchwork")) { plot_marginal_predictions(mod3) \%>\% patchwork::wrap_plots() plot_marginal_predictions(mod3, "no_interaction") \%>\% patchwork::wrap_plots() } tidy_marginal_predictions( mod3, variables_list = list( list(Class = unique, Sex = "Female"), list(Age = unique) ) ) # Marginal Predictions at the Mean tidy_marginal_predictions(mod, newdata = "mean") if (require("patchwork")) { plot_marginal_predictions(mod, newdata = "mean") \%>\% patchwork::wrap_plots() } \dontshow{\}) # examplesIf} } \seealso{ \code{marginaleffects::avg_predictions()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_assign.Rd0000644000176200001440000000320714360056067017407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_assign.R \name{model_get_assign} \alias{model_get_assign} \alias{model_get_assign.default} \alias{model_get_assign.vglm} \alias{model_get_assign.model_fit} \title{Get the assign attribute of model matrix of a model} \usage{ model_get_assign(model) \method{model_get_assign}{default}(model) \method{model_get_assign}{vglm}(model) \method{model_get_assign}{model_fit}(model) } \arguments{ \item{model}{a model object} } \description{ Return the assign attribute attached to the object returned by \code{\link[stats:model.matrix]{stats::model.matrix()}}. } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_assign() } \seealso{ \code{\link[stats:model.matrix]{stats::model.matrix()}} Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/model_list_contrasts.Rd0000644000176200001440000000375114463417025020342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_list_contrasts.R \name{model_list_contrasts} \alias{model_list_contrasts} \alias{model_list_contrasts.default} \title{List contrasts used by a model} \usage{ model_list_contrasts(model) \method{model_list_contrasts}{default}(model) } \arguments{ \item{model}{a model object} } \value{ A tibble with three columns: \itemize{ \item \code{variable}: variable name \item \code{contrasts}: contrasts used \item \code{contrasts_type}: type of contrasts ("treatment", "sum", "poly", "helmert", "sdiff, "other" or "no.contrast") \item \code{reference}: for variables with treatment, SAS or sum contrasts, position of the reference level } } \description{ List contrasts used by a model } \details{ For models with no intercept, no contrasts will be applied to one of the categorical variable. In such case, one dummy term will be returned for each level of the categorical variable. } \examples{ glm( am ~ mpg + factor(cyl), data = mtcars, family = binomial, contrasts = list(`factor(cyl)` = contr.sum) ) \%>\% model_list_contrasts() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/dot-generic_selector.Rd0000644000176200001440000000175214357760764020223 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/select_utilities.R \name{.generic_selector} \alias{.generic_selector} \alias{.is_selector_scoped} \title{Generate a custom selector function} \usage{ .generic_selector(variable_column, select_column, select_expr, fun_name) .is_selector_scoped(variable_column, select_column) } \arguments{ \item{variable_column}{string indicating column variable names are stored} \item{select_column}{character vector of columns used in the \verb{select_expr=} argument} \item{select_expr}{unquoted predicate command to subset a data frame to select variables} \item{fun_name}{quoted name of function where \code{.generic_selector()} is being used. This helps with error messaging.} } \value{ custom selector functions } \description{ Generate a custom selector function } \details{ \code{.is_selector_scoped()} checks if a selector has been properly registered in \code{env_variable_type$df_var_info}. } broom.helpers/man/tidy_add_header_rows.Rd0000644000176200001440000000715714457461241020260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_header_rows.R \name{tidy_add_header_rows} \alias{tidy_add_header_rows} \title{Add header rows variables with several terms} \usage{ tidy_add_header_rows( x, show_single_row = NULL, model = tidy_get_model(x), quiet = FALSE, strict = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{show_single_row}{a vector indicating the names of binary variables that should be displayed on a single row. Accepts \link[dplyr:select]{tidyselect} syntax. Default is \code{NULL}. See also \code{\link[=all_dichotomous]{all_dichotomous()}}} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} \item{strict}{logical argument whether broom.helpers should return an error when requested output cannot be generated. Default is \code{FALSE}} } \description{ For variables with several terms (usually categorical variables but could also be the case of continuous variables with polynomial terms or splines), \code{tidy_add_header_rows()} will add an additional row per variable, where \code{label} will be equal to \code{var_label}. These additional rows could be identified with \code{header_row} column. } \details{ The \code{show_single_row} argument allows to specify a list of dichotomous variables that should be displayed on a single row instead of two rows. The added \code{header_row} column will be equal to: \itemize{ \item \code{TRUE} for an header row; \item \code{FALSE} for a normal row of a variable with an header row; \item \code{NA} for variables without an header row. } If the \code{label} column is not yet available in \code{x}, \code{\link[=tidy_add_term_labels]{tidy_add_term_labels()}} will be automatically applied. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("gtsummary", boolean = TRUE)) { df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) res <- df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.SAS") ) \%>\% tidy_and_attach() \%>\% tidy_add_variable_labels(labels = list(Class = "Custom label for Class")) \%>\% tidy_add_reference_rows() res \%>\% tidy_add_header_rows() res \%>\% tidy_add_header_rows(show_single_row = all_dichotomous()) glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) \%>\% tidy_and_attach() \%>\% tidy_add_reference_rows() \%>\% tidy_add_header_rows() } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_get_coefficients_type.Rd0000644000176200001440000000646414360056067021635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_coefficients_type.R \name{model_get_coefficients_type} \alias{model_get_coefficients_type} \alias{model_get_coefficients_type.default} \alias{model_get_coefficients_type.glm} \alias{model_get_coefficients_type.negbin} \alias{model_get_coefficients_type.geeglm} \alias{model_get_coefficients_type.fixest} \alias{model_get_coefficients_type.biglm} \alias{model_get_coefficients_type.glmerMod} \alias{model_get_coefficients_type.clogit} \alias{model_get_coefficients_type.polr} \alias{model_get_coefficients_type.multinom} \alias{model_get_coefficients_type.svyolr} \alias{model_get_coefficients_type.clm} \alias{model_get_coefficients_type.clmm} \alias{model_get_coefficients_type.coxph} \alias{model_get_coefficients_type.crr} \alias{model_get_coefficients_type.tidycrr} \alias{model_get_coefficients_type.model_fit} \alias{model_get_coefficients_type.LORgee} \title{Get coefficient type} \usage{ model_get_coefficients_type(model) \method{model_get_coefficients_type}{default}(model) \method{model_get_coefficients_type}{glm}(model) \method{model_get_coefficients_type}{negbin}(model) \method{model_get_coefficients_type}{geeglm}(model) \method{model_get_coefficients_type}{fixest}(model) \method{model_get_coefficients_type}{biglm}(model) \method{model_get_coefficients_type}{glmerMod}(model) \method{model_get_coefficients_type}{clogit}(model) \method{model_get_coefficients_type}{polr}(model) \method{model_get_coefficients_type}{multinom}(model) \method{model_get_coefficients_type}{svyolr}(model) \method{model_get_coefficients_type}{clm}(model) \method{model_get_coefficients_type}{clmm}(model) \method{model_get_coefficients_type}{coxph}(model) \method{model_get_coefficients_type}{crr}(model) \method{model_get_coefficients_type}{tidycrr}(model) \method{model_get_coefficients_type}{model_fit}(model) \method{model_get_coefficients_type}{LORgee}(model) } \arguments{ \item{model}{a model object} } \description{ Indicate the type of coefficient among "generic", "logistic", "poisson", "relative_risk" or "prop_hazard". } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_coefficients_type() Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) \%>\% model_get_coefficients_type() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_attach_model.Rd0000644000176200001440000000502214357760764017572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_and_attach.R \name{tidy_attach_model} \alias{tidy_attach_model} \alias{tidy_and_attach} \alias{tidy_get_model} \alias{tidy_detach_model} \title{Attach a full model to the tibble of model terms} \usage{ tidy_attach_model(x, model, .attributes = NULL) tidy_and_attach( model, tidy_fun = tidy_with_broom_or_parameters, conf.int = TRUE, conf.level = 0.95, exponentiate = FALSE, ... ) tidy_get_model(x) tidy_detach_model(x) } \arguments{ \item{x}{a tibble of model terms} \item{model}{a model to be attached/tidied} \item{.attributes}{named list of additional attributes to be attached to \code{x}} \item{tidy_fun}{option to specify a custom tidier function} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{level of confidence for confidence intervals (default: 95\%)} \item{exponentiate}{logical indicating whether or not to exponentiate the coefficient estimates. This is typical for logistic, Poisson and Cox models, but a bad idea if there is no log or logit link; defaults to \code{FALSE}} \item{...}{other arguments passed to \code{tidy_fun()}} } \description{ To facilitate the use of broom helpers with pipe, it is recommended to attach the original model as an attribute to the tibble of model terms generated by \code{broom::tidy()}. } \details{ \code{tidy_attach_model()} attach the model to a tibble already generated while \code{tidy_and_attach()} will apply \code{broom::tidy()} and attach the model. Use \code{tidy_get_model()} to get the model attached to the tibble and \code{tidy_detach_model()} to remove the attribute containing the model. } \examples{ mod <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) tt <- mod \%>\% tidy_and_attach(conf.int = TRUE) tt tidy_get_model(tt) } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_plus_plus.Rd0000644000176200001440000001731414457461243017172 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_plus_plus.R \name{tidy_plus_plus} \alias{tidy_plus_plus} \title{Tidy a model and compute additional informations} \usage{ tidy_plus_plus( model, tidy_fun = tidy_with_broom_or_parameters, conf.int = TRUE, conf.level = 0.95, exponentiate = FALSE, variable_labels = NULL, term_labels = NULL, interaction_sep = " * ", categorical_terms_pattern = "{level}", disambiguate_terms = TRUE, disambiguate_sep = ".", add_reference_rows = TRUE, no_reference_row = NULL, add_pairwise_contrasts = FALSE, pairwise_variables = all_categorical(), keep_model_terms = FALSE, pairwise_reverse = TRUE, contrasts_adjust = NULL, emmeans_args = list(), add_estimate_to_reference_rows = TRUE, add_header_rows = FALSE, show_single_row = NULL, add_n = TRUE, intercept = FALSE, include = everything(), keep_model = FALSE, quiet = FALSE, strict = FALSE, ... ) } \arguments{ \item{model}{a model to be attached/tidied} \item{tidy_fun}{option to specify a custom tidier function} \item{conf.int}{should confidence intervals be computed? (see \code{\link[broom:reexports]{broom::tidy()}})} \item{conf.level}{level of confidence for confidence intervals (default: 95\%)} \item{exponentiate}{logical indicating whether or not to exponentiate the coefficient estimates. This is typical for logistic, Poisson and Cox models, but a bad idea if there is no log or logit link; defaults to \code{FALSE}.} \item{variable_labels}{a named list or a named vector of custom variable labels} \item{term_labels}{a named list or a named vector of custom term labels} \item{interaction_sep}{separator for interaction terms} \item{categorical_terms_pattern}{a \link[glue:glue]{glue pattern} for labels of categorical terms with treatment or sum contrasts (see \code{\link[=model_list_terms_levels]{model_list_terms_levels()}})} \item{disambiguate_terms}{should terms be disambiguated with \code{\link[=tidy_disambiguate_terms]{tidy_disambiguate_terms()}}? (default \code{TRUE})} \item{disambiguate_sep}{separator for \code{\link[=tidy_disambiguate_terms]{tidy_disambiguate_terms()}}} \item{add_reference_rows}{should reference rows be added?} \item{no_reference_row}{variables (accepts \link[dplyr:select]{tidyselect} notation) for those no reference row should be added, when \code{add_reference_rows = TRUE}} \item{add_pairwise_contrasts}{apply \code{\link[=tidy_add_pairwise_contrasts]{tidy_add_pairwise_contrasts()}}? \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}} \item{pairwise_variables}{variables to add pairwise contrasts (accepts \link[dplyr:select]{tidyselect} notation)} \item{keep_model_terms}{keep original model terms for variables where pairwise contrasts are added? (default is \code{FALSE})} \item{pairwise_reverse}{determines whether to use \code{"pairwise"} (if \code{TRUE}) or \code{"revpairwise"} (if \code{FALSE}), see \code{\link[emmeans:contrast]{emmeans::contrast()}}} \item{contrasts_adjust}{optional adjustment method when computing contrasts, see \code{\link[emmeans:contrast]{emmeans::contrast()}} (if \code{NULL}, use \code{emmeans} default)} \item{emmeans_args}{list of additional parameter to pass to \code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts} \item{add_estimate_to_reference_rows}{should an estimate value be added to reference rows?} \item{add_header_rows}{should header rows be added?} \item{show_single_row}{variables that should be displayed on a single row (accepts \link[dplyr:select]{tidyselect} notation), when \code{add_header_rows} is \code{TRUE}} \item{add_n}{should the number of observations be added?} \item{intercept}{should the intercept(s) be included?} \item{include}{variables to include. Accepts \link[dplyr:select]{tidyselect} syntax. Use \code{-} to remove a variable. Default is \code{everything()}. See also \code{\link[=all_continuous]{all_continuous()}}, \code{\link[=all_categorical]{all_categorical()}}, \code{\link[=all_dichotomous]{all_dichotomous()}} and \code{\link[=all_interaction]{all_interaction()}}} \item{keep_model}{should the model be kept as an attribute of the final result?} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} \item{strict}{logical argument whether broom.helpers should return an error when requested output cannot be generated. Default is \code{FALSE}} \item{...}{other arguments passed to \code{tidy_fun()}} } \description{ This function will apply sequentially: \itemize{ \item \code{\link[=tidy_and_attach]{tidy_and_attach()}} \item \code{\link[=tidy_disambiguate_terms]{tidy_disambiguate_terms()}} \item \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} \item \code{\link[=tidy_add_contrasts]{tidy_add_contrasts()}} \item \code{\link[=tidy_add_reference_rows]{tidy_add_reference_rows()}} \item \code{\link[=tidy_add_pairwise_contrasts]{tidy_add_pairwise_contrasts()}} \item \code{\link[=tidy_add_estimate_to_reference_rows]{tidy_add_estimate_to_reference_rows()}} \item \code{\link[=tidy_add_variable_labels]{tidy_add_variable_labels()}} \item \code{\link[=tidy_add_term_labels]{tidy_add_term_labels()}} \item \code{\link[=tidy_add_header_rows]{tidy_add_header_rows()}} \item \code{\link[=tidy_add_n]{tidy_add_n()}} \item \code{\link[=tidy_remove_intercept]{tidy_remove_intercept()}} \item \code{\link[=tidy_select_variables]{tidy_select_variables()}} \item \code{\link[=tidy_add_coefficients_type]{tidy_add_coefficients_type()}} \item \code{\link[=tidy_detach_model]{tidy_detach_model()}} } } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} ex1 <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) \%>\% tidy_plus_plus() ex1 df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate( Survived = factor(Survived, c("No", "Yes")) ) \%>\% labelled::set_variable_labels( Class = "Passenger's class", Sex = "Gender" ) ex2 <- glm( Survived ~ Class + Age * Sex, data = df, weights = df$n, family = binomial ) \%>\% tidy_plus_plus( exponentiate = TRUE, add_reference_rows = FALSE, categorical_terms_pattern = "{level} / {reference_level}", add_n = TRUE ) ex2 if (.assert_package("gtsummary", boolean = TRUE)) { ex3 <- glm( response ~ poly(age, 3) + stage + grade * trt, na.omit(gtsummary::trial), family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.sum ) ) \%>\% tidy_plus_plus( exponentiate = TRUE, variable_labels = c(age = "Age (in years)"), add_header_rows = TRUE, show_single_row = all_dichotomous(), term_labels = c("poly(age, 3)3" = "Cubic age"), keep_model = TRUE ) ex3 } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_add_variable_labels.Rd0000644000176200001440000000516314357760764021073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_variable_labels.R \name{tidy_add_variable_labels} \alias{tidy_add_variable_labels} \title{Add variable labels} \usage{ tidy_add_variable_labels( x, labels = NULL, interaction_sep = " * ", model = tidy_get_model(x), quiet = FALSE, strict = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{labels}{an optional named list or named vector of custom variable labels} \item{interaction_sep}{separator for interaction terms} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} \item{strict}{logical argument whether broom.helpers should return an error when requested output cannot be generated. Default is \code{FALSE}} } \description{ Will add variable labels in a \code{var_label} column, based on: \enumerate{ \item labels provided in \code{labels} argument if provided; \item variable labels defined in the original data frame with the \code{label} attribute (cf. \code{\link[labelled:var_label]{labelled::var_label()}}); \item variable name otherwise. } } \details{ If the \code{variable} column is not yet available in \code{x}, \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} will be automatically applied. It is possible to pass a custom label for an interaction term in \code{labels} (see examples). } \examples{ df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% labelled::set_variable_labels( Class = "Passenger's class", Sex = "Sex" ) df \%>\% glm(Survived ~ Class * Age * Sex, data = ., weights = .$n, family = binomial) \%>\% tidy_and_attach() \%>\% tidy_add_variable_labels( labels = list( "(Intercept)" = "Custom intercept", Sex = "Gender", "Class:Age" = "Custom label" ) ) } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_get_model_matrix.Rd0000644000176200001440000000605514464175037020617 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_model_matrix.R \name{model_get_model_matrix} \alias{model_get_model_matrix} \alias{model_get_model_matrix.default} \alias{model_get_model_matrix.multinom} \alias{model_get_model_matrix.clm} \alias{model_get_model_matrix.brmsfit} \alias{model_get_model_matrix.glmmTMB} \alias{model_get_model_matrix.plm} \alias{model_get_model_matrix.biglm} \alias{model_get_model_matrix.model_fit} \alias{model_get_model_matrix.fixest} \alias{model_get_model_matrix.LORgee} \alias{model_get_model_matrix.betareg} \title{Get the model matrix of a model} \usage{ model_get_model_matrix(model, ...) \method{model_get_model_matrix}{default}(model, ...) \method{model_get_model_matrix}{multinom}(model, ...) \method{model_get_model_matrix}{clm}(model, ...) \method{model_get_model_matrix}{brmsfit}(model, ...) \method{model_get_model_matrix}{glmmTMB}(model, ...) \method{model_get_model_matrix}{plm}(model, ...) \method{model_get_model_matrix}{biglm}(model, ...) \method{model_get_model_matrix}{model_fit}(model, ...) \method{model_get_model_matrix}{fixest}(model, ...) \method{model_get_model_matrix}{LORgee}(model, ...) \method{model_get_model_matrix}{betareg}(model, ...) } \arguments{ \item{model}{a model object} \item{...}{additional arguments passed to \code{\link[stats:model.matrix]{stats::model.matrix()}}} } \description{ The structure of the object returned by \code{\link[stats:model.matrix]{stats::model.matrix()}} could slightly differ for certain types of models. \code{model_get_model_matrix()} will always return an object with the same structure as \code{\link[stats:model.matrix]{stats::model.matrix.default()}}. } \details{ For models fitted with \code{glmmTMB::glmmTMB()}, it will return a model matrix taking into account all components ("cond", "zi" and "disp"). For a more restricted model matrix, please refer to \code{glmmTMB::model.matrix.glmmTMB()}. For \code{\link[plm:plm]{plm::plm()}} models, constant columns are not removed. } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_model_matrix() \%>\% head() } \seealso{ \code{\link[stats:model.matrix]{stats::model.matrix()}} Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/select_helpers.Rd0000644000176200001440000000452314457461241017110 0ustar liggesusers% 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_dichotomous} \alias{all_categorical} \alias{all_interaction} \alias{all_ran_pars} \alias{all_ran_vals} \alias{all_intercepts} \alias{all_contrasts} \title{Select helper functions} \usage{ all_continuous() all_dichotomous() all_categorical(dichotomous = TRUE) all_interaction() all_ran_pars() all_ran_vals() all_intercepts() all_contrasts(contrasts_type = NULL) } \arguments{ \item{dichotomous}{Logical indicating whether to include dichotomous variables. 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_categorical()} selects categorical (including \code{"dichotomous"}) variables \item \code{all_dichotomous()} selects only type \code{"dichotomous"} \item \code{all_interaction()} selects interaction terms from a regression model \item \code{all_intercepts()} selects intercept terms from a regression model \item \code{all_contrasts()} selects variables in regression model based on their type of contrast \item \code{all_ran_pars()} and \code{all_ran_vals()} for random-effect parameters and values from a mixed model (see \code{vignette("broom_mixed_intro", package = "broom.mixed")}) } } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) \%>\% tidy_plus_plus(exponentiate = TRUE, include = all_categorical()) glm(response ~ age + trt + grade + stage, gtsummary::trial, family = binomial, contrasts = list(trt = contr.SAS, grade = contr.sum, stage = contr.poly) ) \%>\% tidy_plus_plus( exponentiate = TRUE, include = all_contrasts(c("treatment", "sum")) ) \dontshow{\}) # examplesIf} } broom.helpers/man/model_get_model.Rd0000644000176200001440000000306214360056067017222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_model.R \name{model_get_model} \alias{model_get_model} \alias{model_get_model.default} \alias{model_get_model.mira} \title{Get the model from model objects} \usage{ model_get_model(model) \method{model_get_model}{default}(model) \method{model_get_model}{mira}(model) } \arguments{ \item{model}{a model object} } \description{ Most model objects are proper R model objects. There are, however, some model objects that store the proper object internally (e.g. mice models). This function extracts that model object in those cases. } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_model() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/figures/0000755000176200001440000000000014357760764015273 5ustar liggesusersbroom.helpers/man/figures/lifecycle-defunct.svg0000644000176200001440000000170414357760764021403 0ustar liggesuserslifecyclelifecycledefunctdefunct broom.helpers/man/figures/lifecycle-maturing.svg0000644000176200001440000000170614357760764021603 0ustar liggesuserslifecyclelifecyclematuringmaturing broom.helpers/man/figures/broom.helpers.png0000644000176200001440000010005114357760764020555 0ustar liggesusersPNG  IHDRA9G pHYs ʱ4tEXtSoftwarewww.inkscape.org<"tEXtTitleRStudio_Hex 2016 v7 outlines}p} IDATxwULt.XEQJUX ^",X! ҥ;[ɜe)dfw]un&-s9ŬiC2[RHy_ yi]Eк" oHMUU#Rb m\S_Բ>" ?:Q 5 Jۍ\H<:s?hGD@'SevB"q?G.":}sczC[>A|/<{|Q9Q41Љ j#kx:U<10GDQ@'2 }*Fa>YGFA (D38L@}@HC CD@'2oˬWaQ0 ȁG}ۢD":MbK$kTFxE%2j "?D:38' pֵSJX߉&@j] N3gBRk1yF,ֵQ t"|ste~ p&C填ܿObN’Q~'FHպ KSr_m8.(1Љ44uHER1j]Kl;ERHǴ5RZJ7ElJ} t(:Tu= ۴E( lkkr!Lw/n!u t:$)7x[XNmZ"N!5okk&=׸MZWBDa6~pvCT<lJ~ t0p[X6Da@' 3:JEAۚ,9ZBdt t:0=Yk\% >Ժ"M!l%!vmM}RM !l[9ۖգdB=eʳ(ֺ"aImMOT,Ea%Ui% (@9CRCU@ֵx] v99(>+Jd1 ;b !2:ӆ$g$tbKIg]uP+QJ.* 7۴Nő DTG(&ksVGRHp;˰m/ؾjM+ tjizVhq^_$e Jc8UǍئ+:1 lu-$f9W!y?w:=9XM+ D0F[SՆF@1Y"Z5syp;"Z56D`S\3B[S![uDs{Ú%%زG\3RvVi%ؔA݄P@mMS4A.}QKދS{u6wԖf\~Ln栬P3{q狂ZWBMy 0#5UV4:yLVTKuW`غt<Z lJN1(mM3VV֥U\ R;M+ :Ŵgq[ZY Ѣk?ku)!)ܷ `~g٦bҷe֫O@ѺXkY=Pmg'%mZ Yu5H>mZCn t)h٪K!T ѦU "^?enN1mMc ۴E o L yֵxh[X6D@'Ú|ste~ 14ְM+Qt0p5 Uzs镰:ty)?*ؾ|&۴E %ۚi% :´!-U)_ZMۚi% /:ѶH]jXѨEQikkئ(|Klk_ئ;hk-ӼiaV1I7֔M+QD~k֔6Daf֔6Da&4vCbܶp6;{h]WXEg\k@b[Si%NQNlJt":Eᶦc4պo⥭iaV1gBRk&^ۚ#is<&ψҺM t ;c5MIg]mMc ۴RcS،̲<'Lۚ>i͗R7mZ)\lkJzSOcV t5%3DVW>i`SH֔ mZ+|6*:XmM{PKrHGԦUu |v!11mM5^lkJZ1Rb֋7~U7P1ۚmZqmMBc6]rDG֔ئ֔(ئ5})ZMZh٥ۚ!UiC[ֺ_K!7>{ aǨY-i]7lkJ(mZ`DqAa5%۴1)|YZS-!PmM)M+i&N=_Ӻo֔۴R41 mMmZ)k@Ǵ5}CzöD3RVEyOi] n Ǵ5}@cmMcVALyQ[ӾH\Rt(mZĽ&.Ժ򏁮sSe֕B5%=lJa@)5%lJ@!#5Mo:ZB3 `o Ke~׺:]G 8.ӺoӲтmM"mZ) t`[S"mZL+T@~` k]Lckhv7s5%"/ئ@ۚQ0ئaGۚQMM+y@5%0PM&^k]L<`GۚQM+AlkJDPAZ ۴F=֔pp˟wҺ*PM썈aĶD5i_ 0`[S"i? b[S"3i )۴z֔ mZKl<z֔bAil^62ZK|CmM냌&lkJD۹Mk`pL[;:lkJD56^ 5%xc6ҙF)pi]0cBcDҦUHyy?h]0c[S"ئx>Ѝִd|"AFjӪ'O+к-m)Q` Ҧ$Fsָ &NZ ۚMX)ψ>j]IU)QͱM>EbL^ByiB$i]OuNmMi]3<.xS&xlC֘t5%",iՏ C30 u-ް)mڱ[wÁ!#5uмq=NOѺMR)1"V۴\f bOI/g[S8߭|eJlUN"䦸ګ1mZ53>VX2J4D[NWlsh]Eنm)ŐALO'8lpૐ ÃmZ^Tyʹ5%oL NWE稛}pr+i.Cz ᖯCrkmM⛪J<8gfXgޓwϥrh0Hw|+ !(mMq1 k%K*qbw&EFT=ؽv6=۴FmM(xO_#r {-"۴Fa}$߀ĩZMZhٵ/2k] i(ؑIV+lf3J].Vv3`OԠRMk>֔$0Oйqc]V둯,)={lNU}zM ۴n}DxmM( ն-&e,)?Dnich ~l(۴mMȈf&;״i%L.>^EN6'5e0ئftZNSpi8ahxz7,8 (SU{㿝S 8ZL5;/jְhk-Mf+2EfSQEZT\& =mogmZTE#t5%" ϧSU' =Ē`GbF-X${= ¸ xchzᷪx)y0Zi$u4i5w luPfM5%" \1)HkTf[aK݄ ͫ:Yi miU?>wQ4_4jSUmM%T5%" {Manȵi kOQ!onۚ&iy./D&̳aTU27{߻Q,MkT=|l^*%Z[JIq={|ه7xY8g !ݪ#ZכmM( *qs6i`\JuoM[΃TuCS|)\mZklkJDa޼Q],}4xwԦ5@g[S"Uaf8ⳙsjV)ԷEt;ҕ)(۫u)ԨMkЁ>_Vpxw[SuζD4#9n2%xGǓ&-eEغ` v9ڴ93:MjT^%m݌z-EB);H} ADkAy`5G @ߠxl wa]B3./C5MJGNۮ'5'DDDU kڴ ȜaҒiIaï` 6VL^ByyBa U1[h|Nv W;1bj5Sucضh*<.f xumZ͐W@mM{JV!A: ia=R lkogq.6>uVE?~4jۑߎC3P<8WKsZ\xRg1މf"b-@5#I})ܳ~GY&%71w!eP#M:E3.pB\_aϳ~e7zH + uOUŝO?4̉ 5Cƍ:_(#@y<\,-8%djϨDg<۟z0?mۂ:_(#@fg0A3̣MTy>Dw3ccn\/R 0Qt5 |/ }XbkD퐊 ! ktc"y=|Z b)w-)tHn@1jdի3yL$3kH2:@ךP mi׫s/yuѣUw\oՑ(&K!p]7%r;Dgɠ[M{y F:}T, . CbLJ#KpLV(B@B1yBD%dgL:0Җ09uL Җ .(涱;as `b놴$ɔA0 @ Mv"c%\9Lq&0s<%kcɚx͉Ц\s!]z. 9m@evF=q?|a^sd8 t ajd SxZW%kc0c6k k7aMxqiG}>~,6 ,ԿruüQŒN%Dֲʛ脻&:kc`ѪuZRRpcAnhK) H={/0"AȩdITp~J~öΗ'ljD]hmK 9:<8͐aε t iBZ!NOyԧ䝮 aT3ciȰ $[fpz$J@S")D2 7Yz0IKWK pْ_OacB]Qv;?&K唺X)eDJX w>?di&tT&UAG^%nFr)GצD37(Q1U"q 6Ӥ￑Z5qU8iNRTLWx\״o|-^0'6U'sjpY}3.k`B߬9%f`"b D]sEERXҎa uUJ|>yP0?v H'p :ZQ}C`ps =ɂ_Q⧝Ӎ5zՄ0I$srR@5!N:@'90+pny^\w+ذmw/ۢXѫ *0c7V`^Oo*U^B=e0RPw{r߆46؃i.7X⚯7KKheFlR &\)xn}x*ۿh` va. SupZFN1Nh[3m,kۋU<܉vM,.laEtmfAô?MH ,ƏkzvzfW!.nf_u.$E?ԣT9X M6=#rmlKDu:" Z]8vp[xl3Mގ~m8^>;T7f?kr2gС0?6sex.t2yc, 8B' 43l.p $\; W1+U0F$c4KTۿ*ڽkXPՑ:1̕M\3+{`2 )0ϲ |=0_qȃ ~, *mf: L9LK3 VLÈn ~ e!VUIK{oqvQyb4'@Z!mi, YPZQAh׶ L@˔'oqoer H}6Vnd3eN ]lf#H iWv;ڪ=jBmLH{Z7o`# bP hQ+_qX=o7`d4rם]XP}h;7؋O/jπ Ցiπ@ZnJ. t2Hyq^9SK!04Pˡf]?|<NjDQ@'CxeD¼B03`לfßcv]T0ۚzłB:?N7oJ\?a\DYeX{UdF5 M5)t̹C:7OL"n Sչw}ke҇pKqk!PbL> !@'݊TW+'[tk &/A_ c{띈ƒN0UG#%RËFg9l^+( }x" t'an 4h{?gL6>lPC}wniABoWK i!yZ[;vVMtEKcx{ۈzPy>eg|":Fa<075cܠd:zV)7`xާ~[sw¯;x}}VAHD3ޝ>U`%mckL Щ)^/8/,y\U|9^ךWf.Mr/ֹQ08B'iU.oc%1U푄TXSqfo/؀ŞRשڷ KDG褩7I^^ͅ Bh=s ^N~}͜anrOR|\K^&F82]9L{xgZX\(4 tjet٣ T| ui tv`nOy40ډc\ڊ+xFc vxޣb`OFR>*@΅ ;ܸZn򾏸s+kpt?w΅<96jx񑐝q O fī *N,Y(8?£U\Uت{A& t";"ah+u>jseq %.-ū&T6gz80 xeَ֫y>>xYf4_QxpNr\{%~js[9R?6U |G9Z>g&T^ xg7(:}W=0H/8B'!CJg<RbL' #c|c`5N7n\*rA }.laȋ_KQy|8kZ"&E;ύ_}c'oq(?.ԫ|S-w1L͛`ƭ>yg"n$* ~4xd8|?Z2*vlW:(|tIQγ>> ZwϱjWV<6c~/zo|M,t?PuwW.i}˽>f6pvSCNQF?)ߑ7ܰ[8d|(aRpmpˀ^صgF>[YM:3q`un}ztID tV083wMG`*|ϱ[^Y}>.{~I[sW5LC"N^)ۣhݟ-bCws8*|n4I(_Q3Ł[;^%l3ys;"3=5:(r䓢H߫S;3F u9LʉkǿnyHD- ؖmche”R`3ѱz_~3\upE]B)"N~3ԅۣ;1 yη>y}f ;oAS{w=) ̷ "=_&_TH^ըV":rao OMp۠>yq׀m>7= uQq~#'g3+]cvQ0)hB p &^SgY^e<ņؖ)u\J/ WiҠ.n+%Q1)=>.zmJǿާ96؂Nw3 _Ms91)u.[C_6gcwu٥#]o|}{eΉRED*:EQyc$:xՎ4=Ю>l|tv(VEDE}> [vx 9?ejygݹe>y$́m"Sޟ_g~.!MDDENz_/?Eޯ՞Ԃ>vxb'늶)qXr͚4ORUD t]{c>.zoWrは1k!\sW@rR>}}HY QM3:4jOǿ/g}nK$=0Y-hmqD?X"{D7n\ /uI-G'0-jSҩ}*#p"Y!yrgkAeb̯ o 4~ןW-^xn\sYED@;M 2>|&.-GSbG˶{Ɠ%"-!>ۯ-|H?2 |6ymAVMlZ960ޛqF*"$^CB'F=\K^:/qI s620 UQ1)jxPÞI HO [Z[w^X.qɻ0'! t*Ex뙇B+@c›QXT8ԂfaQ)x.d^0;pJf{p{wth_%.+M[D*"z#4ԛ7i}|90{2'_D0ICUU)1n[fb]7`H0*ls{<ڇ>9ԭ?W %.{?f1D1NRןw8 E%v J:~=nt߼)xaNDb.\<\<< =&2U7O;aNdCy^?ΰG"K\^>kDttoˎ? Xqg9ىK=D*޷ 5~5 ?aN{KVqz5V-d>;DqNZ+W:1dcQ?KF?t/J0I\/E_} YI2̉tߕaH~bY9OPJ2nFu|VR"}n$Ü(.w2מ*1qڏ>ry9`Z0Umٝy} (/w)N؄ AQ<3>;~nU⋡)0LW+3fvm5$f(U~/njNY IDATĀqpaNDTPxUƄ?bQbbN0*:0'HcSLSW3$̟aNDaSCWm73̉(4 tiZ:ÜN1OPgQ1).D3D:ōhza. gQ0)D2ԃ Fމ DD`S܉D3̉Hk tK u9֑PVz3̉H/ׄxw u9YV<6g@޿6W~P0'"`h{<|6ycsV9: ˥s2̉(Z8Nt>1"@G3̉(jD暺s[S;#JiyE>IKIFJrR*|<&;3v-JLƭѥ0t< ~(UDO&}g1suP*ϼjSDDD1NDDDDD1NDDDDD1NDDDDD1NDDDDD1NDDDDD1ND1cQL@7MZ@; K Gq=b\جV4_ {+TV!!/梬 ŌLO S+*.QZV̴ٌdg飍{L&2RSBn[vc}(,.AjJp&<86ԩZIGJP^HNL@zu`k8b:YHOP^v݆3=B ;Rj!=5""T~/9|: _}7{>< Aycik.놡uзڋw> Θy=+/A.imZӅ)?ogf nK?@ڙa{@ڻ9?VcʋN|7?{&EYq%]~e_i?K}gwW_.;>>=N0*9/_QV{ꙓРnm9kR<{Xy[u6o/+K n:&E;xKm# sظu6O<sKJ7*́#}^ ןmUrJF' sr/ #:{gA\:`x@aTN[fY?" =O7́ʩ&L YWw=2x䅀 lBi :?^w=7`eۻ(5IH4z/AD@J vt^)%5 EHwMBB :yξygΜ9>,1wD}jpibn{1p3 _&pα1g>jYu6n #%5 }EZz_yM3́'Cc|9:>{̏\aUMs-8 2~GqgX5̬l>0nBߺ}lؾg/yfݾkJS{)~劣~NGߡ f7׉Ѷk7vxrK:I>s >6hss?zG]eff-z~ڤGt?Sb3O{ߪ3W!)[7B?gܼsKb;Qc>qw4P)j6k50aw(,Yc:6lۋaϲɾs8zU'=sKnf\h?i5M{DS,>[~M;-޸GHwM{nͻ"zzs |0[Ozc#Q̑{Һ j (U3?%5 aTP>([7cYZ?igHGJp:̏p+fIF~䟖ڴekN>2oIs,ɕ oVճyA;|Ҫ}ڔz9Hx}Obb~y8z sl}L]Xg/n:}`h)Y9l$[.t )iyjm_WFyi#/]&R*nbZ|x2{M¦]Jܯtȏsߊ_]de`˯L>iM-=tz?o >@ܺVÖlySz|5~Ϳ3F)b}RN,?LbnK*R\ѫGrJ*|7]h@20zU:l_J =??_T -BYҪ=[EhƆF|q+c* ~,X%vjCRT*EB%NHLƌ ^˕2==#A fP^eՓIb([8*+-X^ϱn8{m*|G7.魱2zʏұ?ju$_oT -oS2 ZfV6-ܮ 5vL\ص "fы$3/"[#lyq{P N0hEUju/PCǓ®Uؽ\صJٜt ']r@@)CY٘!p<1/ppjk n *0ܥz9æk:?O%gǩ86Gac)ybתqv |;gz&$owlǑ8v^ wϡ,VrG 7_APH0ïsmHVlۊZ˜A}qaJ^ \?zrmVo&9"Rfe*X а^-X4/֮f}OpX1('$Sp06:_Mm0nXG?_Ѧ+5t|O{v瓕T*nĤ޿QPkQg]bOBZ۲> Qۭzh4ڡ ~I(%&Xh0࣮.^VСMsX-#3f3oÈ~,կS1_RyޮKZ{#%vX0y3TPzܥk=u6 B{w_7ޫ7nЉu:˜A}3:z1%`aw5Įmb7_bpdc4Ky ^1:"EB08!_}C/Y>fxcNoZhy}Nعr k|PZͯMx+_kXu|SrRCf"u4W :U*l59h`^[TGx_]ڷuk|]]&y}neJCr ]R0.}[EqN_ o:V*'OKHL^ѐ/F VzsUiv kq QxF-Y+EM.!IzLr$ ,4.[z֯}[bM-s&͞WvN=$Gj;kX̵iî%_2>q"(YR׮-WvF_+UjU^Ce,mL.ڶ嫒ɁDFﮇFcrjTrALЦcLW{1ްw?,9fL.:dң}& 1eGCMc\7/զYc}gඁ5>fݿx䤑5MZʕ6MVv6< 3јI) ѠR9k7 c|2X(pO۔nU(9K0y~Q:>d'M/Fru ]y^nKڗH#g"'eJ! 5t xyI%/C%T\M!lJz~[qɋԉ;G>J},1U#ߵ)$F}{v5*^`r~?-c1aPVzr.G mD,>ۛJX䥮"c$"gE KH3%$XlQ//O@""Xy[6J"}//M?wR, )@cL`C ڤGhPXs[((YON{u4 ~߶LCZ9.5ݥ I},}V-z@ zP 6o % %.<./s? ݚ:fq)2Og$IxwɔQfM~c#>wFu1g=H2WzX~)< xJ/"]zF% E4Ng7[zXۙK,j woՖ{C5ۊ5G `3smܱ[v.ܺ{hg@UI8b %H=J|ιHs]C#tg}Q߉џ˙ZKiE#xN:ƈVoO|_{.f}M=>1 ]>n(gg ]ou /P1fe@RJbYN::cUdg[>a1g`EJ38d ҥ}L;Nǐf j_V}p놞-3,r֖øDFǦ NJ g 6"BeQm=Qq&#2C3g c w| + 40/9Ne./`?6PHbh#5p^緽Nf%zb\3ɳDfT3[*i}XJA{oA$-1$04&0JrVZ^!0_lLff8kΰcus.:Mo+Yώ`5v./=CQj`2,dCWoLtȜCɴJcpdĬ݄ϒɵ R r/U\:~XH8PuHom,"WIN )k#r).mkZ2yZo:ٹuCOIM?~?^ɘJgץBSrI6Hn d9!" Ja,$9]T"Xh }un@ZɀtH=.'R;>/{*{"R݀X:$<+Lbͻ/ٚ^qM}/ wɋL\~KrCE?k/וy7t5Ix p^Hb'Κ^ X˒KT%QE,(WuNjE@8{ׯ߾+t8zJrgV0/&Z2dnХ=$ʕr|C]&Uh:~Vj9pT,[Jry$L:pTtʖ,.ye(1J_{9f|b$7A].~V*#?֬2tnok?7GJeW M֓n̫6l|ppYZP뷚|}+x@:$?U=LHĢU?z <C9k"Cs({LG_y>^WkM(]/g'!Tr~ P/\m{$Ѥ^ڵn"ObbxpZz.GfM,o5},Oﲲs0iR}4o\_x ~Wv&FʿXGOmcAWJӶwfᓈ\a*_W¢UesWo|ęBvݚU$G;zM^!WfV6E O%1kMW` V9#688>nqӟ+4Ci#3d{i׺3ڤGskAgffh{u| N"GdIDAT(${&G#& M ھ6g:'n_w\ZЪ__}71k7 ܥkt4~}l}m pg-!1 /4Ѵ8]9yzn;qƬAv1򇟐.Ro߇´Q&=~öO,V!KKIʼnɴk'qhP囼OoL9'&>o4CJ0A5D>x0Yw| Vncxn/S>UqAVBzLn9KLnwy4x'ux˕Zo\&= lhe\ьEђ>NOb1yx?Ue/OoE.Gç&bԯKkw86 VH%$&c̮O{@Vrt:,MTzao A`q>ORdee[h:7nz';I.Q0z#yb<9<#&υFUi6` Р|(Q0j.\!9Ԟyv09މKۖ!;MBRv[/pELcK{@bEէ=6@捅 ,1ڥz"J,|YWAI b젏~_ZzS5sK4{N<|]yxuhl)iZ2gͶk34).M{'b'd$'-81ʕQEgg@icnDflZNFg%2#NwY];^وL3峞aB@@A̝[bQ7R3kgc6̡Gˇpp\ܼ9bҮu cן۸*yh4X:}ʕ*n’ciϋ1GzmhB⹪y,Ds' Cv6laJe.fiN76eg_%~ٖ~ɣp~sl8go4J0o7(hzQ*~8LM ,u^Ν`X2t//,:o4@ݚU}%y'Xʻ6z)\ݔB~X2mEWbNzbޤo9ۇsʡlcY8qE|[ҫR@4~z+Y~7Q(Wx2{m2Ŋc֢kW -XcJP@Ae >٢+_⭖ZU{'m4j5>؇7~i"FȪ<4 kc۰:܏"( bO2[~![T|Tw蹨adfQ5TdɪxY#!1of}1q$jN1)bAT M{Wq4zNMBFtҖ-Ӻ3M:ձ5vIGzF4j5 "0B˗FZ"'ݾ'^KWq~,TECPNuP]8sp:\߷,yzP FŦ=PRh" 5>j*"^\e3WU< H~Nob g{r .NSZ3 3^C)*.cz,T3zt"D@!y/x*YB!#;= =e!ѿsv/ge9Z\ "]2/~]m*}Bqoz}وGN8ƝyFןvHm욾%e _eg? ^"U!x.nY a]E[x' ݂P.N1wBWX B\..n]ˇ.V~WmaN[z gk31uBǸbMÎ2n@eI 92 W8g88ܘփ֡uzO_"bs;~W)'c>#%f{BDD+YWaVɍi}oTj]!Kq7/vXg᱉{F `lLQja^rcZC*GV`!8̔x\ޱIh6=cɛ- zx @xlLͧˇz %꾎u[!HdIBpq>ST:kvbu8KXt–z `Y>G)1Bd4ŚÀD0} =ۑhB1VVnL*iTB$߹Ar_lJ5:,2%V;içM[yE4Df=QhEB!)+%W \OoÀH [.Wѝ&V\vj:+st%acZ !ؖRcM9X}ݔΑkcG,ssp}*?( B9/ʎh5ǜa\`尨5s˹.sjG}%B},*w)'qa6lgr"xb,]R+e)nZ=qG՚Ks:|}CgrUG)1i%'X #lL'l($5ڳJ7xbZ !Dk =sTB$~/W5}K(-5wPqi%QzH("uERJiXB[o2rB!n)bM#ǚ: +gpL%ŴS)BUbMEQ Ǝƥ`< +a(Y JQ !epqN\ڶ iy9W8gjBQ݊k"zUZLk.mAJ!6t4.nY.%?cME =W\¡L\J!XS02i 1E =WlLg)w-yTi% )<|-i:lkt&p Dz DWQN+0TVBq<~\޶ &$$8=<Yr#);OTY1>BbZsJ T5K!EJ{,Fr*xyŘ)zUOg@kycJ!(=TQIRNs=]Fv rגJI1MBshOWЧ`VF&]QFBHCy ғ]J~9ÔTUI}^ː[p{Hqc|;罛bZ !Bɱ 1>$<"ؒ5\1B^T30bi%2ǚâ{.\X\ J!vXSǸ? ŝe؊K7\k8P/Jqv 50C5RXSGqbZ !v(TY%G@SW rגŴBcMqΑڍrhni%s)+zObZxbZ !XSఈĵr$ X!A}@1w3ޚLQ&ifQL+!R]kꬨ X#|:7JǚnWq>cMZa{}=TO!8 .wnĕ])6ִsTB$vHD1WX4+Ś: -{!%=c@1'*.o^ě{ecMzϠVB)=֔N]3nybZPT Ŵ(}PC<1_( w=yQL+!G鱦zUܢΊT:'OVBҵwqi2_>$w)Lӿ+rWjl\Mlfg#w-yQL+!bM5t;ˍieE15%5tY; @W(b+ 5]=)[QCw=C*9 rגŴ<k12܅j2y:@ kɋbZ Q6}NXXScDX6VR5t- ഠ0@E1(cMS9TBډk*:R+ŴBLQzGW@q»j B1kvԺK] y=i ܵE18cMoqFPPCW<1𗻞(Qz)O{Kqg)95t TlE5@SJK[B{Uq#؜q<㨡;!L%/i%:;F 8c|@xDnk!Ҩ;i%ukr]XSB E(ͲVBŚ{ĴFhJHkJ X39領VBXӵ\+pN1cv܅PCwN`LQ +g5 |;NG P/>ڢŴX)PCwQ+{TA?q-w-QL+qe5eآ|Ś&j.bZ q 5%riUa8 ŴXǜa Ś:=c4}*YURFDIuWCkyŴ'XS;Ek] q,jnbZ 1Ś%bJy3c#@1.mY$ō`1fUc] % ܘV$u¾JXSЉUbTQ14o]K~J7.@a˵r`+щ'宅8/j&ƴP]ZVXSKl8Ś[NlbZP)q3td#6bڪŴ'K|ܥWk/}xObkNfEzgxMZA1.bM;NiL,%/iu 59Nި:E1M錱YkJ^ġbzTqDi%RzZҤkrWB܇} n|Ŵs)=֔s J%w%PC'QrLeGRLB9wbY [@8XS"'jDvJ(=TG&&] qoЉbt/\Its LZVy(;z֞BjDVng|8j]K^8 5=A#BNi[3h`)}k=ُ5̀D=yfXd]!QC'ݵPZ=g42 i-ǚdXSdЉSVו;k9"ܵ":q*OcZg&w-yQLk.so(֔8j-ENDjĚ NZb:c(iP)!C 8=Ǵ6CFVJ5xv܅b je(?TZF67ߐI5tR-ᓑ%ŴO鱦 !V\BܒcZ+"..kGNrWB)@G n rג+ƴ*;֔e*݀N˒v] !B cq);ŴŚ Љ/ TZBHrb5%D9֖}RZRLJŕ]"XS▨-%S*Nᱦ:E%B@ 5iC(5tB|P0Hi}NӸy)R(I/=U1!Dn #wpUi`xSZstLcM (֔PC'Ā'ȪܵZI=ӪXS䜍 JB:!F]Lknd$?>mbM @  +L?䝝bZkʀ8C#o] !JF A1B^T38ܵ<Ê֬D\ݣXS1 ,JWBq 1X\ @Y˜V%ǚr;*q'+j;J[ŢN-ᓑ1q `iA&]ƴ*84 |H5%| ŠnAĘր25V5%ĵ)DTU3 /F0B:woV^)1=L!w)8;jHnL+YyQ)!6F  +ǼuCӪkJPC'Nej%ƴd3Ty܅⊨bgJiukJ}QC'j/kJcQC'ā RB16DȀ:!2RE%w-ākJQC'DF+zP]Z/qaX+!])*9w)"asp 3>3KQE͜y:! {9Hҫ5C×>'w1j(Ί!8DZ aAѿSvܵBC `3nsΆwJd qw QRq?2KW}*S  q1=K~cZZZeIKPC'ĉWspXBPC'p̀)xw0VbM q. qR=z X,3=ZB:!Nnu99|zXrwZ|ŶB:!."{H33|YǠQ +!.",*~z^Li1@E͜AW脸Uz01^O9]M>BQC'ą> a:/M8'sI;? IENDB`broom.helpers/man/figures/lifecycle-archived.svg0000644000176200001440000000170714357760764021543 0ustar liggesusers lifecyclelifecyclearchivedarchived broom.helpers/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000172614357760764023030 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated broom.helpers/man/figures/lifecycle-questioning.svg0000644000176200001440000000171414357760764022321 0ustar liggesuserslifecyclelifecyclequestioningquestioning broom.helpers/man/figures/lifecycle-superseded.svg0000644000176200001440000000171314357760764022116 0ustar liggesusers lifecyclelifecyclesupersededsuperseded broom.helpers/man/figures/broom.helpers.svg0000644000176200001440000004562514357760764020607 0ustar liggesusers image/svg+xml RStudio_Hex 2016 v7 outlines RStudio_Hex 2016 v7 outlines broom.helpers/man/figures/lifecycle-stable.svg0000644000176200001440000000167414357760764021233 0ustar liggesuserslifecyclelifecyclestablestable broom.helpers/man/figures/lifecycle-experimental.svg0000644000176200001440000000171614357760764022453 0ustar liggesuserslifecyclelifecycleexperimentalexperimental broom.helpers/man/figures/lifecycle-deprecated.svg0000644000176200001440000000171214357760764022052 0ustar liggesuserslifecyclelifecycledeprecateddeprecated broom.helpers/man/model_list_higher_order_variables.Rd0000644000176200001440000000341014360056067023004 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_list_higher_order_variables.R \name{model_list_higher_order_variables} \alias{model_list_higher_order_variables} \alias{model_list_higher_order_variables.default} \title{List higher order variables of a model} \usage{ model_list_higher_order_variables(model) \method{model_list_higher_order_variables}{default}(model) } \arguments{ \item{model}{a model object} } \description{ List higher order variables of a model } \examples{ lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) \%>\% model_list_higher_order_variables() mod <- glm( response ~ stage * grade + trt:stage, gtsummary::trial, family = binomial ) mod \%>\% model_list_higher_order_variables() mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_list_higher_order_variables() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/reexports.Rd0000644000176200001440000000203014357760764016144 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport.R \docType{import} \name{reexports} \alias{reexports} \alias{\%>\%} \alias{vars} \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:reexports]{num_range}}, \code{\link[dplyr:reexports]{one_of}}, \code{\link[dplyr:reexports]{starts_with}}, \code{\link[dplyr]{vars}}} }} broom.helpers/man/model_compute_terms_contributions.Rd0000644000176200001440000000550314360056067023135 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_compute_terms_contributions.R \name{model_compute_terms_contributions} \alias{model_compute_terms_contributions} \alias{model_compute_terms_contributions.default} \title{Compute a matrix of terms contributions} \usage{ model_compute_terms_contributions(model) \method{model_compute_terms_contributions}{default}(model) } \arguments{ \item{model}{a model object} } \description{ Used for \code{\link[=model_get_n]{model_get_n()}}. For each row and term, equal 1 if this row should be taken into account in the estimate of the number of observations, 0 otherwise. } \details{ This function does not cover \code{lavaan} models (\code{NULL} is returned). } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} mod <- lm(Sepal.Length ~ Sepal.Width, iris) mod \%>\% model_compute_terms_contributions() mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) mod \%>\% model_compute_terms_contributions() mod <- glm( response ~ stage * grade + trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sum, grade = contr.treatment(3, 2), trt = "contr.SAS" ) ) mod \%>\% model_compute_terms_contributions() mod <- glm( response ~ stage * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly) ) mod \%>\% model_compute_terms_contributions() mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_compute_terms_contributions() d <- dplyr::as_tibble(Titanic) \%>\% dplyr::group_by(Class, Sex, Age) \%>\% dplyr::summarise( n_survived = sum(n * (Survived == "Yes")), n_dead = sum(n * (Survived == "No")) ) mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) mod \%>\% model_compute_terms_contributions() \dontshow{\}) # examplesIf} } \seealso{ Other model_helpers: \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_add_estimate_to_reference_rows.Rd0000644000176200001440000000747714463417025023366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_estimate_to_reference_rows.R \name{tidy_add_estimate_to_reference_rows} \alias{tidy_add_estimate_to_reference_rows} \title{Add an estimate value to references rows for categorical variables} \usage{ tidy_add_estimate_to_reference_rows( x, exponentiate = attr(x, "exponentiate"), conf.level = attr(x, "conf.level"), model = tidy_get_model(x), quiet = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{exponentiate}{logical indicating whether or not to exponentiate the coefficient estimates. It should be consistent with the original call to \code{\link[broom:reexports]{broom::tidy()}}} \item{conf.level}{confidence level, by default use the value indicated previously in \code{\link[=tidy_and_attach]{tidy_and_attach()}}, used only for sum contrasts} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} } \description{ For categorical variables with a treatment contrast (\code{\link[stats:contrast]{stats::contr.treatment()}}) or a SAS contrast (\code{\link[stats:contrast]{stats::contr.SAS()}}), will add an estimate equal to \code{0} (or \code{1} if \code{exponentiate = TRUE}) to the reference row. } \details{ For categorical variables with a sum contrast (\code{\link[stats:contrast]{stats::contr.sum()}}), the estimate value of the reference row will be equal to the sum of all other coefficients multiplied by \code{-1} (eventually exponentiated if \code{exponentiate = TRUE}), and obtained with \code{emmeans::emmeans()}. The \code{emmeans} package should therefore be installed. For sum contrasts, the model coefficient corresponds to the difference of each level with the grand mean. For sum contrasts, confidence intervals and p-values will also be computed and added to the reference rows. For other variables, no change will be made. If the \code{reference_row} column is not yet available in \code{x}, \code{\link[=tidy_add_reference_rows]{tidy_add_reference_rows()}} will be automatically applied. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("gtsummary", boolean = TRUE) && .assert_package("emmeans", boolean = TRUE)) { df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(dplyr::across(where(is.character), factor)) df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.SAS") ) \%>\% tidy_and_attach(exponentiate = TRUE) \%>\% tidy_add_reference_rows() \%>\% tidy_add_estimate_to_reference_rows() glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) \%>\% tidy_and_attach() \%>\% tidy_add_reference_rows() \%>\% tidy_add_estimate_to_reference_rows() } \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_marginal_means.Rd0000644000176200001440000000460014370455163020111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_marginal_means} \alias{tidy_marginal_means} \title{Marginal Means with \code{marginaleffects::marginal_means()}} \usage{ tidy_marginal_means(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{marginaleffects::marginal_means()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{marginaleffects::marginal_means()} to estimate marginal means and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{marginaleffects::marginal_means()()} for a list of supported models. } \details{ \code{marginaleffects::marginal_means()} estimate marginal means: adjusted predictions, averaged across a grid of categorical predictors, holding other numeric predictors at their means. Please refer to the documentation page of \code{marginaleffects::marginal_means()}. Marginal means are defined only for categorical variables. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Average Marginal Means df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_marginal_means(mod) tidy_plus_plus(mod, tidy_fun = tidy_marginal_means) mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) tidy_marginal_means(mod2) \dontshow{\}) # examplesIf} } \seealso{ \code{marginaleffects::marginal_means()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/dot-formula_list_to_named_list.Rd0000644000176200001440000000371714357760764022313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/select_utilities.R \name{.formula_list_to_named_list} \alias{.formula_list_to_named_list} \title{Convert formula selector to a named list} \usage{ .formula_list_to_named_list( x, data = NULL, var_info = NULL, arg_name = NULL, select_single = FALSE, type_check = NULL, type_check_msg = NULL, null_allowed = TRUE ) } \arguments{ \item{x}{list of selecting formulas} \item{data}{A data frame to select columns from. Default is NULL} \item{var_info}{A data frame of variable names and attributes. May also pass a character vector of variable names. Default is NULL} \item{arg_name}{Optional string indicating the source argument name. This helps in the error messaging. Default is NULL.} \item{select_single}{Logical indicating whether the result must be a single variable. Default is \code{FALSE}} \item{type_check}{A predicate function that checks the elements passed on the RHS of the formulas in \verb{x=} (or the element in a named list) satisfy the function.} \item{type_check_msg}{When the \verb{type_check=} fails, the string provided here will be printed as the error message. When \code{NULL}, a generic error message will be printed.} \item{null_allowed}{Are \code{NULL} values accepted for the right hand side of formulas?} } \description{ Functions takes a list of formulas, a named list, or a combination of named elements with formula elements and returns a named list. For example, \code{list(age = 1, starts_with("stage") ~ 2)}. } \section{Shortcuts}{ A shortcut for specifying an option be applied to all columns/variables is omitting the LHS of the formula. For example, \code{list(~ 1)} is equivalent to passing \code{list(everything() ~ 1)}. Additionally, a single formula may be passed instead of placing a single formula in a list; e.g. \code{everything() ~ 1} is equivalent to passing \code{list(everything() ~ 1)} } broom.helpers/man/tidy_select_variables.Rd0000644000176200001440000000515614357760764020465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_select_variables.R \name{tidy_select_variables} \alias{tidy_select_variables} \title{Select variables to keep/drop} \usage{ tidy_select_variables(x, include = everything(), model = tidy_get_model(x)) } \arguments{ \item{x}{a tidy tibble} \item{include}{variables to include. Accepts \link[dplyr:select]{tidyselect} syntax. Use \code{-} to remove a variable. Default is \code{everything()}. See also \code{\link[=all_continuous]{all_continuous()}}, \code{\link[=all_categorical]{all_categorical()}}, \code{\link[=all_dichotomous]{all_dichotomous()}} and \code{\link[=all_interaction]{all_interaction()}}} \item{model}{the corresponding model, if not attached to \code{x}} } \value{ The \code{x} tibble limited to the included variables (and eventually the intercept), sorted according to the \code{include} parameter. } \description{ Will remove unselected variables from the results. To remove the intercept, use \code{\link[=tidy_remove_intercept]{tidy_remove_intercept()}}. } \details{ If the \code{variable} column is not yet available in \code{x}, \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} will be automatically applied. } \examples{ res <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived)) \%>\% glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) \%>\% tidy_and_attach() \%>\% tidy_identify_variables() res res \%>\% tidy_select_variables() res \%>\% tidy_select_variables(include = "Class") res \%>\% tidy_select_variables(include = -c("Age", "Sex")) res \%>\% tidy_select_variables(include = starts_with("A")) res \%>\% tidy_select_variables(include = all_categorical()) res \%>\% tidy_select_variables(include = all_dichotomous()) res \%>\% tidy_select_variables(include = all_interaction()) res \%>\% tidy_select_variables( include = c("Age", all_categorical(dichotomous = FALSE), all_interaction()) ) } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()} } \concept{tidy_helpers} broom.helpers/man/tidy_ggpredict.Rd0000644000176200001440000000437614370455163017116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_ggpredict} \alias{tidy_ggpredict} \title{Marginal Predictions with \code{ggeffects::ggpredict()}} \usage{ tidy_ggpredict(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{ggeffects::ggpredict()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{ggeffects::ggpredict()} to estimate marginal predictions and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \url{https://strengejacke.github.io/ggeffects/} for a list of supported models. } \details{ By default, \code{ggeffects::ggpredict()} estimate marginal predictions at the observed mean of continuous variables and at the first modality of categorical variables (regardless of the type of contrasts used in the model). For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \note{ By default, \code{ggeffects::ggpredict()} estimates marginal predictions for each individual variable, regardless of eventual interactions. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_ggpredict(mod) tidy_plus_plus(mod, tidy_fun = tidy_ggpredict) \dontshow{\}) # examplesIf} } \seealso{ \code{ggeffects::ggpredict()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_response.Rd0000644000176200001440000000446614360056067017771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_response.R \name{model_get_response} \alias{model_get_response} \alias{model_get_response.default} \alias{model_get_response.glm} \alias{model_get_response.glmerMod} \alias{model_get_response.model_fit} \title{Get model response} \usage{ model_get_response(model) \method{model_get_response}{default}(model) \method{model_get_response}{glm}(model) \method{model_get_response}{glmerMod}(model) \method{model_get_response}{model_fit}(model) } \arguments{ \item{model}{a model object} } \description{ This function does not cover \code{lavaan} models (\code{NULL} is returned). } \examples{ lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) \%>\% model_get_response() mod <- glm( response ~ stage * grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.treatment(3, 2), trt = "contr.SAS") ) mod \%>\% model_get_response() mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_get_response() d <- dplyr::as_tibble(Titanic) \%>\% dplyr::group_by(Class, Sex, Age) \%>\% dplyr::summarise( n_survived = sum(n * (Survived == "Yes")), n_dead = sum(n * (Survived == "No")) ) mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial, y = FALSE) mod \%>\% model_get_response() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/model_get_response_variable.Rd0000644000176200001440000000332014360056067021622 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_response_variable.R \name{model_get_response_variable} \alias{model_get_response_variable} \alias{model_get_response_variable.default} \title{Get the name of the response variable} \usage{ model_get_response_variable(model) \method{model_get_response_variable}{default}(model) } \arguments{ \item{model}{a model object} } \description{ Get the name of the response variable } \examples{ lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) \%>\% model_get_response_variable() mod <- glm( response ~ stage * grade + trt, gtsummary::trial, family = binomial ) mod \%>\% model_get_response_variable() mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_get_response_variable() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_avg_comparisons.Rd0000644000176200001440000000561514370455163020335 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_avg_comparisons} \alias{tidy_avg_comparisons} \title{Marginal Contrasts with \code{marginaleffects::avg_comparisons()}} \usage{ tidy_avg_comparisons(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{marginaleffects::avg_comparisons()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{marginaleffects::avg_comparisons()} to estimate marginal contrasts and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{marginaleffects::avg_comparisons()} for a list of supported models. } \details{ By default, \code{marginaleffects::avg_comparisons()} estimate average marginal contrasts: a contrast is computed for each observed value in the original dataset (counterfactual approach) before being averaged. Marginal Contrasts at the Mean could be computed by specifying \code{newdata = "mean"}. The \code{variables} argument can be used to select the contrasts to be computed. Please refer to the documentation page of \code{marginaleffects::avg_comparisons()}. See also \code{tidy_marginal_contrasts()} for taking into account interactions. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Average Marginal Contrasts df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_avg_comparisons(mod) tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons) mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) tidy_avg_comparisons(mod2) # Custumizing the type of contrasts tidy_avg_comparisons( mod2, variables = list(Petal.Width = 2, Species = "pairwise") ) # Marginal Contrasts at the Mean tidy_avg_comparisons(mod, newdata = "mean") tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons, newdata = "mean") \dontshow{\}) # examplesIf} } \seealso{ \code{marginaleffects::avg_comparisons()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/tidy_add_contrasts.Rd0000644000176200001440000000360214357760764020000 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_contrasts.R \name{tidy_add_contrasts} \alias{tidy_add_contrasts} \title{Add contrasts type for categorical variables} \usage{ tidy_add_contrasts(x, model = tidy_get_model(x), quiet = FALSE) } \arguments{ \item{x}{a tidy tibble} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when \code{tidy_disambiguate_terms()} was already applied} } \description{ Add a \code{contrasts} column corresponding to contrasts used for a categorical variable and a \code{contrasts_type} column equal to "treatment", "sum", "poly", "helmert", "other" or "no.contrast". } \details{ If the \code{variable} column is not yet available in \code{x}, \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} will be automatically applied. } \examples{ df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) df \%>\% glm( Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.helmert") ) \%>\% tidy_and_attach() \%>\% tidy_add_contrasts() } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_margins.Rd0000644000176200001440000000434214370455163016577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_margins} \alias{tidy_margins} \title{Average Marginal Effects with \code{margins::margins()}} \usage{ tidy_margins(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{margins::margins()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{margins::margins()} to estimate average marginal effects (AME) and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{margins::margins()} for a list of supported models. } \details{ By default, \code{margins::margins()} estimate average marginal effects (AME): an effect is computed for each observed value in the original dataset before being averaged. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \note{ When applying \code{margins::margins()}, custom contrasts are ignored. Treatment contrasts (\code{stats::contr.treatment()}) are applied to all categorical variables. Interactions are also ignored. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_margins(mod) tidy_plus_plus(mod, tidy_fun = tidy_margins) \dontshow{\}) # examplesIf} } \seealso{ \code{margins::margins()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()} } \concept{marginal_tieders} broom.helpers/man/model_list_variables.Rd0000644000176200001440000000716214457461241020274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_list_variables.R \name{model_list_variables} \alias{model_list_variables} \alias{model_list_variables.default} \alias{model_list_variables.lavaan} \alias{model_list_variables.logitr} \title{List all the variables used in a model} \usage{ model_list_variables( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE ) \method{model_list_variables}{default}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE ) \method{model_list_variables}{lavaan}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE ) \method{model_list_variables}{logitr}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE ) } \arguments{ \item{model}{a model object} \item{labels}{an optional named list or named vector of custom variable labels} \item{only_variable}{if \code{TRUE}, will return only "variable" column} \item{add_var_type}{if \code{TRUE}, add \code{var_nlevels} and \code{var_type} columns} } \value{ A tibble with three columns: \itemize{ \item \code{variable}: the corresponding variable \item \code{var_class}: class of the variable (cf. \code{\link[stats:checkMFClasses]{stats::.MFclass()}}) \item \code{label_attr}: variable label defined in the original data frame with the label attribute (cf. \code{\link[labelled:var_label]{labelled::var_label()}}) \item \code{var_label}: a variable label (by priority, \code{labels} if defined, \code{label_attr} if available, otherwise \code{variable}) } If \code{add_var_type = TRUE}: \itemize{ \item \code{var_type}: \code{"continuous"}, \code{"dichotomous"} (categorical variable with 2 levels), \code{"categorical"} (categorical variable with 3 or more levels), \code{"intercept"} or \code{"interaction"} \item \code{var_nlevels}: number of original levels for categorical variables } } \description{ Including variables used only in an interaction. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("gtsummary", boolean = TRUE)) { Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% glm( Survived ~ Class + Age:Sex, data = ., weights = .$n, family = binomial ) \%>\% model_list_variables() iris \%>\% lm( Sepal.Length ~ poly(Sepal.Width, 2) + Species, data = ., contrasts = list(Species = contr.sum) ) \%>\% model_list_variables() glm( response ~ poly(age, 3) + stage + grade * trt, na.omit(gtsummary::trial), family = binomial, ) \%>\% model_list_variables() } \dontshow{\}) # examplesIf} } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()} } \concept{model_helpers} broom.helpers/man/tidy_add_term_labels.Rd0000644000176200001440000000637114357760764020257 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_term_labels.R \name{tidy_add_term_labels} \alias{tidy_add_term_labels} \title{Add term labels} \usage{ tidy_add_term_labels( x, labels = NULL, interaction_sep = " * ", categorical_terms_pattern = "{level}", model = tidy_get_model(x), quiet = FALSE, strict = FALSE ) } \arguments{ \item{x}{a tidy tibble} \item{labels}{an optional named list or named vector of custom term labels} \item{interaction_sep}{separator for interaction terms} \item{categorical_terms_pattern}{a \link[glue:glue]{glue pattern} for labels of categorical terms with treatment or sum contrasts (see examples and \code{\link[=model_list_terms_levels]{model_list_terms_levels()}})} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} \item{strict}{logical argument whether broom.helpers should return an error when requested output cannot be generated. Default is \code{FALSE}} } \description{ Will add term labels in a \code{label} column, based on: \enumerate{ \item labels provided in \code{labels} argument if provided; \item factor levels for categorical variables coded with treatment, SAS or sum contrasts (the label could be customized with \code{categorical_terms_pattern} argument); \item variable labels when there is only one term per variable; \item term name otherwise. } } \details{ If the \code{variable_label} column is not yet available in \code{x}, \code{\link[=tidy_add_variable_labels]{tidy_add_variable_labels()}} will be automatically applied. If the \code{contrasts} column is not yet available in \code{x}, \code{\link[=tidy_add_contrasts]{tidy_add_contrasts()}} will be automatically applied. It is possible to pass a custom label for any term in \code{labels}, including interaction terms. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} df <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% labelled::set_variable_labels( Class = "Passenger's class", Sex = "Sex" ) mod <- df \%>\% glm(Survived ~ Class * Age * Sex, data = ., weights = .$n, family = binomial) mod \%>\% tidy_and_attach() \%>\% tidy_add_term_labels() mod \%>\% tidy_and_attach() \%>\% tidy_add_term_labels( interaction_sep = " x ", categorical_terms_pattern = "{level} / {reference_level}" ) \dontshow{\}) # examplesIf} } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_get_pairwise_contrasts.Rd0000644000176200001440000000567314464175037022063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_pairwise_contrasts.R \name{model_get_pairwise_contrasts} \alias{model_get_pairwise_contrasts} \title{Get pairwise comparison of the levels of a categorical variable} \usage{ model_get_pairwise_contrasts( model, variables, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = 0.95, emmeans_args = list() ) } \arguments{ \item{model}{a model object} \item{variables}{names of variables to add pairwise contrasts} \item{pairwise_reverse}{determines whether to use \code{"pairwise"} (if \code{TRUE}) or \code{"revpairwise"} (if \code{FALSE}), see \code{\link[emmeans:contrast]{emmeans::contrast()}}} \item{contrasts_adjust}{optional adjustment method when computing contrasts, see \code{\link[emmeans:contrast]{emmeans::contrast()}} (if \code{NULL}, use \code{emmeans} default)} \item{conf.level}{level of confidence for confidence intervals} \item{emmeans_args}{list of additional parameter to pass to \code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts} } \description{ It is computed with \code{\link[emmeans:emmeans]{emmeans::emmeans()}}. } \details{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} For \code{pscl::zeroinfl()} and \code{pscl::hurdle()} models, pairwise contrasts are computed separately for each component, using \code{mode = "count"} and \code{mode = "zero"} (see documentation of \code{emmeans}) and a component column is added to the results. This support is still experimental. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("emmeans", boolean = TRUE)) { mod <- lm(Sepal.Length ~ Species, data = iris) mod \%>\% model_get_pairwise_contrasts(variables = "Species") mod \%>\% model_get_pairwise_contrasts( variables = "Species", contrasts_adjust = "none" ) } \dontshow{\}) # examplesIf} } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/dot-escape_regex.Rd0000644000176200001440000000075214357760764017340 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpers.R \name{.escape_regex} \alias{.escape_regex} \title{Escapes any characters that would have special meaning in a regular expression} \usage{ .escape_regex(string) } \arguments{ \item{string}{a character vector} } \description{ This functions has been adapted from \code{Hmisc::escapeRegex()} } \seealso{ Other other_helpers: \code{\link{.clean_backticks}()} } \concept{other_helpers} broom.helpers/man/model_get_xlevels.Rd0000644000176200001440000000356414463417025017612 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_xlevels.R \name{model_get_xlevels} \alias{model_get_xlevels} \alias{model_get_xlevels.default} \alias{model_get_xlevels.lmerMod} \alias{model_get_xlevels.glmerMod} \alias{model_get_xlevels.felm} \alias{model_get_xlevels.brmsfit} \alias{model_get_xlevels.glmmTMB} \alias{model_get_xlevels.plm} \alias{model_get_xlevels.model_fit} \title{Get xlevels used in the model} \usage{ model_get_xlevels(model) \method{model_get_xlevels}{default}(model) \method{model_get_xlevels}{lmerMod}(model) \method{model_get_xlevels}{glmerMod}(model) \method{model_get_xlevels}{felm}(model) \method{model_get_xlevels}{brmsfit}(model) \method{model_get_xlevels}{glmmTMB}(model) \method{model_get_xlevels}{plm}(model) \method{model_get_xlevels}{model_fit}(model) } \arguments{ \item{model}{a model object} } \description{ Get xlevels used in the model } \examples{ lm(hp ~ mpg + factor(cyl), mtcars) \%>\% model_get_xlevels() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_broom.Rd0000644000176200001440000000121714464175037016256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_broom} \alias{tidy_broom} \title{Tidy with \code{broom::tidy()} and checks that all arguments are used} \usage{ tidy_broom(x, ...) } \arguments{ \item{x}{a model to tidy} \item{...}{additional parameters passed to \code{broom::tidy()}} } \description{ Tidy with \code{broom::tidy()} and checks that all arguments are used } \seealso{ Other custom_tieders: \code{\link{tidy_multgee}()}, \code{\link{tidy_parameters}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/seq_range.Rd0000644000176200001440000000114214360056067016044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/broom.helpers-package.R \name{seq_range} \alias{seq_range} \title{Sequence generation between min and max} \usage{ seq_range(x, length.out = 25) } \arguments{ \item{x}{a numeric vector} \item{length.out}{desired length of the sequence} } \value{ a numeric vector } \description{ Sequence generation between min and max } \details{ \code{seq_range(x, length.out)} is a shortcut for \code{seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = length.out)} } \examples{ seq_range(iris$Petal.Length) } broom.helpers/man/tidy_multgee.Rd0000644000176200001440000000347314464175037016610 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_multgee} \alias{tidy_multgee} \title{Tidy a \code{multgee} model} \usage{ tidy_multgee(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a \code{multgee::nomLORgee()} or a \code{multgee::ordLORgee()} model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{parameters::model_parameters()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} A tidier for models generated with \code{multgee::nomLORgee()} or \code{multgee::ordLORgee()}. Term names will be updated to be consistent with generic models. The original term names are preserved in an \code{"original_term"} column. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("multgee", boolean = TRUE)) { library(multgee) mod <- multgee::nomLORgee( y ~ factor(time) * sec, data = multgee::housing, id = id, repeated = time, ) mod \%>\% tidy_multgee() mod2 <- ordLORgee( formula = y ~ factor(time) + factor(trt) + factor(baseline), data = multgee::arthritis, id = id, repeated = time, LORstr = "uniform" ) mod2 \%>\% tidy_multgee() } \dontshow{\}) # examplesIf} } \seealso{ Other custom_tieders: \code{\link{tidy_broom}()}, \code{\link{tidy_parameters}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/tidy_avg_slopes.Rd0000644000176200001440000000512414370455163017300 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_avg_slopes} \alias{tidy_avg_slopes} \title{Marginal Slopes / Effects with \code{marginaleffects::avg_slopes()}} \usage{ tidy_avg_slopes(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{marginaleffects::avg_slopes()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{marginaleffects::avg_slopes()} to estimate marginal slopes / effects and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{marginaleffects::avg_slopes()} for a list of supported models. } \details{ By default, \code{marginaleffects::avg_slopes()} estimate average marginal effects (AME): an effect is computed for each observed value in the original dataset before being averaged. Marginal Effects at the Mean (MEM) could be computed by specifying \code{newdata = "mean"}. Other types of marginal effects could be computed. Please refer to the documentation page of \code{marginaleffects::avg_slopes()}. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # Average Marginal Effects (AME) df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_avg_slopes(mod) tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes) mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) tidy_avg_slopes(mod2) # Marginal Effects at the Mean (MEM) tidy_avg_slopes(mod, newdata = "mean") tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes, newdata = "mean") \dontshow{\}) # examplesIf} } \seealso{ \code{marginaleffects::avg_slopes()} Other marginal_tieders: \code{\link{tidy_all_effects}()}, \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_n.Rd0000644000176200001440000001011714457461240016356 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_n.R \name{model_get_n} \alias{model_get_n} \alias{model_get_n.default} \alias{model_get_n.glm} \alias{model_get_n.glmerMod} \alias{model_get_n.multinom} \alias{model_get_n.LORgee} \alias{model_get_n.coxph} \alias{model_get_n.survreg} \alias{model_get_n.model_fit} \alias{model_get_n.tidycrr} \title{Get the number of observations} \usage{ model_get_n(model) \method{model_get_n}{default}(model) \method{model_get_n}{glm}(model) \method{model_get_n}{glmerMod}(model) \method{model_get_n}{multinom}(model) \method{model_get_n}{LORgee}(model) \method{model_get_n}{coxph}(model) \method{model_get_n}{survreg}(model) \method{model_get_n}{model_fit}(model) \method{model_get_n}{tidycrr}(model) } \arguments{ \item{model}{a model object} } \description{ For binomial and multinomial logistic models, will also return the number of events. } \details{ For Poisson models, will return the number of events and exposure time (defined with \code{\link[stats:offset]{stats::offset()}}). For Cox models (\code{\link[survival:coxph]{survival::coxph()}}), will return the number of events and exposure time. For competing risk regression models (\code{\link[tidycmprsk:crr]{tidycmprsk::crr()}}), \code{n_event} takes into account only the event of interest defined by \code{failcode.} See \code{\link[=tidy_add_n]{tidy_add_n()}} for more details. The total number of observations (\code{N_obs}), of events (\code{N_event}) and of exposure time (\code{Exposure}) are stored as attributes of the returned tibble. This function does not cover \code{lavaan} models (\code{NULL} is returned). } \examples{ lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) \%>\% model_get_n() mod <- glm( response ~ stage * grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.treatment(3, 2), trt = "contr.SAS") ) mod \%>\% model_get_n() \dontrun{ mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_get_n() d <- dplyr::as_tibble(Titanic) \%>\% dplyr::group_by(Class, Sex, Age) \%>\% dplyr::summarise( n_survived = sum(n * (Survived == "Yes")), n_dead = sum(n * (Survived == "No")) ) mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) mod \%>\% model_get_n() mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) mod \%>\% model_get_n() mod <- glm( response ~ trt * grade + offset(ttdeath), gtsummary::trial, family = poisson ) mod \%>\% model_get_n() dont df <- survival::lung \%>\% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) mod \%>\% model_get_n() mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) mod \%>\% model_get_n() mod <- lme4::glmer(response ~ trt * grade + (1 | stage), family = binomial, data = gtsummary::trial ) mod \%>\% model_get_n() mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) mod \%>\% model_get_n() } } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/model_get_contrasts.Rd0000644000176200001440000000325714464175037020154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_contrasts.R \name{model_get_contrasts} \alias{model_get_contrasts} \alias{model_get_contrasts.model_fit} \alias{model_get_contrasts.zeroinfl} \alias{model_get_contrasts.hurdle} \alias{model_get_contrasts.betareg} \title{Get contrasts used in the model} \usage{ model_get_contrasts(model) \method{model_get_contrasts}{model_fit}(model) \method{model_get_contrasts}{zeroinfl}(model) \method{model_get_contrasts}{hurdle}(model) \method{model_get_contrasts}{betareg}(model) } \arguments{ \item{model}{a model object} } \description{ Get contrasts used in the model } \examples{ glm( am ~ mpg + factor(cyl), data = mtcars, family = binomial, contrasts = list(`factor(cyl)` = contr.sum) ) \%>\% model_get_contrasts() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_all_effects.Rd0000644000176200001440000000471214370455163017407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marginal_tidiers.R \name{tidy_all_effects} \alias{tidy_all_effects} \title{Marginal Predictions at the mean with \code{effects::allEffects()}} \usage{ tidy_all_effects(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{a model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{...}{additional parameters passed to \code{effects::allEffects()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} Use \code{effects::allEffects()} to estimate marginal predictions and return a tibble tidied in a way that it could be used by \code{broom.helpers} functions. See \code{vignette("functions-supported-by-effects", package = "effects")} for a list of supported models. } \details{ By default, \code{effects::allEffects()} estimate marginal predictions at the mean at the observed means for continuous variables and weighting modalities of categorical variables according to their observed distribution in the original dataset. Marginal predictions are therefore computed at a sort of averaged situation / typical values for the other variables fixed in the model. For more information, see \code{vignette("marginal_tidiers", "broom.helpers")}. } \note{ If the model contains interactions, \code{effects::allEffects()} will return marginal predictions for the different levels of the interactions. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} df <- Titanic \%>\% dplyr::as_tibble() \%>\% tidyr::uncount(n) \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) mod <- glm( Survived ~ Class + Age + Sex, data = df, family = binomial ) tidy_all_effects(mod) tidy_plus_plus(mod, tidy_fun = tidy_all_effects) \dontshow{\}) # examplesIf} } \seealso{ \code{effects::allEffects()} Other marginal_tieders: \code{\link{tidy_avg_comparisons}()}, \code{\link{tidy_avg_slopes}()}, \code{\link{tidy_ggpredict}()}, \code{\link{tidy_marginal_contrasts}()}, \code{\link{tidy_marginal_means}()}, \code{\link{tidy_marginal_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_weights.Rd0000644000176200001440000000436514463417025017602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_weights.R \name{model_get_weights} \alias{model_get_weights} \alias{model_get_weights.default} \alias{model_get_weights.svyglm} \alias{model_get_weights.model_fit} \title{Get sampling weights used by a model} \usage{ model_get_weights(model) \method{model_get_weights}{default}(model) \method{model_get_weights}{svyglm}(model) \method{model_get_weights}{model_fit}(model) } \arguments{ \item{model}{a model object} } \description{ This function does not cover \code{lavaan} models (\code{NULL} is returned). } \examples{ mod <- lm(Sepal.Length ~ Sepal.Width, iris) mod \%>\% model_get_weights() mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars, weights = mtcars$gear) mod \%>\% model_get_weights() mod <- glm( response ~ stage * grade + trt, gtsummary::trial, family = binomial ) mod \%>\% model_get_weights() mod <- glm( Survived ~ Class * Age + Sex, data = Titanic \%>\% as.data.frame(), weights = Freq, family = binomial ) mod \%>\% model_get_weights() d <- dplyr::as_tibble(Titanic) \%>\% dplyr::group_by(Class, Sex, Age) \%>\% dplyr::summarise( n_survived = sum(n * (Survived == "Yes")), n_dead = sum(n * (Survived == "No")) ) mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) mod \%>\% model_get_weights() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_zeroinfl.Rd0000644000176200001440000000331514464175037016771 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_zeroinfl} \alias{tidy_zeroinfl} \title{Tidy a \code{zeroinfl} or a \code{hurdle} model} \usage{ tidy_zeroinfl(x, conf.int = TRUE, conf.level = 0.95, component = NULL, ...) } \arguments{ \item{x}{a \code{pscl::zeroinfl()} or a \code{pscl::hurdle()} model} \item{conf.int}{logical indicating whether or not to include a confidence interval in the tidied output} \item{conf.level}{the confidence level to use for the confidence interval} \item{component}{\code{NULL} or one of \code{"all"}, \code{"conditional"}, \code{"zi"}, or \code{"zero_inflated"}} \item{...}{additional parameters passed to \code{parameters::model_parameters()}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} A tidier for models generated with \code{pscl::zeroinfl()} or \code{pscl::hurdle()}. Term names will be updated to be consistent with generic models. The original term names are preserved in an \code{"original_term"} column. } \examples{ \dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} if (.assert_package("pscl", boolean = TRUE)) { library(pscl) mod <- zeroinfl( art ~ fem + mar + phd, data = pscl::bioChemists ) mod \%>\% tidy_zeroinfl(exponentiate = TRUE) } \dontshow{\}) # examplesIf} } \seealso{ Other custom_tieders: \code{\link{tidy_broom}()}, \code{\link{tidy_multgee}()}, \code{\link{tidy_parameters}()}, \code{\link{tidy_with_broom_or_parameters}()} } \concept{custom_tieders} broom.helpers/man/tidy_add_coefficients_type.Rd0000644000176200001440000000405214357760764021462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_add_coefficients_type.R \name{tidy_add_coefficients_type} \alias{tidy_add_coefficients_type} \title{Add coefficients type and label as attributes} \usage{ tidy_add_coefficients_type( x, exponentiate = attr(x, "exponentiate"), model = tidy_get_model(x) ) } \arguments{ \item{x}{a tidy tibble} \item{exponentiate}{logical indicating whether or not to exponentiate the coefficient estimates. It should be consistent with the original call to \code{\link[broom:reexports]{broom::tidy()}}} \item{model}{the corresponding model, if not attached to \code{x}} } \description{ Add the type of coefficients ("generic", "logistic", "poisson", "relative_risk" or "prop_hazard") and the corresponding coefficient labels, as attributes to \code{x} (respectively named \code{coefficients_type} and \code{coefficients_label}). } \examples{ ex1 <- lm(hp ~ mpg + factor(cyl), mtcars) \%>\% tidy_and_attach() \%>\% tidy_add_coefficients_type() attr(ex1, "coefficients_type") attr(ex1, "coefficients_label") ex2 <- Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) \%>\% tidy_and_attach(exponentiate = TRUE) \%>\% tidy_add_coefficients_type() attr(ex2, "coefficients_type") attr(ex2, "coefficients_label") } \seealso{ Other tidy_helpers: \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_get_offset.Rd0000644000176200001440000000264214360056067017413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_get_offset.R \name{model_get_offset} \alias{model_get_offset} \alias{model_get_offset.default} \title{Get model offset} \usage{ model_get_offset(model) \method{model_get_offset}{default}(model) } \arguments{ \item{model}{a model object} } \description{ This function does not cover \code{lavaan} models (\code{NULL} is returned). } \examples{ mod <- glm( response ~ trt + offset(log(ttdeath)), gtsummary::trial, family = poisson ) mod \%>\% model_get_offset() } \seealso{ Other model_helpers: \code{\link{model_compute_terms_contributions}()}, \code{\link{model_get_assign}()}, \code{\link{model_get_coefficients_type}()}, \code{\link{model_get_contrasts}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_model}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_n}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response_variable}()}, \code{\link{model_get_response}()}, \code{\link{model_get_terms}()}, \code{\link{model_get_weights}()}, \code{\link{model_get_xlevels}()}, \code{\link{model_identify_variables}()}, \code{\link{model_list_contrasts}()}, \code{\link{model_list_higher_order_variables}()}, \code{\link{model_list_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_identify_variables.Rd0000644000176200001440000000515314357760764021016 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_identify_variables.R \name{tidy_identify_variables} \alias{tidy_identify_variables} \title{Identify the variable corresponding to each model coefficient} \usage{ tidy_identify_variables(x, model = tidy_get_model(x), quiet = FALSE) } \arguments{ \item{x}{a tidy tibble} \item{model}{the corresponding model, if not attached to \code{x}} \item{quiet}{logical argument whether broom.helpers should not return a message when requested output cannot be generated. Default is \code{FALSE}} } \description{ \code{tidy_identify_variables()} will add to the tidy tibble three additional columns: \code{variable}, \code{var_class}, \code{var_type} and \code{var_nlevels}. } \details{ It will also identify interaction terms and intercept(s). \code{var_type} could be: \itemize{ \item \code{"continuous"}, \item \code{"dichotomous"} (categorical variable with 2 levels), \item \code{"categorical"} (categorical variable with 3 levels or more), \item \code{"intercept"} \item \code{"interaction"} \item \verb{"ran_pars} (random-effect parameters for mixed models) \item \code{"ran_vals"} (random-effect values for mixed models) \item \code{"unknown"} in the rare cases where \code{tidy_identify_variables()} will fail to identify the list of variables } For dichotomous and categorical variables, \code{var_nlevels} corresponds to the number of original levels in the corresponding variables. } \examples{ Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) \%>\% glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) \%>\% tidy_and_attach() \%>\% tidy_identify_variables() lm( Sepal.Length ~ poly(Sepal.Width, 2) + Species, data = iris, contrasts = list(Species = contr.sum) ) \%>\% tidy_and_attach(conf.int = TRUE) \%>\% tidy_identify_variables() } \seealso{ \code{\link[=model_identify_variables]{model_identify_variables()}} Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_remove_intercept.Rd0000644000176200001440000000273314357760764020526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_remove_intercept.R \name{tidy_remove_intercept} \alias{tidy_remove_intercept} \title{Remove intercept(s)} \usage{ tidy_remove_intercept(x, model = tidy_get_model(x)) } \arguments{ \item{x}{a tidy tibble} \item{model}{the corresponding model, if not attached to \code{x}} } \description{ Will remove terms where \code{var_type == "intercept"}. } \details{ If the \code{variable} column is not yet available in \code{x}, \code{\link[=tidy_identify_variables]{tidy_identify_variables()}} will be automatically applied. } \examples{ Titanic \%>\% dplyr::as_tibble() \%>\% dplyr::mutate(Survived = factor(Survived)) \%>\% glm(Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial) \%>\% tidy_and_attach() \%>\% tidy_remove_intercept() } \seealso{ Other tidy_helpers: \code{\link{tidy_add_coefficients_type}()}, \code{\link{tidy_add_contrasts}()}, \code{\link{tidy_add_estimate_to_reference_rows}()}, \code{\link{tidy_add_header_rows}()}, \code{\link{tidy_add_n}()}, \code{\link{tidy_add_pairwise_contrasts}()}, \code{\link{tidy_add_reference_rows}()}, \code{\link{tidy_add_term_labels}()}, \code{\link{tidy_add_variable_labels}()}, \code{\link{tidy_attach_model}()}, \code{\link{tidy_disambiguate_terms}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/DESCRIPTION0000644000176200001440000000357314464210122014543 0ustar liggesusersPackage: broom.helpers Title: Helpers for Model Coefficients Tibbles Version: 1.14.0 Authors@R: c( person("Joseph", "Larmarange", , "joseph@larmarange.net", role = c("aut", "cre"), comment = c(ORCID = "0000-0001-7097-700X")), person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = "aut", comment = c(ORCID = "0000-0003-0862-2018")) ) Description: Provides suite of functions to work with regression model 'broom::tidy()' tibbles. The suite includes functions to group regression model terms by variable, insert reference and header rows for categorical variables, add variable labels, and more. License: GPL (>= 3) URL: https://larmarange.github.io/broom.helpers/ BugReports: https://github.com/larmarange/broom.helpers/issues Depends: R (>= 3.4) Imports: broom (>= 0.8), cli, dplyr, labelled, lifecycle, purrr, rlang (>= 1.0.1), stats, stringr, tibble, tidyr Suggests: betareg, biglm, biglmm, brms (>= 2.13.0), broom.mixed, cmprsk, covr, datasets, effects, emmeans, fixest (>= 0.10.0), forcats, gam, gee, geepack, ggplot2, ggeffects, ggstats (>= 0.2.1), glmmTMB, glue, gt, gtsummary (>= 1.6.3), knitr, lavaan, lfe, lme4 (>= 1.1.28), logitr (>= 0.8.0), marginaleffects (>= 0.10.0), margins, MASS, mgcv, mice, multgee, nnet, ordinal, parameters, parsnip, patchwork, plm, pscl, rmarkdown, rstanarm, scales, spelling, survey, survival, testthat, tidycmprsk, VGAM VignetteBuilder: knitr RdMacros: lifecycle Encoding: UTF-8 Language: en-US LazyData: true RoxygenNote: 7.2.3 NeedsCompilation: no Packaged: 2023-08-07 15:01:10 UTC; josep Author: Joseph Larmarange [aut, cre] (), Daniel D. Sjoberg [aut] () Maintainer: Joseph Larmarange Repository: CRAN Date/Publication: 2023-08-07 15:40:02 UTC broom.helpers/build/0000755000176200001440000000000014464203464014137 5ustar liggesusersbroom.helpers/build/vignette.rds0000644000176200001440000000033314464203464016475 0ustar liggesusersmP 0 .N7`1|郯FW؍.0;j m$1Lf[3- -`6s^MgB(B_KL*,H -AU'%ZVmdյye%KVt.Ԅ8cgu 14bWu0iXw?%ӅR^B=wEv broom.helpers/tests/0000755000176200001440000000000014357760764014216 5ustar liggesusersbroom.helpers/tests/spelling.R0000644000176200001440000000023314457457144016150 0ustar liggesusersif (requireNamespace("spelling", quietly = TRUE)) { spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) } broom.helpers/tests/testthat/0000755000176200001440000000000014464210122016027 5ustar liggesusersbroom.helpers/tests/testthat/test-list_higher_order_variables.R0000644000176200001440000000126414457457170024700 0ustar liggesuserstest_that("model_list_higher_order_variables() works for basic models", { mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) expect_equal( mod %>% model_list_higher_order_variables(), c("mpg", "factor(cyl)", "hp:disp") ) mod <- glm( Survived ~ Class * Age + Sex:Class, data = Titanic %>% as.data.frame(), weights = Freq, family = binomial ) expect_equal( mod %>% model_list_higher_order_variables(), c("Class:Age", "Class:Sex") ) mod <- lm(Petal.Length ~ Petal.Width * Species * Sepal.Length, data = iris) expect_equal( mod %>% model_list_higher_order_variables(), "Petal.Width:Species:Sepal.Length" ) }) broom.helpers/tests/testthat/test-add_pairwise_contrasts.R0000644000176200001440000000371414457457156023715 0ustar liggesuserstest_that("tidy_add_pairwise_contrasts() works for glm", { skip_on_cran() skip_if_not_installed("emmeans") skip_if_not_installed("gtsummary") mod <- glm(response ~ stage + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_pairwise_contrasts() expect_equivalent( res$term, c( "(Intercept)", "T2 - T1", "T3 - T1", "T3 - T2", "T4 - T1", "T4 - T2", "T4 - T3", "Drug B - Drug A" ) ) res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts() expect_equivalent( res$term, c( "(Intercept)", "T2 / T1", "T3 / T1", "T3 / T2", "T4 / T1", "T4 / T2", "T4 / T3", "Drug B / Drug A" ) ) expect_equivalent( round(res$estimate, digits = 2), c(0.48, 0.62, 1.12, 1.82, 0.82, 1.33, 0.73, 1.24) ) expect_equivalent( round(res$conf.low, digits = 2), c(0.25, 0.2, 0.36, 0.56, 0.27, 0.42, 0.23, 0.67) ) res <- mod %>% tidy_and_attach(exponentiate = TRUE, conf.level = .9) %>% tidy_add_pairwise_contrasts( variables = stage, keep_model_terms = TRUE, pairwise_reverse = FALSE ) expect_equivalent( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "T1 / T2", "T1 / T3", "T1 / T4", "T2 / T3", "T2 / T4", "T3 / T4", "trtDrug B" ) ) expect_equivalent( round(res$conf.low, digits = 2), c(0.27, 0.3, 0.54, 0.4, 0.6, 0.33, 0.46, 0.19, 0.27, 0.49, 0.74) ) res <- mod %>% tidy_plus_plus(exponentiate = TRUE, add_pairwise_contrasts = TRUE) expect_equivalent( res$term, c( "T2 / T1", "T3 / T1", "T3 / T2", "T4 / T1", "T4 / T2", "T4 / T3", "Drug B / Drug A" ) ) res1 <- mod %>% tidy_plus_plus(add_pairwise_contrasts = TRUE) res2 <- mod %>% tidy_plus_plus(add_pairwise_contrasts = TRUE, contrasts_adjust = "none") expect_false(identical(res1, res2)) }) broom.helpers/tests/testthat/test-add_n.R0000644000176200001440000002045614457457156020231 0ustar liggesuserstest_that("tidy_add_n() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 52, 40, 49, 63, 63, 98) ) expect_equivalent( res$n_event, c(61, 13, 15, 15, 19, 21, 33) ) expect_equivalent(attr(res, "N_obs"), 193) expect_equivalent(attr(res, "N_event"), 61) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.helmert, trt = contr.SAS) ) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 52, 52, 40, 63, 63, 95) ) expect_equivalent(attr(res, "N_obs"), 193) expect_equivalent(attr(res, "N_event"), 61) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.treatment, trt = matrix(c(-3, 2))) ) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 193, 193, 193, 63, 63, 98) ) expect_equivalent(attr(res, "N_obs"), 193) expect_equivalent(attr(res, "N_event"), 61) mod <- glm( response ~ stage + grade + trt + factor(death), gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, 3), grade = contr.treatment(3, 2), trt = contr.treatment(2, 2), "factor(death)" = matrix(c(-3, 2)) ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 52, 52, 49, 67, 63, 95, 107) ) expect_equivalent(attr(res, "N_obs"), 193) expect_equivalent(attr(res, "N_event"), 61) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = "contr.sum", grade = "contr.helmert", trt = "contr.SAS") ) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 52, 52, 40, 63, 63, 95) ) mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(183, 183, 58, 60, 94, 29, 33) ) expect_equivalent( res$n_event, c(58, 58, 17, 20, 31, 10, 8) ) expect_equivalent( res$exposure, c(183, 183, 58, 60, 94, 29, 33) ) expect_equivalent(attr(res, "N_obs"), 183) expect_equivalent(attr(res, "N_event"), 58) expect_equivalent(attr(res, "Exposure"), 183) mod <- glm( response ~ trt * grade + offset(log(ttdeath)), gtsummary::trial, family = poisson, weights = rep_len(1:2, 200) ) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(292, 151, 94, 92, 49, 49) ) expect_equivalent( res$n_event, c(96, 53, 28, 31, 19, 12) ) expect_equivalent( res$exposure, c(5819.07, 2913.6, 1826.26, 1765.52, 887.22, 915.56) ) expect_equivalent(attr(res, "N_obs"), 292) expect_equivalent(attr(res, "N_event"), 96) expect_equivalent(attr(res, "Exposure"), 5819.07) }) test_that("test tidy_add_n() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_n()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_add_n() %>% tidy_add_n(), NA ) }) test_that("tidy_add_n() works with variables having non standard name", { df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- glm(response ~ stage + `grade of kids` + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(193, 52, 40, 49, 63, 63, 98) ) }) test_that("tidy_add_n() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) mod <- lme4::lmer(marker ~ stage + grade + (1 | group), df) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) suppressMessages( mod <- lme4::glmer(response ~ stage + grade + (1 | group), df, family = binomial) ) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with survival::coxph", { skip_on_cran() df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with survival::survreg", { skip_on_cran() mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with nnet::multinom", { skip_if_not_installed("nnet") skip_on_cran() mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) res <- mod %>% tidy_and_attach() %>% tidy_add_n() expect_equivalent( res$n_obs, c(179, 47, 52, 37, 179, 179, 179, 47, 52, 37, 179, 179) ) expect_equivalent( res$n_event, c(57, 21, 16, 8, 57, 57, 58, 12, 18, 12, 58, 58) ) # when y is not coded as a factor mod <- nnet::multinom(race ~ age + lwt + bwt, data = MASS::birthwt, trace = FALSE) expect_error( mod %>% tidy_and_attach() %>% tidy_add_n(), NA ) }) test_that("tidy_add_n() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(mod %>% tidy_and_attach() %>% tidy_add_n(), NA) }) test_that("tidy_add_n() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(res <- mod %>% tidy_and_attach() %>% tidy_add_n(), NA) expect_true(all(is.na(res$n))) }) broom.helpers/tests/testthat/test-add_estimate_to_reference_rows.R0000644000176200001440000003206414461477304025367 0ustar liggesuserstest_that("tidy_add_estimate_to_reference_rows() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(0, 0, 0) ) res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(1, 1, 1) ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.SAS ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(0, 0, 0) ) res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(1, 1, 1) ) skip_if_not_installed("emmeans") mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.sum, trt = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() # should be -1 * sum of other coefficients when sum contrasts expect_equivalent( res$estimate[res$reference_row & res$variable == "stage" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "stage"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "grade" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "grade"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "trt" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "trt"], na.rm = TRUE) * -1 ) # p-values and confidence intervals should be populated expect_false(any(is.na(res$p.value))) expect_false(any(is.na(res$conf.low))) expect_false(any(is.na(res$conf.high))) res2 <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res2$estimate[res2$reference_row & res2$variable == "stage" & !is.na(res2$reference_row)], exp(sum(res$estimate[!res$reference_row & res$variable == "stage"], na.rm = TRUE) * -1) ) expect_equivalent( res2$estimate[res2$reference_row & res2$variable == "grade" & !is.na(res2$reference_row)], exp(sum(res$estimate[!res$reference_row & res$variable == "grade"], na.rm = TRUE) * -1) ) expect_equivalent( res2$estimate[res2$reference_row & res2$variable == "trt" & !is.na(res2$reference_row)], exp(sum(res$estimate[!res$reference_row & res$variable == "trt"], na.rm = TRUE) * -1) ) ## works also when there is an interaction term mod <- glm(response ~ stage * grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.sum, trt = contr.sum) ) suppressWarnings( res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() ) # should be -1 * sum of other coefficients when sum contrasts expect_equivalent( res$estimate[res$reference_row & res$variable == "stage" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "stage"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "grade" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "grade"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "trt" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "trt"], na.rm = TRUE) * -1 ) skip_on_cran() mod <- lm( Petal.Length ~ Petal.Width + Species, data = iris, contrasts = list(Species = contr.sum) ) expect_error( res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA ) expect_error( res2 <- mod %>% tidy_and_attach(conf.level = .8) %>% tidy_add_estimate_to_reference_rows(), NA ) expect_error( res3 <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(conf.level = .8), NA ) expect_false(res$conf.low[5] == res2$conf.low[5]) expect_true(res2$conf.low[5] == res3$conf.low[5]) }) test_that("test tidy_add_estimate_to_reference_rows() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE)) # expect an error if no value for exponentiate expect_error( mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(exponentiate = NULL) ) expect_error( mod %>% broom::tidy() %>% tidy_attach_model(mod) %>% tidy_add_estimate_to_reference_rows() ) skip_if_not_installed("emmeans") # expect a message if this is a model not covered by emmeans mod <- glm( response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(grade = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() class(mod) <- "unknown" expect_message( res %>% tidy_add_estimate_to_reference_rows(model = mod) ) }) test_that("tidy_add_estimate_to_reference_rows() works with character variables", { df <- gtsummary::trial %>% dplyr::mutate(dplyr::across(where(is.factor), as.character)) mod <- glm(response ~ stage + grade + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(0, 0, 0) ) mod <- glm(response ~ stage + grade + trt, df, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.SAS ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() expect_equivalent( res$estimate[res$reference_row & !is.na(res$reference_row)], c(0, 0, 0) ) skip_if_not_installed("emmeans") mod <- glm(response ~ stage + grade + trt, df, family = binomial, contrasts = list(stage = contr.sum, grade = contr.sum, trt = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows() # should be -1 * sum of other coefficients when sum contrasts expect_equivalent( res$estimate[res$reference_row & res$variable == "stage" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "stage"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "grade" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "grade"], na.rm = TRUE) * -1 ) expect_equivalent( res$estimate[res$reference_row & res$variable == "trt" & !is.na(res$reference_row)], sum(res$estimate[!res$reference_row & res$variable == "trt"], na.rm = TRUE) * -1 ) }) test_that("tidy_add_estimate_to_reference_rows() handles variables having non standard name", { skip_if_not_installed("emmeans") df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- glm(response ~ stage + `grade of kids` + trt, df, family = binomial, contrasts = list(`grade of kids` = contr.sum) ) expect_message( res <- mod %>% tidy_and_attach(tidy_fun = broom::tidy) %>% tidy_add_estimate_to_reference_rows(), NA ) expect_equivalent( res$estimate[res$variable == "grade of kids" & !is.na(res$variable)] %>% sum(), 0 ) }) test_that("tidy_add_estimate_to_reference_rows() preserve estimates of continuous variables", { mod <- glm(response ~ poly(age, 3) + ttdeath, na.omit(gtsummary::trial), family = binomial) res1 <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() res2 <- res1 %>% tidy_add_estimate_to_reference_rows() expect_equivalent(res1$estimate, res2$estimate) }) skip_on_cran() test_that("tidy_add_estimate_to_reference_rows() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) mod <- lme4::lmer(marker ~ stage + grade + (1 | group), df) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_estimate_to_reference_rows(), NA ) }) test_that("tidy_add_estimate_to_reference_rows() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) suppressMessages( mod <- lme4::glmer(response ~ stage + grade + (1 | group), df, family = binomial) ) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_estimate_to_reference_rows(), NA ) }) test_that("tidy_add_estimate_to_reference_rows() works with survival::coxph", { df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with survival::survreg", { mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with nnet::multinom", { mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) # no emmeans for multinom # should return a warning but not an error mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) expect_message(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows()) }) test_that("tidy_add_estimate_to_reference_rows() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) test_that("tidy_add_estimate_to_reference_rows() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_estimate_to_reference_rows(), NA) }) broom.helpers/tests/testthat/test-disambiguate_terms.R0000644000176200001440000000414214457457164023025 0ustar liggesuserstest_that("tidy_disambiguate_terms() changes nothing for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() # no change by default res2 <- res %>% tidy_disambiguate_terms() expect_equivalent(res, res2) expect_false("original_term" %in% names(res2)) }) test_that("tidy_disambiguate_terms() works for mixed models", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) skip_if_not_installed("broom.mixed") res <- mod %>% tidy_and_attach() %>% tidy_disambiguate_terms(sep = ".") expect_equivalent( res$term, c( "(Intercept)", "Days", "Subject.sd__(Intercept)", "Subject.cor__(Intercept).Days", "Subject.sd__Days", "Residual.sd__Observation" ) ) expect_true("original_term" %in% names(res)) res <- mod %>% tidy_and_attach() %>% tidy_disambiguate_terms(sep = "_") expect_equivalent( res$term, c( "(Intercept)", "Days", "Subject_sd__(Intercept)", "Subject_cor__(Intercept).Days", "Subject_sd__Days", "Residual_sd__Observation" ) ) }) test_that("test tidy_disambiguate_terms() checks", { skip_on_cran() skip_if_not_installed("lme4") skip_if_not_installed("broom.mixed") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) # expect an error if no model attached expect_error(mod %>% broom.mixed::tidy() %>% tidy_disambiguate_terms()) # could be apply twice (no error but a message) expect_error( mod %>% tidy_and_attach() %>% tidy_disambiguate_terms() %>% tidy_disambiguate_terms(), NA ) expect_message( mod %>% tidy_and_attach(tidy_fun = broom::tidy) %>% tidy_disambiguate_terms() %>% tidy_disambiguate_terms() ) expect_message( mod %>% tidy_and_attach(tidy_fun = broom::tidy) %>% tidy_disambiguate_terms() %>% tidy_disambiguate_terms(quiet = TRUE), NA ) }) broom.helpers/tests/testthat/test-add_term_labels.R0000644000176200001440000003001614463417025022242 0ustar liggesuserstest_that("tidy_add_term_labels() works for basic models", { mod <- lm(Petal.Length ~ Petal.Width, iris) expect_error( mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA ) df <- gtsummary::trial mod <- glm(response ~ age + grade + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_term_labels() expect_equivalent( res$label, c("(Intercept)", "Age", "II", "III", "Drug B") ) df <- gtsummary::trial mod <- glm(response ~ age + grade + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels() expect_equivalent( res$label, c("(Intercept)", "Age", "I", "II", "III", "Drug A", "Drug B") ) # if labels provided in `labels`, taken into account res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels( labels = list( "(Intercept)" = "the intercept", "trtDrug A" = "the reference term", gradeIII = "third grade" ) ) expect_equivalent( res$label, c( "the intercept", "Age", "I", "II", "third grade", "the reference term", "Drug B" ) ) # no error if providing labels not corresponding to an existing variable # but display a message expect_error( mod %>% tidy_and_attach() %>% tidy_add_term_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44) ), NA ) expect_message( mod %>% tidy_and_attach() %>% tidy_add_term_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44) ) ) expect_error( mod %>% tidy_and_attach() %>% tidy_add_term_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44), strict = TRUE ) ) # model with an interaction term only mod <- lm(age ~ factor(response):marker, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_add_term_labels() expect_equivalent( res$label, c("(Intercept)", "0 * Marker Level (ng/mL)", "1 * Marker Level (ng/mL)") ) }) test_that("test tidy_add_term_labels() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_term_labels()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_add_term_labels() %>% tidy_add_term_labels(), NA ) # cannot be applied after tidy_add_header_rows expect_error( mod %>% tidy_and_attach() %>% tidy_add_header_rows() %>% tidy_add_term_labels() ) }) test_that("tidy_add_term_labels() correctly manages interaction terms", { df <- gtsummary::trial mod <- glm(response ~ age * grade * trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels() expect_equivalent( res$label, c( "(Intercept)", "Age", "I", "II", "III", "Drug A", "Drug B", "Age * II", "Age * III", "Age * Drug B", "II * Drug B", "III * Drug B", "Age * II * Drug B", "Age * III * Drug B" ) ) # custom separator and custom labels for certain interaction terms res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels( interaction_sep = ":::", labels = c( "age:gradeII" = "custom interaction label", "gradeII:trtDrug B" = "a second custom label" ) ) expect_equivalent( res$label, c( "(Intercept)", "Age", "I", "II", "III", "Drug A", "Drug B", "custom interaction label", "Age:::III", "Age:::Drug B", "a second custom label", "III:::Drug B", "Age:::II:::Drug B", "Age:::III:::Drug B" ) ) # case with sum contrasts mod <- lm( marker ~ stage:ttdeath + stage, data = gtsummary::trial, contrasts = list(stage = "contr.sum") ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels() expect_equivalent( res$label, c( "(Intercept)", "T1", "T2", "T3", "T4", "T1 * Months to Death/Censor", "T2 * Months to Death/Censor", "T3 * Months to Death/Censor", "T4 * Months to Death/Censor" ) ) # complex case: model with no intercept and sum contrasts mod <- lm( Petal.Length ~ Species * Petal.Width - 1, data = iris, contrasts = list(Species = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels() expect_equivalent( res$label, c( "setosa", "versicolor", "virginica", "Petal.Width", "setosa * Petal.Width", "versicolor * Petal.Width" ) ) }) test_that("tidy_add_term_labels() works with poly or helmert contrasts", { mod <- glm( response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.helmert, trt = contr.SAS) ) # should not produce an error expect_error( mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA ) }) test_that("tidy_add_term_labels() works with sdif contrasts", { skip_if_not_installed("MASS") mod <- glm( response ~ stage + grade, gtsummary::trial, family = binomial, contrasts = list(stage = MASS::contr.sdif, grade = MASS::contr.sdif) ) # should not produce an error expect_error( res <- mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA ) expect_equivalent( res$label, c( `(Intercept)` = "(Intercept)", `stageT2-T1` = "T2 - T1", `stageT3-T2` = "T3 - T2", `stageT4-T3` = "T4 - T3", `gradeII-I` = "II - I", `gradeIII-II` = "III - II" ) ) # should not produce an error expect_error( res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_term_labels(), NA ) expect_equivalent( res$label, c( `(Intercept)` = "(Intercept)", `stageT2-T1` = "T2 / T1", `stageT3-T2` = "T3 / T2", `stageT4-T3` = "T4 / T3", `gradeII-I` = "II / I", `gradeIII-II` = "III / II" ) ) }) test_that("tidy_add_term_labels() works with variables having non standard name", { skip_on_cran() df <- gtsummary::trial %>% dplyr::rename( `grade of kids...` = grade, `?? treatment ++ response ...` = response ) mod <- lm(age ~ marker * `grade of kids...` + factor(`?? treatment ++ response ...`), df) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_term_labels() expect_equivalent( res$label, c( "(Intercept)", "Marker Level (ng/mL)", "I", "II", "III", "0", "1", "Marker Level (ng/mL) * II", "Marker Level (ng/mL) * III" ) ) expect_equivalent( res$variable, c( "(Intercept)", "marker", "grade of kids...", "grade of kids...", "grade of kids...", "factor(`?? treatment ++ response ...`)", "factor(`?? treatment ++ response ...`)", "marker:grade of kids...", "marker:grade of kids..." ) ) res <- gtsummary::trial %>% dplyr::select(response, `age at dx` = age, `drug type` = trt) %>% lm( response ~ `age at dx` + `drug type`, data = . ) %>% tidy_and_attach() %>% tidy_add_variable_labels(list(`age at dx` = "AGGGGGGGE")) %>% tidy_add_term_labels() expect_equivalent( res$label, c("(Intercept)", "AGGGGGGGE", "Drug B") ) }) test_that("tidy_add_term_labels() works with stats::poly()", { skip_on_cran() df <- iris %>% labelled::set_variable_labels(Petal.Length = "Length of petal") mod <- lm(Sepal.Length ~ poly(Sepal.Width, 3) + poly(Petal.Length, 2), df) res <- mod %>% tidy_and_attach() %>% tidy_add_term_labels() expect_equivalent( res$label, c( "(Intercept)", "Sepal.Width", "Sepal.Width²", "Sepal.Width³", "Petal.Length", "Petal.Length²" ) ) }) skip_on_cran() test_that("tidy_add_term_labels() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with survival::coxph", { skip_on_cran() df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with survival::survreg", { skip_on_cran() mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with nnet::multinom", { skip_on_cran() mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with survey::svyglm", { skip_on_cran() skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with ordinal::clm", { skip_on_cran() mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with ordinal::clmm", { skip_on_cran() mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with MASS::polr", { skip_on_cran() mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with geepack::geeglm", { skip_on_cran() skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with gam::gam", { skip_on_cran() skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) test_that("tidy_add_term_labels() works with lavaan::lavaan", { skip_on_cran() skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_term_labels(), NA) }) broom.helpers/tests/testthat/test-marginal_tidiers.R0000644000176200001440000003153414457457172022476 0ustar liggesuserstest_that("tidy_margins()", { skip_on_cran() skip_if_not_installed("margins") mod <- lm(Petal.Length ~ Petal.Width + Species, data = iris) expect_error( t <- tidy_margins(mod), NA ) expect_error( tidy_margins(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_margins), NA ) expect_equal( nrow(res), nrow(t) + 1 # due to adding ref row ) expect_equal( attr(res, "coefficients_label"), "Average Marginal Effects" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_margins, add_pairwise_contrasts = TRUE ) ) }) test_that("tidy_all_effects()", { skip_on_cran() skip_if_not_installed("effects") mod <- lm(Petal.Length ~ Petal.Width + Species, data = iris) expect_error( t <- tidy_all_effects(mod), NA ) expect_error( tidy_all_effects(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_all_effects), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Marginal Predictions at the Mean" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_all_effects, add_pairwise_contrasts = TRUE ) ) }) test_that("tidy_ggpredict()", { skip_on_cran() skip_if_not_installed("ggeffects") mod <- lm(Petal.Length ~ Petal.Width + Species, data = iris) expect_error( t <- tidy_ggpredict(mod), NA ) expect_error( tidy_ggpredict(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_ggpredict), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Marginal Predictions" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_ggpredict, add_pairwise_contrasts = TRUE ) ) }) test_that("tidy_marginal_predictions()", { skip_on_cran() skip_if_not_installed("marginaleffects") mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_error( t <- tidy_marginal_predictions(mod), NA ) expect_error( tidy_marginal_predictions(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_marginal_predictions), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Average Marginal Predictions" ) expect_true(any(res$var_type == "interaction")) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, add_pairwise_contrasts = TRUE ) ) expect_error( t <- tidy_marginal_predictions(mod, "no_interaction"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, variables_list = "no_interaction" ), NA ) expect_equal( nrow(res), nrow(t) ) expect_false(any(res$var_type == "interaction")) expect_error( t <- tidy_marginal_predictions(mod, newdata = "mean"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, newdata = "mean" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Predictions at the Mean" ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, newdata = "marginalmeans" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Predictions at Marginal Means" ) expect_type( p <- plot_marginal_predictions(mod), "list" ) expect_length(p, 2) expect_type( p <- plot_marginal_predictions(mod, variables_list = "no_interaction"), "list" ) expect_length(p, 3) }) test_that("tidy_avg_slopes()", { skip_on_cran() skip_if_not_installed("marginaleffects") mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_error( t <- tidy_avg_slopes(mod), NA ) expect_error( tidy_avg_slopes(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Average Marginal Effects" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_avg_slopes, add_pairwise_contrasts = TRUE ) ) expect_error( t <- tidy_avg_slopes(mod, newdata = "mean"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_slopes, newdata = "mean" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Effects at the Mean" ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_slopes, newdata = "marginalmeans" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Effects at Marginal Means" ) }) test_that("tidy_marginal_contrasts()", { skip_on_cran() skip_if_not_installed("marginaleffects") mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_error( t <- tidy_marginal_contrasts(mod), NA ) expect_error( tidy_marginal_contrasts(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_marginal_contrasts), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Average Marginal Contrasts" ) expect_true(any(res$var_type == "interaction")) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, add_pairwise_contrasts = TRUE ) ) expect_error( t <- tidy_marginal_contrasts(mod, "no_interaction"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, variables_list = "no_interaction" ), NA ) expect_equal( nrow(res), nrow(t) ) expect_false(any(res$var_type == "interaction")) expect_error( t <- tidy_marginal_contrasts(mod, newdata = "mean"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, newdata = "mean" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at the Mean" ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, newdata = "marginalmeans" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at Marginal Means" ) }) test_that("tidy_marginal_means()", { skip_on_cran() skip_if_not_installed("marginaleffects") mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_error( t <- tidy_marginal_means(mod), NA ) expect_error( tidy_marginal_means(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_marginal_means), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Marginal Means" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_marginal_means, add_pairwise_contrasts = TRUE ) ) }) test_that("tidy_avg_comparisons()", { skip_on_cran() skip_if_not_installed("marginaleffects") mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_error( t <- tidy_avg_comparisons(mod), NA ) expect_error( tidy_avg_comparisons(mod, exponentiate = TRUE) ) expect_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons), NA ) expect_equal( nrow(res), nrow(t) ) expect_equal( attr(res, "coefficients_label"), "Average Marginal Contrasts" ) expect_error( tidy_plus_plus( mod, tidy_fun = tidy_avg_comparisons, add_pairwise_contrasts = TRUE ) ) expect_error( t <- tidy_avg_comparisons(mod, newdata = "mean"), NA ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_comparisons, newdata = "mean" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at the Mean" ) expect_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_comparisons, newdata = "marginalmeans" ), NA ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at Marginal Means" ) }) test_that("Marginal tidiers works with nnet::multinom() models", { skip_on_cran() skip_if_not_installed("nnet") skip_if_not_installed("margins") skip_if_not_installed("effects") skip_if_not_installed("ggeffects") skip_if_not_installed("marginaleffects") suppressMessages( mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE ) ) # not supported: tidy_margins(mod) expect_error( res <- tidy_all_effects(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_ggpredict(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_avg_slopes(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_avg_comparisons(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_marginal_means(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_marginal_predictions(mod), NA ) expect_true("y.level" %in% names(res)) expect_type( p <- plot_marginal_predictions(mod), "list" ) expect_length(p, 3) expect_error( res <- tidy_marginal_contrasts(mod), NA ) expect_true("y.level" %in% names(res)) }) test_that("Marginal tidiers works with MASS::polr() models", { skip_on_cran() skip_if_not_installed("MASS") skip_if_not_installed("margins") skip_if_not_installed("effects") skip_if_not_installed("ggeffects") skip_if_not_installed("marginaleffects") mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error( suppressMessages(res <- tidy_margins(mod)), NA ) # for margins, no result per y.level expect_error( suppressMessages(res <- tidy_all_effects(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_ggpredict(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_avg_slopes(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_avg_comparisons(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_marginal_means(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_marginal_predictions(mod)), NA ) expect_true("y.level" %in% names(res)) expect_type( suppressMessages(p <- plot_marginal_predictions(mod)), "list" ) expect_length(p, 3) expect_error( suppressMessages(res <- tidy_marginal_contrasts(mod)), NA ) expect_true("y.level" %in% names(res)) }) test_that("Marginal tidiers works with ordinal::clm() models", { skip_on_cran() skip_if_not_installed("ordinal") library(ordinal) skip_if_not_installed("margins") skip_if_not_installed("effects") skip_if_not_installed("ggeffects") skip_if_not_installed("marginaleffects") mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) # not supported: tidy_margins(mod) library(MASS) expect_error( res <- tidy_all_effects(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( suppressMessages(res <- tidy_ggpredict(mod)), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_avg_slopes(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_avg_comparisons(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_marginal_means(mod), NA ) expect_true("y.level" %in% names(res)) expect_error( res <- tidy_marginal_predictions(mod), NA ) expect_true("y.level" %in% names(res)) expect_type( p <- plot_marginal_predictions(mod), "list" ) expect_length(p, 1) expect_error( res <- tidy_marginal_contrasts(mod), NA ) expect_true("y.level" %in% names(res)) }) broom.helpers/tests/testthat/test-helpers.R0000644000176200001440000000056214357760764020623 0ustar liggesuserstest_that(".update_vector()", { # y vector must be named expect_error( .update_vector(letters, LETTERS) ) expect_error( .update_vector( c(a = 2, b = 3), c(a = 1, d = 5, 4) ) ) }) test_that(".superscript_numbers ()", { # works with non character vector expect_error( .superscript_numbers(1:4), NA ) }) broom.helpers/tests/testthat/test-add_variable_labels.R0000644000176200001440000002506314457457441023077 0ustar liggesuserstest_that("tidy_add_variable_labels() works for basic models", { # if no variable labels, variable names # term for intercept df <- gtsummary::trial labelled::var_label(df) <- NULL mod <- glm(response ~ age + grade + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c("(Intercept)", "age", "grade", "grade", "trt") ) # if variable labels defined in data, variable labels df <- gtsummary::trial mod <- glm(response ~ age + grade + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c("(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment") ) # if labels provided in `labels`, taken into account res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels( labels = list(`(Intercept)` = "custom intercept", grade = "custom label") ) expect_equivalent( res$var_label, c( "custom intercept", "Age", "custom label", "custom label", "Chemotherapy Treatment" ) ) # labels can also be a named vector res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels( labels = c(`(Intercept)` = "custom intercept", grade = "custom label") ) expect_equivalent( res$var_label, c( "custom intercept", "Age", "custom label", "custom label", "Chemotherapy Treatment" ) ) # no error if providing labels not corresponding to an existing variable # but display a message expect_error( mod %>% tidy_and_attach() %>% tidy_add_variable_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44) ), NA ) expect_message( mod %>% tidy_and_attach() %>% tidy_add_variable_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44) ) ) expect_error( mod %>% tidy_and_attach() %>% tidy_add_variable_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44), strict = TRUE ) ) # model with only an interaction term mod <- lm(age ~ factor(response):marker, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c( "(Intercept)", "factor(response) * Marker Level (ng/mL)", "factor(response) * Marker Level (ng/mL)" ) ) # custom label for interaction term mod <- glm(response ~ age + grade * trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels(labels = c("grade:trt" = "custom label")) expect_equivalent( res$var_label, c( "(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment", "custom label", "custom label" ) ) }) test_that("test tidy_add_variable_labels() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_variable_labels()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_add_variable_labels() %>% tidy_add_variable_labels(), NA ) # cannot be applied after tidy_add_header_rows() expect_error( mod %>% tidy_and_attach() %>% tidy_add_header_rows() %>% tidy_add_variable_labels() ) }) test_that("tidy_add_variable_labels() correctly manages interaction terms", { df <- gtsummary::trial mod <- glm(response ~ age * grade * trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c( "(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment", "Age * Grade", "Age * Grade", "Age * Chemotherapy Treatment", "Grade * Chemotherapy Treatment", "Grade * Chemotherapy Treatment", "Age * Grade * Chemotherapy Treatment", "Age * Grade * Chemotherapy Treatment" ) ) # custom separator and custom labels for certain interaction terms res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels( interaction_sep = ":::", labels = c( "age:grade" = "custom interaction label", "grade:trt" = "a second custom label" ) ) expect_equivalent( res$var_label, c( "(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment", "custom interaction label", "custom interaction label", "Age:::Chemotherapy Treatment", "a second custom label", "a second custom label", "Age:::Grade:::Chemotherapy Treatment", "Age:::Grade:::Chemotherapy Treatment" ) ) }) test_that("tidy_add_variable_labels() works with variables having non standard name", { df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- lm(age ~ marker * `grade of kids`, df) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c( "(Intercept)", "Marker Level (ng/mL)", "Grade", "Grade", "Marker Level (ng/mL) * Grade", "Marker Level (ng/mL) * Grade" ) ) }) test_that("tidy_add_variable_labels() works with stats::poly()", { df <- iris %>% labelled::set_variable_labels(Petal.Length = "Length of petal") mod <- lm(Sepal.Length ~ poly(Sepal.Width, 3) + poly(Petal.Length, 2), df) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels(labels = c(Sepal.Width = "Width of sepal")) expect_equivalent( res$var_label, c( "(Intercept)", "Width of sepal", "Width of sepal", "Width of sepal", "Petal.Length", "Petal.Length" ) ) }) test_that("tidy_add_variable_labels() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_variable_labels(), NA ) }) test_that("tidy_add_variable_labels() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_variable_labels(), NA ) }) test_that("tidy_add_variable_labels() works with survival::coxph", { df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) # check that label attribute in original dataset is preserved mod <- survival::coxph(survival::Surv(ttdeath, death) ~ grade, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_add_reference_rows() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c("Grade", "Grade", "Grade") ) }) test_that("tidy_add_variable_labels() works with survival::survreg", { mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) # check that label attribute in original dataset is preserved mod <- survival::survreg(survival::Surv(ttdeath, death) ~ grade, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_add_reference_rows() %>% tidy_add_variable_labels() expect_equivalent( res$var_label, c("(Intercept)", "Grade", "Grade", "Grade", "Log(scale)") ) }) test_that("tidy_add_variable_labels() works with nnet::multinom", { skip_if_not_installed("nnet") mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) test_that("tidy_add_variable_labels() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_variable_labels(), NA) }) broom.helpers/tests/testthat/test-get_response_variable.R0000644000176200001440000000110414360056067023500 0ustar liggesuserstest_that("model_get_response_variable() works for basic models", { mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) expect_equal( mod %>% model_get_response_variable(), "hp" ) mod <- glm( Survived ~ Class + Age + Sex, data = Titanic %>% as.data.frame(), weights = Freq, family = binomial ) expect_equal( mod %>% model_get_response_variable(), "Survived" ) mod <- lm(Petal.Length ~ Petal.Width + Species, data = iris) expect_equal( mod %>% model_get_response_variable(), "Petal.Length" ) }) broom.helpers/tests/testthat/test-add_coefficients_type.R0000644000176200001440000002547614457457146023504 0ustar liggesuserslibrary(survival) library(gtsummary) test_that("tidy_add_coefficients_type() works for common models", { mod <- lm(Sepal.Length ~ Sepal.Width, iris) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "generic") expect_equivalent(attr(res, "coefficients_label"), "Beta") mod <- glm(Sepal.Length ~ Sepal.Width, iris, family = gaussian) res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "generic") expect_equivalent(attr(res, "coefficients_label"), "exp(Beta)") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "logistic") expect_equivalent(attr(res, "coefficients_label"), "log(OR)") res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "logistic") expect_equivalent(attr(res, "coefficients_label"), "OR") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = binomial(probit)) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "generic") expect_equivalent(attr(res, "coefficients_label"), "Beta") res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "generic") expect_equivalent(attr(res, "coefficients_label"), "exp(Beta)") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = binomial(log)) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "relative_risk") expect_equivalent(attr(res, "coefficients_label"), "log(RR)") res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "relative_risk") expect_equivalent(attr(res, "coefficients_label"), "RR") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = binomial(cloglog)) res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "prop_hazard") expect_equivalent(attr(res, "coefficients_label"), "HR") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "poisson") expect_equivalent(attr(res, "coefficients_label"), "log(IRR)") res <- mod %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "poisson") expect_equivalent(attr(res, "coefficients_label"), "IRR") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson("identity")) res <- mod %>% tidy_and_attach(conf.int = FALSE) %>% tidy_add_coefficients_type() expect_equivalent(attr(res, "coefficients_type"), "generic") expect_equivalent(attr(res, "coefficients_label"), "Beta") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = quasipoisson) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type(exponentiate = TRUE) expect_equivalent(attr(res, "coefficients_type"), "poisson") expect_equivalent(attr(res, "coefficients_label"), "IRR") mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = quasibinomial) res <- mod %>% tidy_and_attach() %>% tidy_add_coefficients_type(exponentiate = TRUE) expect_equivalent(attr(res, "coefficients_type"), "logistic") expect_equivalent(attr(res, "coefficients_label"), "OR") }) test_that("test tidy_add_coefficients_type() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_coefficients_type(exponentiate = TRUE)) # expect an error if no value for exponentiate expect_error(mod %>% tidy_and_attach() %>% tidy_add_coefficients_type(exponentiate = NULL)) expect_error(mod %>% broom::tidy() %>% tidy_attach_model(mod) %>% tidy_add_coefficients_type()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_add_coefficients_type() %>% tidy_add_coefficients_type(), NA ) }) test_that("model_get_coefficients_type() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") }) test_that("model_identify_variables() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial("probit"), data = lme4::cbpp ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial("log"), data = lme4::cbpp ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "relative_risk") mod <- lme4::glmer(response ~ trt + (1 | grade), gtsummary::trial, family = poisson) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "poisson") }) test_that("model_get_coefficients_type() works with survival::coxph", { df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "prop_hazard") }) test_that("model_get_coefficients_type() works with survival::survreg", { mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") }) test_that("model_get_coefficients_type() works with survival::clogit", { resp <- levels(survival::logan$occupation) n <- nrow(survival::logan) indx <- rep(1:n, length(resp)) logan2 <- data.frame(survival::logan[indx, ], id = indx, tocc = factor(rep(resp, each = n)) ) logan2$case <- (logan2$occupation == logan2$tocc) mod <- survival::clogit(case ~ tocc + tocc:education + strata(id), logan2) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with nnet::multinom", { skip_if_not_installed("nnet") mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with survey::svycoxph", { skip_if_not_installed("survey") dpbc <- survey::svydesign(id = ~1, prob = ~1, strata = ~edema, data = survival::pbc) mod <- survey::svycoxph( Surv(time, status > 0) ~ log(bili) + protime + albumin, design = dpbc ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "prop_hazard") }) test_that("tidy_plus_plus() works with survey::svyolr", { skip_if_not_installed("survey") data(api, package = "survey") fpc <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) fpc <- update(fpc, mealcat = cut(meals, c(0, 25, 50, 75, 100))) mod <- survey::svyolr(mealcat ~ avg.ed + mobility + stype, design = fpc) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") }) test_that("model_get_coefficients_type() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") mod <- MASS::polr( Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing, method = "probit" ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") }) test_that("model_get_coefficients_type() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("log"), corstr = "ar1") ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "poisson") }) test_that("model_get_coefficients_type() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "logistic") mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") }) test_that("model_get_coefficients_type() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) res <- mod %>% model_get_coefficients_type() expect_equivalent(res, "generic") }) broom.helpers/tests/testthat/test-tidy_parameters.R0000644000176200001440000000225114357760764022352 0ustar liggesuserstest_that("tidy_parameters() works for basic models", { skip_if_not_installed("parameters") mod <- lm(Petal.Length ~ Petal.Width, iris) expect_error( mod %>% tidy_parameters(), NA ) expect_error( mod %>% tidy_plus_plus(tidy_fun = tidy_parameters), NA ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) expect_error( mod %>% tidy_parameters(), NA ) expect_error( res1 <- mod %>% tidy_plus_plus(tidy_fun = tidy_parameters), NA ) expect_error( res2 <- mod %>% tidy_plus_plus(tidy_fun = tidy_parameters, conf.level = .80), NA ) expect_false(identical(res1$conf.low, res2$conf.low)) expect_error( res <- mod %>% tidy_plus_plus(tidy_fun = tidy_parameters, conf.int = FALSE), NA ) expect_false("conf.low" %in% res) }) test_that("tidy_with_broom_or_parameters() works for basic models", { skip_if_not_installed("parameters") mod <- lm(Petal.Length ~ Petal.Width, iris) expect_error( mod %>% tidy_with_broom_or_parameters(), NA ) expect_error( suppressWarnings("not a model" %>% tidy_with_broom_or_parameters()) ) }) broom.helpers/tests/testthat/test-tidy_plus_plus.R0000644000176200001440000005564014464175037022237 0ustar liggesuserstest_that("tidy_plus_plus() works for basic models", { mod <- lm(Petal.Length ~ Petal.Width, iris) expect_error( mod %>% tidy_plus_plus(), NA ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) expect_error( mod %>% tidy_plus_plus(add_header_rows = TRUE, include = c(stage, grade)), NA ) # combining custom variable labels with categorical_terms_pattern # check that the custom variable labels are passed to model_list_terms_levels() res <- mod %>% tidy_plus_plus( variable_labels = c(grade = "custom"), add_reference_rows = FALSE, categorical_terms_pattern = "{var_label}:{level}/{reference_level}" ) expect_equivalent( res$label, c( "T Stage:T2/T1", "T Stage:T3/T1", "T Stage:T4/T1", "custom:II/I", "custom:III/I", "Chemotherapy Treatment:Drug B/Drug A" ) ) # works with add_n res <- mod %>% tidy_plus_plus(add_n = TRUE) expect_true(all(c("n_obs", "n_event") %in% names(res))) }) test_that("tidy_plus_plus() works with no intercept models", { mod <- glm(response ~ stage + grade - 1, data = gtsummary::trial, family = binomial) expect_error( res <- mod %>% tidy_plus_plus(), NA ) expect_equivalent( res$variable, c("stage", "stage", "stage", "stage", "grade", "grade", "grade") ) expect_equivalent( res$label, c("T1", "T2", "T3", "T4", "I", "II", "III") ) expect_equivalent( res$contrasts_type, c( "no.contrast", "no.contrast", "no.contrast", "no.contrast", "treatment", "treatment", "treatment" ) ) }) test_that("tidy_plus_plus() and functionnal programming", { skip_on_cran() # works with glm expect_error( res <- dplyr::tibble(grade = c("I", "II", "III")) %>% dplyr::mutate( df_model = purrr::map(grade, ~ gtsummary::trial %>% dplyr::filter(grade == ..1)), mv_formula_char = "response ~ trt + age + marker", mv_formula = purrr::map(mv_formula_char, ~ as.formula(.x)), mv_model_form = purrr::map2( mv_formula, df_model, ~ glm(..1, data = ..2) ), mv_tbl_form = purrr::map( mv_model_form, ~ tidy_plus_plus(..1, exponentiate = TRUE, add_header_rows = TRUE) ) ), NA ) # for coxph, identification of variables will not work # will display a message # but a result should be returned expect_message( suppressWarnings( res <- dplyr::tibble(grade = c("I", "II", "III")) %>% dplyr::mutate( df_model = purrr::map(grade, ~ gtsummary::trial %>% dplyr::filter(grade == ..1)), mv_formula_char = "survival::Surv(ttdeath, death) ~ trt + age + marker", mv_formula = purrr::map(mv_formula_char, ~ as.formula(.x)), mv_model_form = purrr::map2( mv_formula, df_model, ~ survival::coxph(..1, data = ..2) ), mv_tbl_form = purrr::map( mv_model_form, ~ tidy_plus_plus(..1, exponentiate = TRUE) ) ) ) ) }) test_that("tidy_plus_plus() with mice objects", { skip_on_cran() skip_if(packageVersion("mice") < "3.12.0") # impute missing values imputed_trial <- suppressWarnings(mice::mice(gtsummary::trial, maxit = 2, m = 2, print = FALSE)) # build regression model mod <- with(imputed_trial, lm(age ~ marker + grade)) # testing pre-pooled results expect_error( tidy_plus_plus( mod, exponentiate = FALSE, tidy_fun = function(x, ...) mice::pool(x) %>% mice::tidy(...) ), NA ) }) test_that("tidy_plus_plus() with tidyselect", { skip_on_cran() # build regression model mod <- lm(age ~ trt + marker + grade, gtsummary::trial) expect_error( tidy_plus_plus( mod, add_header_rows = TRUE, show_single_row = trt, no_reference_row = grade ), NA ) expect_equal( tidy_plus_plus( mod, add_header_rows = TRUE, show_single_row = "trt", no_reference_row = "grade" ), tidy_plus_plus( mod, add_header_rows = TRUE, show_single_row = trt, no_reference_row = grade ) ) }) test_that("tidy_plus_plus() works with stats::aov", { skip_on_cran() mod <- aov(yield ~ block + N * P * K, npk) expect_error( res <- tidy_plus_plus(mod), NA ) expect_equivalent( res$variable, c("block", "N", "P", "K", "N:P", "N:K", "P:K") ) }) test_that("tidy_plus_plus() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") skip_if_not_installed("broom.mixed") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) skip_if_not_installed("broom.mixed") expect_error( res <- mod %>% tidy_plus_plus(), NA ) mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial("probit"), data = lme4::cbpp ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with lme4::glmer.nb", { skip_on_cran() skip_if_not_installed("lme4") skip_if_not_installed("MASS") library(lme4) suppressMessages( mod <- lme4::glmer.nb(Days ~ Age + Eth + (1 | Sex), data = MASS::quine) ) skip_if_not_installed("broom.mixed") expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survival::coxph", { skip_on_cran() df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survival::survreg", { skip_on_cran() mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survival::clogit", { skip_on_cran() library(survival) resp <- levels(survival::logan$occupation) n <- nrow(survival::logan) indx <- rep(1:n, length(resp)) logan2 <- data.frame(survival::logan[indx, ], id = indx, tocc = factor(rep(resp, each = n)) ) logan2$case <- (logan2$occupation == logan2$tocc) mod <- survival::clogit(case ~ tocc + tocc:education + strata(id), logan2) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with nnet::multinom", { skip_on_cran() suppressMessages( mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE ) ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) expect_equivalent( res$y.level, c( "II", "II", "II", "II", "II", "II", "III", "III", "III", "III", "III", "III" ) ) expect_equivalent( res$term, c( "stageT1", "stageT2", "stageT3", "stageT4", "marker", "age", "stageT1", "stageT2", "stageT3", "stageT4", "marker", "age" ) ) # multinom model with binary outcome suppressMessages( mod <- nnet::multinom( response ~ stage + marker + age, data = gtsummary::trial, trace = FALSE ) ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survey::svyglm", { skip_on_cran() skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survey::svycoxph", { skip_on_cran() skip_if_not_installed("survey") dpbc <- survey::svydesign(id = ~1, prob = ~1, strata = ~edema, data = survival::pbc) mod <- survey::svycoxph( Surv(time, status > 0) ~ log(bili) + protime + albumin, design = dpbc ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with survey::svyolr", { skip_on_cran() skip_if_not_installed("survey") data(api, package = "survey") fpc <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) fpc <- update(fpc, mealcat = cut(meals, c(0, 25, 50, 75, 100))) mod <- survey::svyolr(mealcat ~ avg.ed + mobility + stype, design = fpc) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with ordinal::clm", { skip_on_cran() skip_if_not_installed("ordinal") mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with ordinal::clmm", { skip_on_cran() skip_if_not_installed("ordinal") mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with MASS::polr", { skip_on_cran() mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with MASS::glm.nb", { skip_on_cran() mod <- MASS::glm.nb(Days ~ Sex / (Age + Eth * Lrn), data = MASS::quine) expect_error( suppressWarnings(res <- mod %>% tidy_plus_plus()), NA ) }) test_that("tidy_plus_plus() works with geepack::geeglm", { skip_on_cran() skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("log"), corstr = "ar1") ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with gam::gam", { skip_on_cran() skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with brms::brm", { skip_on_cran() skip_if_not_installed("broom.mixed") skip_if_not_installed("brms") skip_if(packageVersion("brms") < "2.13") skip_if_not_installed("rstanarm") load(system.file("extdata", "brms_example.rda", package = "broom.mixed")) mod <- brms_crossedRE expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with rstanarm::stan_glm", { skip_on_cran() skip_if_not_installed("broom.mixed") skip_if_not_installed("rstanarm") mod <- rstanarm::stan_glm( response ~ age + grade, data = gtsummary::trial, refresh = 0, family = binomial ) expect_error( res <- mod %>% tidy_plus_plus(tidy_fun = broom.mixed::tidy), NA ) }) test_that("tidy_plus_plus() works with cmprsk::crr", { skip_on_cran() skip_if_not_installed("cmprsk") skip_if(packageVersion("broom") < "0.7.4") ftime <- rexp(200) fstatus <- sample(0:2, 200, replace = TRUE) cov <- matrix(runif(600), nrow = 200) dimnames(cov)[[2]] <- c("x1", "x2", "x3") mod <- cmprsk::crr(ftime, fstatus, cov) expect_error( res <- mod %>% tidy_plus_plus(quiet = TRUE), NA ) }) test_that("tidy_plus_plus() works with tidycmprsk::crr", { skip_on_cran() skip_if_not_installed("tidycmprsk") mod <- tidycmprsk::crr(Surv(ttdeath, death_cr) ~ age + grade, tidycmprsk::trial) expect_error( res <- mod %>% tidy_plus_plus(quiet = TRUE), NA ) }) test_that("tidy_plus_plus() works with stats::nls", { skip_on_cran() mod <- stats::nls( Petal.Width ~ a * Petal.Length - (Sepal.Width + Sepal.Length) / b + a^2, data = iris, start = list(a = 1, b = 1) ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with lavaan::lavaan", { skip_on_cran() skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with lfe::felm", { skip_on_cran() skip_if_not_installed("lfe") mod <- lfe::felm(marker ~ age + grade | stage | 0, gtsummary::trial) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() error messaging", { # does not allow for exponentiate, conf.inf, conf.level arguments bad_tidy <- function(x) { broom::tidy } expect_error( lm(mpg ~ cyl, mtcars) %>% tidy_plus_plus(tidy_fun = bad_tidy) ) }) test_that("tidy_plus_plus() works with mgcv::gam", { skip_on_cran() skip_if_not_installed("mgcv") tidy_gam <- function(x, conf.int = FALSE, exponentiate = FALSE, ...) { broom::tidy(x, conf.int = conf.int, exponentiate = exponentiate, parametric = TRUE, ... ) %>% dplyr::mutate(parametric = TRUE) %>% dplyr::bind_rows( broom::tidy(x, parametric = FALSE, ...) %>% dplyr::mutate(parametric = FALSE) ) %>% dplyr::relocate(parametric, .after = dplyr::last_col()) } gam_logistic <- mgcv::gam( response ~ s(marker, ttdeath) + grade + age, data = gtsummary::trial, family = binomial ) gam_linear <- mgcv::gam(response ~ s(marker, ttdeath) + grade, data = gtsummary::trial) gam_smooth_only <- mgcv::gam(response ~ s(marker, ttdeath), data = gtsummary::trial) gam_param_only <- mgcv::gam(response ~ grade, data = gtsummary::trial) expect_error(tbl_gam_logistic <- gam_logistic %>% tidy_plus_plus(tidy_fun = tidy_gam), NA) expect_error(gam_logistic %>% tidy_plus_plus(), NA) expect_error(tbl_gam_linear <- gam_linear %>% tidy_plus_plus(tidy_fun = tidy_gam), NA) expect_error(gam_linear %>% tidy_plus_plus(), NA) expect_error(tbl_gam_smooth_only <- gam_smooth_only %>% tidy_plus_plus(tidy_fun = tidy_gam), NA) expect_error(gam_smooth_only %>% tidy_plus_plus(), NA) expect_error(tbl_gam_param_only <- gam_param_only %>% tidy_plus_plus(tidy_fun = tidy_gam), NA) # the default tidier return a df with no columns and no rows...it fails. }) test_that("tidy_plus_plus() works with VGAM::vglm", { skip_on_cran() skip_if_not_installed("VGAM") skip_if_not_installed("parameters") df <- data.frame( treatment = gl(3, 3), outcome = gl(3, 1, 9), counts = c(18, 17, 15, 20, 10, 20, 25, 13, 12) ) mod <- VGAM::vglm( counts ~ outcome + treatment, family = VGAM::poissonff, data = df, trace = FALSE ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with plm::plm", { skip_on_cran() skip_if_not_installed("plm") data("Grunfeld", package = "plm") mod <- plm::plm( inv ~ value + capital, data = Grunfeld, model = "within", index = c("firm", "year") ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with biglm::bigglm", { skip_on_cran() skip_if_not_installed("biglm") skip_if(compareVersion(as.character(getRversion()), "3.6") < 0) mod <- biglm::bigglm( response ~ age + trt, data = as.data.frame(gtsummary::trial), family = binomial() ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) # check that reference rows are properly added expect_equal( res %>% dplyr::filter(variable == "trt") %>% purrr::pluck("reference_row"), c(TRUE, FALSE) ) }) test_that("tidy_plus_plus() works with biglmm::bigglm", { skip_on_cran() skip_if_not_installed("biglmm") skip_if(compareVersion(as.character(getRversion()), "3.6") < 0) mod <- biglmm::bigglm( response ~ age + trt, data = as.data.frame(gtsummary::trial), family = binomial() ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) # check that reference rows are properly added expect_equal( res %>% dplyr::filter(variable == "trt") %>% purrr::pluck("reference_row"), c(TRUE, FALSE) ) }) test_that("tidy_plus_plus() works with parsnip::model_fit object", { skip_on_cran() skip_if_not_installed("parsnip") d <- gtsummary::trial d$response <- as.factor(d$response) mod1 <- glm(response ~ stage + grade + trt, d, family = binomial) mod2 <- parsnip::logistic_reg() %>% parsnip::set_engine("glm") %>% parsnip::fit(response ~ stage + grade + trt, data = d) res1 <- mod1 %>% tidy_plus_plus(exponentiate = TRUE) expect_error( res2 <- mod2 %>% tidy_plus_plus(exponentiate = TRUE), NA ) expect_equivalent(res1, res2) }) test_that("tidy_plus_plus() works with fixest models", { skip_on_cran() skip_if_not_installed("fixest") skip_if(compareVersion(as.character(getRversion()), "4.1") < 0) mod <- fixest::feols(fml = mpg ~ am + factor(carb), data = mtcars) expect_error( res <- mod %>% tidy_plus_plus(), NA ) mod <- fixest::feglm(Sepal.Length ~ Sepal.Width + Petal.Length | Species, iris, "poisson") expect_error( res <- mod %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with logitr models", { skip_on_cran() skip_if_not(.assert_package("logitr", boolean = TRUE)) mod <- logitr::logitr( data = logitr::yogurt %>% head(1000), outcome = "choice", obsID = "obsID", pars = c("feat", "brand"), scalePar = "price", randScale = "n", numMultiStarts = 1 ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) expect_true("scalePar" %in% res$variable) }) test_that("tidy_plus_plus() works with multgee models", { skip_on_cran() skip_if_not_installed("multgee") skip_if_not_installed("parameters") library(multgee) mod <- multgee::nomLORgee( y ~ factor(time) * sec, data = multgee::housing, id = id, repeated = time, ) expect_error( res <- mod %>% tidy_plus_plus(), NA ) expect_equivalent( res$y.level, c( "1", "1", "1", "1", "1", "1", "1", "1", "2", "2", "2", "2", "2", "2", "2", "2" ) ) expect_equivalent( res$term, c( "factor(time)0", "factor(time)6", "factor(time)12", "factor(time)24", "sec", "factor(time)6:sec", "factor(time)12:sec", "factor(time)24:sec", "factor(time)0", "factor(time)6", "factor(time)12", "factor(time)24", "sec", "factor(time)6:sec", "factor(time)12:sec", "factor(time)24:sec" ) ) mod2 <- ordLORgee( formula = y ~ factor(time) + factor(trt) + factor(baseline), data = multgee::arthritis, id = id, repeated = time, LORstr = "uniform" ) expect_error( res <- mod2 %>% tidy_plus_plus(), NA ) }) test_that("tidy_plus_plus() works with pscl::zeroinfl() & hurdle() models", { skip_on_cran() skip_if_not_installed("pscl") skip_if_not_installed("parameters") library(pscl) data("bioChemists", package = "pscl") m1 <- zeroinfl(art ~ fem + mar + phd | fem + mar + phd, data = bioChemists) m2 <- zeroinfl(art ~ fem + mar + phd | 1, data = bioChemists, dist = "negbin") m3 <- zeroinfl(art ~ fem + mar + phd | fem, data = bioChemists) m4 <- hurdle(art ~ fem + mar + phd | fem, data = bioChemists) expect_message( res <- m1 %>% tidy_plus_plus() ) expect_message( res <- m4 %>% tidy_plus_plus() ) expect_error( res <- m1 %>% tidy_plus_plus(exponentiate = TRUE, tidy_fun = tidy_zeroinfl), NA ) expect_equal(nrow(res), 10) expect_error( res <- m1 %>% tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl), NA ) expect_equal(nrow(res), 12) expect_error( res <- m2 %>% tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl), NA ) expect_equal(nrow(res), 7) expect_error( res <- m3 %>% tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl), NA ) expect_equal(nrow(res), 9) expect_error( res <- m4 %>% tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl), NA ) expect_equal(nrow(res), 9) expect_error( m3 %>% tidy_plus_plus(add_pairwise_contrasts = TRUE) ) expect_error( m4 %>% tidy_plus_plus(add_pairwise_contrasts = TRUE) ) }) test_that("tidy_plus_plus() works with betareg::betareg() models", { skip_on_cran() skip_if_not_installed("betareg") skip_if_not_installed("parameters") library(betareg) data("GasolineYield", package = "betareg") m1 <- betareg(yield ~ batch + temp, data = GasolineYield) m2 <- betareg(yield ~ batch + temp | temp + pressure, data = GasolineYield) m3 <- betareg(yield ~ temp | temp + batch, data = GasolineYield) m4 <- betareg(yield ~ temp + batch | temp + batch, data = GasolineYield) expect_error( res <- m1 %>% tidy_plus_plus(intercept = TRUE), NA ) expect_equal(nrow(res), 13) expect_error( res <- m1 %>% tidy_plus_plus(exponentiate = TRUE), NA ) expect_equal(nrow(res), 11) expect_error( res <- m1 %>% tidy_plus_plus(add_header_rows = TRUE), NA ) expect_equal(nrow(res), 12) expect_error( res <- m2 %>% tidy_plus_plus(intercept = TRUE), NA ) expect_equal(nrow(res), 15) expect_error( res <- m2 %>% tidy_plus_plus(exponentiate = TRUE), NA ) expect_equal(nrow(res), 13) expect_error( res <- m2 %>% tidy_plus_plus(component = "conditional"), NA ) expect_equal(nrow(res), 11) expect_error( res <- m2 %>% tidy_plus_plus(add_header_rows = TRUE), NA ) expect_equal(nrow(res), 14) expect_error( res <- m3 %>% tidy_plus_plus(intercept = TRUE), NA ) expect_equal(nrow(res), 14) expect_error( res <- m3 %>% tidy_plus_plus(exponentiate = TRUE), NA ) expect_equal(nrow(res), 12) expect_error( res <- m3 %>% tidy_plus_plus(component = "mean"), NA ) expect_equal(nrow(res), 1) expect_error( m3 %>% tidy_plus_plus(add_pairwise_contrasts = TRUE) ) expect_error( res <- m4 %>% tidy_plus_plus(add_header_rows = TRUE), NA ) expect_equal(nrow(res), 24) }) broom.helpers/tests/testthat/test-select_helpers.R0000644000176200001440000002624014457457200022150 0ustar liggesuserstest_that("select_helpers: .select_to_varnames", { expect_error( .select_to_varnames(mpg) ) expect_equal( .select_to_varnames(select = vars(hp, mpg), data = mtcars), dplyr::select(mtcars, hp, mpg) %>% colnames() ) expect_equal( .select_to_varnames(select = mpg, data = mtcars), dplyr::select(mtcars, mpg) %>% colnames() ) expect_equal( .select_to_varnames(select = "mpg", data = mtcars), dplyr::select(mtcars, "mpg") %>% colnames() ) expect_equal( .select_to_varnames(select = c("hp", "mpg"), data = mtcars), dplyr::select(mtcars, c("hp", "mpg")) %>% colnames() ) expect_equal( .select_to_varnames(select = c(hp, mpg), data = mtcars), dplyr::select(mtcars, c(hp, mpg)) %>% colnames() ) expect_equal( .select_to_varnames(select = NULL, data = mtcars), NULL ) expect_equal( .select_to_varnames(select = vars(dplyr::everything(), -mpg), data = mtcars), dplyr::select(mtcars, dplyr::everything(), -mpg) %>% colnames() ) }) test_that("select_helpers: all_*()", { mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) mod_tidy <- tidy_and_attach(mod) expect_equal( tidy_select_variables(mod_tidy, include = all_categorical())$variable %>% na.omit() %>% unique(), c("(Intercept)", "trt", "grade") ) expect_equal( tidy_select_variables(mod_tidy, include = all_categorical(dichotomous = FALSE))$variable %>% na.omit() %>% unique(), c("(Intercept)", "grade") ) expect_equal( tidy_select_variables(mod_tidy, include = all_continuous())$variable %>% na.omit() %>% unique(), c("(Intercept)", "age") ) expect_equal( tidy_select_variables(mod_tidy, include = all_dichotomous())$variable %>% na.omit() %>% unique(), c("(Intercept)", "trt") ) expect_equal( tidy_select_variables(mod_tidy, include = all_interaction())$variable %>% na.omit() %>% unique(), c("(Intercept)", "age:trt") ) }) test_that("select_helpers: tidy_plus_plus", { skip_on_cran() mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) mod2 <- glm(response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sum, grade = contr.poly, trt = contr.helmert ) ) mod3 <- glm( response ~ stage + grade + trt + factor(death), gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, 3), grade = contr.treatment(3, 2), trt = contr.treatment(2, 2), "factor(death)" = matrix(c(-3, 2)) ) ) expect_equal( tidy_plus_plus(mod3, include = all_contrasts("treatment"))$variable %>% na.omit() %>% unique(), c("stage", "grade", "trt") ) expect_equal( tidy_plus_plus(mod3, include = all_contrasts("other"))$variable %>% na.omit() %>% unique(), c("factor(death)") ) expect_equal( tidy_plus_plus(mod, include = all_contrasts())$variable %>% na.omit() %>% unique(), c("trt", "grade") ) expect_equal( tidy_plus_plus(mod, include = all_categorical())$variable %>% na.omit() %>% unique(), c("trt", "grade") ) expect_equal( tidy_plus_plus(mod, include = all_contrasts("treatment"))$variable %>% na.omit() %>% unique(), c("trt", "grade") ) expect_equal( tidy_plus_plus(mod, include = all_continuous())$variable %>% na.omit() %>% unique(), c("age") ) expect_equal( tidy_plus_plus(mod, include = all_dichotomous())$variable %>% na.omit() %>% unique(), c("trt") ) expect_equal( tidy_plus_plus(mod, include = all_interaction())$variable %>% na.omit() %>% unique(), c("age:trt") ) expect_equal( tidy_plus_plus(mod, include = all_intercepts(), intercept = TRUE)$variable %>% na.omit() %>% unique(), c("(Intercept)") ) expect_equal( tidy_plus_plus(mod, add_header_rows = TRUE, show_single_row = all_dichotomous() )$variable %in% "trt" %>% sum(), 1L ) skip_if_not_installed("emmeans") expect_equal( tidy_plus_plus(mod2, include = all_contrasts("sum"))$variable %>% na.omit() %>% unique(), c("stage") ) expect_equal( tidy_plus_plus(mod2, include = all_contrasts("poly"))$variable %>% na.omit() %>% unique(), c("grade") ) expect_equal( tidy_plus_plus(mod2, include = all_contrasts("helmert"))$variable %>% na.omit() %>% unique(), c("trt") ) skip_on_cran() skip_if_not_installed("lme4") mod3 <- lme4::lmer(age ~ stage + (stage | grade) + (1 | grade), gtsummary::trial) res <- mod3 %>% tidy_plus_plus( tidy_fun = broom.mixed::tidy, include = all_ran_pars() ) expect_equal( res$term, c( "grade.sd__(Intercept)", "grade.cor__(Intercept).stageT2", "grade.cor__(Intercept).stageT3", "grade.cor__(Intercept).stageT4", "grade.sd__stageT2", "grade.cor__stageT2.stageT3", "grade.cor__stageT2.stageT4", "grade.sd__stageT3", "grade.cor__stageT3.stageT4", "grade.sd__stageT4", "grade.1.sd__(Intercept)", "Residual.sd__Observation" ) ) res <- mod3 %>% tidy_plus_plus( tidy_fun = broom.mixed::tidy, include = all_ran_vals() ) expect_equal(res %>% nrow(), 0L) }) test_that("select_helpers: tidy_add_header_rows", { mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) mod_tidy <- tidy_and_attach(mod) expect_equal( tidy_add_header_rows(mod_tidy, show_single_row = all_dichotomous())$variable %in% "trt" %>% sum(), 1L ) }) test_that("select_helpers: tidy_add_variable_labels", { mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) mod_tidy <- tidy_and_attach(mod) expect_error( tidy_add_variable_labels(mod_tidy, labels = where(is.numeric) ~ "NUMERIC"), NA ) expect_equal( tidy_add_variable_labels(mod_tidy, labels = list( `(Intercept)` ~ "b0", age ~ "AGE", trt ~ "Drug", "grade" ~ "Grade", contains("age:") ~ "Interaction" ) ) %>% dplyr::pull(var_label) %>% unique(), c("b0", "AGE", "Drug", "Grade", "Interaction") ) }) test_that("select_helpers: .select_to_varnames", { expect_error( .select_to_varnames(c(mpg, hp), data = mtcars, select_single = TRUE) ) }) test_that("select_helpers: .generic_selector ", { mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) expect_error( tidy_and_attach(mod) %>% tidy_identify_variables() %>% tidy_add_variable_labels(labels = all_contrasts("helmert") ~ "HELMERT!") ) expect_error( all_continuous() ) expect_equal( .var_info_to_df(letters) %>% names(), letters ) }) test_that("select_helpers: .formula_list_to_named_list ", { mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) tidy_mod <- tidy_plus_plus(mod) expect_error( .formula_list_to_named_list(list(age ~ "Age", TRUE), var_info = tidy_mod) ) expect_error( .formula_list_to_named_list(list(age ~ "Age"), var_info = tidy_mod, type_check = is.character ), NA ) expect_error( .formula_list_to_named_list(list(age ~ "Age"), var_info = tidy_mod, type_check = is.logical ) ) expect_error( .formula_list_to_named_list(letters, var_info = tidy_mod, type_check = is.logical ) ) expect_equal( .formula_list_to_named_list(age ~ "Age", var_info = tidy_mod), list(age = "Age") ) expect_equal( .formula_list_to_named_list(~"Age", var_info = tidy_mod), list(age = "Age", trt = "Age", grade = "Age", `age:trt` = "Age") ) expect_equal( .formula_list_to_named_list(list(~"Age", `age:trt` = "interact"), var_info = tidy_mod), list(age = "Age", trt = "Age", grade = "Age", `age:trt` = "interact") ) expect_error( .formula_list_to_named_list(list(age ~ "Age"), var_info = tidy_mod, type_check = is.logical, arg_name = "label" ) ) expect_error( .formula_list_to_named_list(list(age ~ "Age"), var_info = tidy_mod, type_check = is.logical, arg_name = "label", type_check_msg = "Age msg error" ), "Age msg error" ) expect_error( .formula_list_to_named_list("Age", var_info = tidy_mod, type_check = rlang::is_string, arg_name = "label" ), "Did you mean `everything" ) expect_error( .formula_list_to_named_list("Age", var_info = tidy_mod, type_check = rlang::is_string, arg_name = "label" ), "Age" ) expect_error( .formula_list_to_named_list(~"Age", var_info = tidy_mod, type_check = rlang::is_string, arg_name = "label" ), NA ) expect_error( .formula_list_to_named_list(list(age ~ NULL), var_info = tidy_mod, type_check = is.logical ), NA ) expect_error( .formula_list_to_named_list(list(age ~ NULL), var_info = tidy_mod, type_check = is.logical, null_allowed = FALSE ) ) expect_error( select_test <- .formula_list_to_named_list( list(response = "Response", dplyr::contains("age") ~ "?AGE?", trt = NULL), data = gtsummary::trial, arg_name = "label", type_check = rlang::is_string, type_check_msg = NULL, null_allowed = TRUE ), NA ) expect_equal( select_test, list(response = "Response", age = "?AGE?", stage = "?AGE?", trt = NULL) ) expect_error( .formula_list_to_named_list( list(response = "Response", dplyr::contains("age") ~ "?AGE?", trt = NULL), data = gtsummary::trial, arg_name = "label", type_check = rlang::is_string, type_check_msg = NULL, null_allowed = FALSE ) ) expect_error( .formula_list_to_named_list( list(response = "Response", dplyr::contains("age") ~ "?AGE?", trt = NULL), data = gtsummary::trial, arg_name = "label", select_single = TRUE ) ) expect_error( .formula_list_to_named_list( list(response = "Response", dplyr::contains("age") ~ "?AGE?", trt = NULL), data = gtsummary::trial, select_single = TRUE ) ) }) test_that("select_helpers: .scope_var_info", { mod_tidy <- lm(mpg ~ hp, mtcars) %>% tidy_and_attach() # can scope a data frame with no variable expect_error( .scope_var_info(mod_tidy %>% tidy_identify_variables()), NA ) # no error when non-data frame is scoped expect_error( .scope_var_info(mod_tidy$term), NA ) }) test_that("select_helpers: .var_info_to_df ", { mod_tidy <- lm(mpg ~ hp, mtcars) %>% tidy_and_attach() # can convert a tibble without a var_class column expect_error( .var_info_to_df(mod_tidy %>% tidy_identify_variables() %>% dplyr::select(-var_class)), NA ) }) broom.helpers/tests/testthat/test-add_header_rows.R0000644000176200001440000001501314457457154022265 0ustar liggesuserstest_that("tidy_add_header_rows() works as expected", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.treatment, grade = contr.SAS, trt = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_header_rows() expect_equivalent( res$label, c( "(Intercept)", "T Stage", "T2", "T3", "T4", "Grade", "I", "II", "Chemotherapy Treatment", "Drug A", "Grade * Chemotherapy Treatment", "I * Drug A", "II * Drug A" ) ) expect_equivalent( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE ) ) expect_equivalent( res$var_nlevels, c(NA, 4L, 4L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, NA, NA, NA) ) # show_single_row has an effect only on variables with one term (2 if a ref term) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_add_header_rows(show_single_row = everything(), quiet = TRUE) expect_equivalent( res$label, c( "(Intercept)", "T Stage", "T2", "T3", "T4", "Grade", "I", "II", "Chemotherapy Treatment", "Grade * Chemotherapy Treatment", "I * Drug A", "II * Drug A" ) ) expect_equivalent( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, NA, TRUE, FALSE, FALSE ) ) # with reference rows res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_header_rows() expect_equivalent( res$label, c( "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Grade", "I", "II", "III", "Chemotherapy Treatment", "Drug A", "Drug B", "Grade * Chemotherapy Treatment", "I * Drug A", "II * Drug A" ) ) expect_equivalent( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE ) ) # no warning with an intercept only model mod <- lm(mpg ~ 1, mtcars) expect_warning( mod %>% tidy_and_attach() %>% tidy_add_header_rows(), NA ) # header row for all categorical variable (even if no reference row) # and if interaction with a categorical variable # (except if ) mod <- lm(age ~ factor(response) * marker + trt, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_add_header_rows(show_single_row = "trt") expect_equivalent( res$header_row, c(NA, TRUE, FALSE, NA, NA, TRUE, FALSE) ) # show_single_row could be apply to an interaction variable mod <- lm(age ~ factor(response) * marker, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_add_header_rows(show_single_row = "factor(response):marker") expect_equivalent( res$header_row, c(NA, TRUE, FALSE, NA, NA) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_header_rows(show_single_row = "factor(response):marker") expect_equivalent( res$header_row, c(NA, TRUE, FALSE, FALSE, NA, NA) ) expect_equivalent( res$var_label, c( "(Intercept)", "factor(response)", "factor(response)", "factor(response)", "Marker Level (ng/mL)", "factor(response) * Marker Level (ng/mL)" ) ) # no standard name mod <- lm( hp ~ `miles per gallon`, mtcars %>% dplyr::rename(`miles per gallon` = mpg) ) res <- mod %>% tidy_and_attach() %>% tidy_add_header_rows() expect_equivalent( res$header_row, c(NA, NA) ) mod <- lm( hp ~ `cyl as factor`, mtcars %>% dplyr::mutate(`cyl as factor` = factor(cyl)) ) res <- mod %>% tidy_and_attach() %>% tidy_add_header_rows() expect_equivalent( res$header_row, c(NA, TRUE, FALSE, FALSE) ) }) test_that("test tidy_add_header_rows() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_header_rows()) # warning if applied twice expect_message( mod %>% tidy_and_attach() %>% tidy_add_header_rows() %>% tidy_add_header_rows() ) }) test_that("tidy_add_header_rows() works with nnet::multinom", { skip_if_not_installed("nnet") skip_on_cran() mod <- nnet::multinom(grade ~ stage + marker + age + trt, data = gtsummary::trial, trace = FALSE) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_header_rows() expect_equivalent( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, TRUE, FALSE, FALSE, NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, TRUE, FALSE, FALSE ) ) expect_equivalent( res$label, c( "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Marker Level (ng/mL)", "Age", "Chemotherapy Treatment", "Drug A", "Drug B", "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Marker Level (ng/mL)", "Age", "Chemotherapy Treatment", "Drug A", "Drug B" ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_header_rows(show_single_row = everything(), quiet = TRUE) expect_equivalent( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, NA, NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, NA ) ) expect_equivalent( res$label, c( "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Marker Level (ng/mL)", "Age", "Chemotherapy Treatment", "(Intercept)", "T Stage", "T1", "T2", "T3", "T4", "Marker Level (ng/mL)", "Age", "Chemotherapy Treatment" ) ) }) test_that("test tidy_add_header_rows() bad single row request", { mod <- lm(mpg ~ hp + factor(cyl) + factor(am), mtcars) %>% tidy_and_attach() %>% tidy_identify_variables() expect_message( tidy_add_header_rows(mod, show_single_row = "factor(cyl)") ) expect_error( tidy_add_header_rows(mod, show_single_row = "factor(cyl)", strict = TRUE) ) }) test_that("tidy_add_header_rows() and mixed model", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer( age ~ stage + (stage | grade) + (1 | grade), gtsummary::trial ) res <- mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_header_rows() expect_equal( res %>% dplyr::filter(.data$header_row & .data$var_type == "ran_pars") %>% nrow(), 0L ) }) broom.helpers/tests/testthat/test-attach_and_detach.R0000644000176200001440000000205014457457164022547 0ustar liggesuserstest_that("Attach and Detach models works", { mod <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) expect_identical( mod, mod %>% tidy_and_attach() %>% tidy_get_model() ) tb <- broom::tidy(mod) expect_equivalent( tb, tb %>% tidy_attach_model(mod) %>% tidy_detach_model() ) # an error should occur if 'exponentiate = TRUE' for a linear model expect_error( mod %>% tidy_and_attach(exponentiate = TRUE) ) }) test_that("tidy_and_attach() handles models without exponentiate arguments", { skip_if_not_installed("lavaan") skip_on_cran() df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(mod %>% tidy_and_attach(exponentiate = TRUE)) expect_error(mod %>% tidy_and_attach(), NA) }) broom.helpers/tests/testthat/test-model_get_n.R0000644000176200001440000003120314457457175021431 0ustar liggesuserstest_that("model_get_n() works for basic models", { mod <- lm(Sepal.Length ~ ., iris) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(150, 150, 150, 150, 50, 50, 50) ) mod <- lm( Sepal.Length ~ log(Sepal.Width) + Petal.Length^2, iris ) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(150, 150, 150) ) # logistic model mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(193, 52, 40, 49, 63, 63, 98, 52, 67, 95) ) expect_equivalent( res$n_event, c(61, 13, 15, 15, 19, 21, 33, 18, 21, 28) ) mod <- glm( Survived ~ Class * Age + Sex, data = Titanic %>% as.data.frame(), weights = Freq, family = binomial ) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(2201, 285, 706, 885, 2092, 470, 261, 627, 885, 325, 109, 1731) ) expect_equivalent( res$n_event, c(711, 118, 178, 212, 654, 344, 94, 151, 212, 203, 57, 367) ) # cbind() syntax d <- dplyr::as_tibble(Titanic) %>% dplyr::group_by(Class, Sex, Age) %>% dplyr::summarise( n_survived = sum(n * (Survived == "Yes")), n_dead = sum(n * (Survived == "No")) ) mod <- glm( cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial, y = FALSE # should work even if y is not returned ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent( res$n_obs, c(2201, 285, 706, 885, 109, 1731, 24, 79, 0, 325, 2092, 470) ) expect_equivalent( res$n_event, c(711, 118, 178, 212, 57, 367, 24, 27, 0, 203, 654, 344) ) # Poisson without offset mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(183, 183, 58, 60, 94, 29, 33, 65, 89) ) expect_equivalent( res$n_event, c(58, 58, 17, 20, 31, 10, 8, 21, 27) ) expect_equivalent( res$exposure, c(183, 183, 58, 60, 94, 29, 33, 65, 89) ) # Poisson with offset mod <- glm( response ~ trt * grade + offset(log(ttdeath)), gtsummary::trial, family = poisson, weights = rep_len(1:2, 200) ) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(292, 151, 94, 92, 49, 49, 141, 106) ) expect_equivalent( res$n_event, c(96, 53, 28, 31, 19, 12, 43, 37) ) expect_equivalent( res$exposure %>% round(), c(5819, 2914, 1826, 1766, 887, 916, 2905, 2227) ) # interaction only terms mod <- glm( Survived ~ Class:Age, data = Titanic %>% as.data.frame(), weights = Freq, family = binomial ) res <- mod %>% model_get_n() expect_equivalent( res$n_obs, c(2201, 6, 24, 79, 0, 319, 261, 627, 885) ) expect_equivalent( res$n_event, c(711, 6, 24, 27, 0, 197, 94, 151, 212) ) }) test_that("model_get_n() handles variables having non standard name", { df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- glm(response ~ stage + `grade of kids` + trt, df, family = binomial, contrasts = list(`grade of kids` = contr.sum) ) expect_error( res <- mod %>% model_get_n(), NA ) }) test_that("model_get_n() works with different contrasts", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.treatment, grade = contr.SAS, trt = contr.SAS) ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) if ("stage2" %in% names(coef(mod))) { expect_equivalent( res$term, c( "(Intercept)", "stage2", "stage3", "stage4", "grade1", "grade2", "trt1", "grade1:trt1", "grade2:trt1", "stage1", "grade3", "trt2" ) ) } else { expect_equivalent( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "trtDrug A", "gradeI:trtDrug A", "gradeII:trtDrug A", "stageT1", "gradeIII", "trtDrug B" ) ) } expect_equivalent( res$n_obs, c(193, 52, 40, 49, 67, 63, 95, 35, 30, 52, 63, 98) ) mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.helmert, trt = contr.sum) ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) expect_equivalent( res$term, c( "(Intercept)", "stage.L", "stage.Q", "stage.C", "grade1", "grade2", "trt1", "grade1:trt1", "grade2:trt1", "trt2" ) ) expect_equivalent( res$n_obs, c(193, 193, 193, 193, 63, 63, 95, 62, 95, 98) ) }) test_that("model_get_n() works with stats::poly()", { skip_on_cran() mod <- lm(Sepal.Length ~ poly(Sepal.Width, 3) + poly(Petal.Length, 2), iris) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) expect_equivalent( res$term, c( "(Intercept)", "poly(Sepal.Width, 3)1", "poly(Sepal.Width, 3)2", "poly(Sepal.Width, 3)3", "poly(Petal.Length, 2)1", "poly(Petal.Length, 2)2" ) ) expect_equivalent( res$n_obs, c(150, 150, 150, 150, 150, 150) ) }) test_that("model_get_n() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) mod <- lme4::lmer(marker ~ stage + grade + (1 | group), df) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) }) test_that("model_get_n() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) df$response <- factor(df$response) suppressMessages( mod <- lme4::glmer(response ~ stage + grade + (1 | group), df, family = binomial) ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) }) test_that("model_get_n() works with survival::coxph", { skip_on_cran() df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event", "exposure")) test <- list( start = c(1, 2, 5, 2, 1, 7, 3, 4, 8, 8), stop = c(2, 3, 6, 7, 8, 9, 9, 9, 14, 17), event = c(1, 1, 1, 1, 1, 1, 1, 0, 0, 0), x = c(1, 0, 0, 1, 0, 1, 1, 1, 0, 0) ) mod <- survival::coxph(survival::Surv(start, stop, event) ~ x, test) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event", "exposure")) expect_equivalent(res$n_obs, c(10, 10)) expect_equivalent(res$n_event, c(7, 7)) expect_equivalent(res$exposure, c(43, 43)) }) test_that("model_get_n() works with survival::survreg", { skip_on_cran() mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event", "exposure")) }) test_that("model_get_n() works with nnet::multinom", { skip_if_not_installed("nnet") skip_on_cran() mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("y.level", "term", "n_obs", "n_event")) expect_equivalent( res$y.level, c( "II", "II", "II", "II", "II", "II", "II", "III", "III", "III", "III", "III", "III", "III" ) ) expect_equivalent( res$n_obs, c(179, 52, 37, 43, 179, 179, 47, 179, 52, 37, 43, 179, 179, 47) ) expect_equivalent( res$n_event, c(57, 16, 8, 12, 57, 57, 21, 58, 18, 12, 16, 58, 58, 12) ) # when y is not coded as a factor mod <- nnet::multinom(race ~ age + lwt + bwt, data = MASS::birthwt, trace = FALSE) expect_true(mod %>% model_get_n() %>% nrow() > 0) }) test_that("model_get_n() works with survey::svyglm", { skip_on_cran() skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) mod <- survey::svyglm(response ~ age + grade + offset(log(ttdeath)), df, family = quasipoisson) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event", "exposure")) df <- survey::svydesign( ~1, weights = ~Freq, data = as.data.frame(Titanic) %>% dplyr::filter(Freq > 0) ) mod <- survey::svyglm(Survived ~ Class + Age * Sex, df, family = quasibinomial) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) expect_equivalent( res$n_obs, c(2201, 285, 706, 885, 2092, 470, 425, 325, 109, 1731) ) }) test_that("model_get_n() works with ordinal::clm", { skip_on_cran() mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) # note: no nevent computed for ordinal models }) test_that("model_get_n() works with ordinal::clmm", { skip_on_cran() mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) }) test_that("model_get_n() works with MASS::polr", { skip_on_cran() mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) }) test_that("model_get_n() works with geepack::geeglm", { skip_on_cran() skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs")) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson(), corstr = "ar1") ) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event", "exposure")) }) test_that("model_get_n() works with gam::gam", { skip_on_cran() skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(res <- mod %>% model_get_n(), NA) expect_equivalent(names(res), c("term", "n_obs", "n_event")) }) test_that("model_get_n() works with lavaan::lavaan", { skip_on_cran() skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(res <- mod %>% model_get_n(), NA) expect_null(res) expect_null(mod %>% model_get_response()) expect_null(mod %>% model_get_weights()) expect_null(mod %>% model_get_offset()) expect_null(mod %>% model_compute_terms_contributions()) }) test_that("model_get_n() works with tidycmprsk::crr", { skip_on_cran() skip_if_not_installed("tidycmprsk") mod <- tidycmprsk::crr(Surv(ttdeath, death_cr) ~ age + grade, tidycmprsk::trial) res <- mod %>% tidy_plus_plus() expect_equivalent( res$n_event, c(52, 16, 15, 21) ) }) test_that("tidy_add_n() does not duplicates rows with gam model", { skip_on_cran() skip_if_not_installed("mgcv") skip_if_not_installed("gtsummary") mod <- mgcv::gam( marker ~ s(age, bs = "ad", k = -1) + grade + ti(age, by = grade, bs = "fs"), data = gtsummary::trial, method = "REML", family = gaussian ) res <- mod %>% tidy_and_attach(tidy_fun = gtsummary::tidy_gam) %>% tidy_add_n() expect_equal(nrow(res), 7L) }) broom.helpers/tests/testthat/test-select_variables.R0000644000176200001440000000524114457457202022456 0ustar liggesuserstest_that("tidy_select_variables() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() # no change by default res2 <- res %>% tidy_select_variables() expect_equivalent(res, res2) # include res2 <- res %>% tidy_select_variables(include = "stage") expect_equivalent( res2$variable, c("(Intercept)", "stage", "stage", "stage") ) res2 <- res %>% tidy_select_variables(include = c("grade", "trt")) expect_equivalent( res2$variable, c("(Intercept)", "grade", "grade", "trt") ) res2 <- res %>% tidy_select_variables(include = c("trt", "grade")) expect_equivalent( res2$variable, c("(Intercept)", "trt", "grade", "grade") ) res2 <- res %>% tidy_select_variables(include = c(trt, grade, dplyr::everything())) expect_equivalent( res2$variable, c("(Intercept)", "trt", "grade", "grade", "stage", "stage", "stage") ) # select and de-select expect_equivalent( res %>% tidy_select_variables(include = stage), res %>% tidy_select_variables(include = -c(grade, trt)) ) # tidyselect fns expect_equivalent( res %>% tidy_select_variables(include = contains("tage")), res %>% tidy_select_variables(include = stage) ) # testing vars() selector expect_equivalent( res %>% tidy_select_variables(include = vars(grade, trt)), res %>% tidy_select_variables(include = c(grade, trt)) ) # no error when none selected expect_error( res %>% tidy_select_variables(include = starts_with("zzzzzzz")), NA ) expect_error( res %>% tidy_select_variables(include = -everything()), NA ) expect_error( res %>% tidy_select_variables(include = where(is.character)), NA ) # interaction mod <- glm(response ~ stage + grade * trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() res2 <- res %>% tidy_select_variables(include = c(trt, grade, dplyr::everything())) expect_equivalent( res2$variable, c( "(Intercept)", "trt", "grade", "grade", "stage", "stage", "stage", "grade:trt", "grade:trt" ) ) }) test_that("test tidy_select_variables() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_select_variables()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_select_variables() %>% tidy_select_variables(), NA ) }) broom.helpers/tests/testthat/test-add_contrasts.R0000644000176200001440000002341214463417025021773 0ustar liggesuserstest_that("tidy_add_contrast() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment" ) ) expect_equivalent( res$contrasts_type, c( NA, "treatment", "treatment", "treatment", "treatment", "treatment", "treatment" ) ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.sum, grade = contr.helmert, trt = contr.SAS) ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.sum", "contr.sum", "contr.sum", "contr.helmert", "contr.helmert", "contr.SAS" ) ) expect_equivalent( res$contrasts_type, c(NA, "sum", "sum", "sum", "helmert", "helmert", "treatment") ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.treatment, trt = matrix(c(-3, 2))) ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.poly", "contr.poly", "contr.poly", "contr.treatment", "contr.treatment", "custom" ) ) expect_equivalent( res$contrasts_type, c(NA, "poly", "poly", "poly", "treatment", "treatment", "other") ) mod <- glm( response ~ stage + grade + trt + factor(death), gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, 3), grade = contr.treatment(3, 2), trt = contr.treatment(2, 2), "factor(death)" = matrix(c(-3, 2)) ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.treatment(base=3)", "contr.treatment(base=3)", "contr.treatment(base=3)", "contr.treatment(base=2)", "contr.treatment(base=2)", "contr.SAS", "custom" ) ) expect_equivalent( res$contrasts_type, c( NA, "treatment", "treatment", "treatment", "treatment", "treatment", "treatment", "other" ) ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list(stage = "contr.sum", grade = "contr.helmert", trt = "contr.SAS") ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.sum", "contr.sum", "contr.sum", "contr.helmert", "contr.helmert", "contr.SAS" ) ) expect_equivalent( res$contrasts_type, c(NA, "sum", "sum", "sum", "helmert", "helmert", "treatment") ) skip_if_not_installed("MASS") library(MASS) mod <- glm( response ~ stage + grade + trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sdif, grade = contr.sdif(3), trt = "contr.sdif" ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c(NA, "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif") ) expect_equivalent( res$contrasts_type, c(NA, "sdif", "sdif", "sdif", "sdif", "sdif", "sdif") ) }) test_that("test tidy_add_contrasts() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_contrasts()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_add_contrasts() %>% tidy_add_contrasts(), NA ) }) test_that("tidy_add_contrasts() works with no intercept models", { mod <- glm(response ~ stage + grade - 1, data = gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts_type, c( "no.contrast", "no.contrast", "no.contrast", "no.contrast", "treatment", "treatment" ) ) }) test_that("tidy_add_contrasts() works with variables having non standard name", { df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- glm(response ~ stage + `grade of kids` + trt, df, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment" ) ) mod <- glm(response ~ stage + `grade of kids` + trt, df, family = binomial, contrasts = list(`grade of kids` = contr.helmert) ) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.treatment", "contr.treatment", "contr.treatment", "contr.helmert", "contr.helmert", "contr.treatment" ) ) }) test_that("tidy_add_contrasts() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) mod <- lme4::lmer(marker ~ stage + grade + (1 | group), df) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") df <- gtsummary::trial df$stage <- as.character(df$stage) df$group <- rep.int(1:2, 100) suppressMessages( mod <- lme4::glmer(response ~ stage + grade + (1 | group), df, family = binomial) ) expect_error(mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with survival::coxph", { df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with survival::survreg", { mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with nnet::multinom", { skip_if_not_installed("nnet") mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) res <- mod %>% tidy_and_attach() %>% tidy_add_contrasts() expect_equivalent( res$contrasts, c( NA, "contr.sum", "contr.sum", "contr.sum", NA, NA, NA, "contr.sum", "contr.sum", "contr.sum", NA, NA ) ) }) test_that("tidy_add_contrasts() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("tidy_add_contrasts() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) expect_error(mod %>% tidy_and_attach() %>% tidy_add_contrasts(), NA) }) test_that("model_get_contrasts() works with rstanarm::stan_glm", { skip_on_cran() skip_if_not_installed("broom.mixed") skip_if_not_installed("rstanarm") mod <- rstanarm::stan_glm( response ~ age + grade, data = gtsummary::trial, refresh = 0, family = binomial ) expect_false( is.null(mod %>% model_get_contrasts()) ) }) broom.helpers/tests/testthat/test-remove_intercept.R0000644000176200001440000000132714357760764022533 0ustar liggesuserstest_that("tidy_remove_intercept() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_remove_intercept() expect_equal( res %>% dplyr::filter(var_type == "intercept") %>% nrow(), 0L ) }) test_that("test tidy_remove_intercept() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_remove_intercept()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_remove_intercept() %>% tidy_remove_intercept(), NA ) }) broom.helpers/tests/testthat/test-add_reference_rows.R0000644000176200001440000001630714457457157023005 0ustar liggesuserstest_that("tidy_add_reference_rows() works as expected", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.treatment, grade = contr.SAS, trt = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() if ("stage2" %in% names(coef(mod))) { expect_equivalent( res$term, c( "(Intercept)", "stage1", "stage2", "stage3", "stage4", "grade1", "grade2", "grade3", "trt1", "trt2", "grade1:trt1", "grade2:trt1" ) ) } else { expect_equivalent( res$term, c( "(Intercept)", "stageT1", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "gradeIII", "trt1", "trt2", "gradeI:trt1", "gradeII:trt1" ) ) } expect_equivalent( res$reference_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE, NA, NA ) ) expect_equivalent( res$var_class, c( NA, "factor", "factor", "factor", "factor", "factor", "factor", "factor", "character", "character", NA, NA ) ) expect_equivalent( res$var_type, c( "intercept", "categorical", "categorical", "categorical", "categorical", "categorical", "categorical", "categorical", "dichotomous", "dichotomous", "interaction", "interaction" ) ) expect_equivalent( res$var_nlevels, c(NA, 4L, 4L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, NA, NA) ) # no reference row added if other contrasts are used mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.helmert, trt = matrix(c(2, 3))) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() expect_true(all(is.na(res$reference_row))) # no reference row for an interaction only variable mod <- lm(age ~ factor(response):marker, gtsummary::trial) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() expect_equivalent( res$reference_row, c(NA, NA, NA) ) # no reference row if defined in no_reference_row mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.treatment, grade = contr.SAS, trt = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = c("stage", "grade")) if ("stage2" %in% names(coef(mod))) { expect_equivalent( res$term, c( "(Intercept)", "stage2", "stage3", "stage4", "grade1", "grade2", "trt1", "trt2", "grade1:trt1", "grade2:trt1" ) ) } else { expect_equivalent( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "trt1", "trt2", "gradeI:trt1", "gradeII:trt1" ) ) } expect_equivalent( res$reference_row, c(NA, NA, NA, NA, NA, NA, FALSE, TRUE, NA, NA) ) }) test_that("test tidy_add_reference_rows() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_add_reference_rows()) # warning if applied twice expect_message( mod %>% tidy_and_attach() %>% tidy_add_reference_rows() %>% tidy_add_reference_rows() ) # message if applied after tidy_add_term_labels() expect_message( mod %>% tidy_and_attach() %>% tidy_add_term_labels() %>% tidy_add_reference_rows() ) # message if applied after tidy_add_n() expect_message( mod %>% tidy_and_attach() %>% tidy_add_n() %>% tidy_add_reference_rows() ) # error if applied after tidy_add_header_rows() expect_error( mod %>% tidy_and_attach() %>% tidy_add_header_rows() %>% tidy_add_reference_rows() ) # message or error if non existing variable in no_reference_row expect_error( mod %>% tidy_and_attach() %>% tidy_add_reference_rows(no_reference_row = "g") ) }) test_that("tidy_add_reference_rows() works with different values of base in contr.treatment()", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() if ("stage2" %in% names(coef(mod))) { expect_equivalent( res$term, c( "(Intercept)", "stage1", "stage2", "stage3", "stage4", "grade1", "grade2", "grade3", "trt1", "trt2", "grade1:trt1", "grade3:trt1" ) ) } else { expect_equivalent( res$term, c( "(Intercept)", "stageT1", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "gradeIII", "trt1", "trt2", "gradeI:trt1", "gradeIII:trt1" ) ) } expect_equivalent( res$reference_row, c( NA, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, NA, NA ) ) }) test_that("tidy_add_reference_rows() use var_label if available", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial ) res <- mod %>% tidy_and_attach() %>% tidy_add_variable_labels() %>% tidy_add_reference_rows() expect_equivalent( res$var_label, c( "(Intercept)", "T Stage", "T Stage", "T Stage", "T Stage", "Grade", "Grade", "Grade", "Chemotherapy Treatment", "Chemotherapy Treatment", "Grade * Chemotherapy Treatment", "Grade * Chemotherapy Treatment" ) ) }) test_that("tidy_add_reference_rows() works with nnet::multinom", { skip_if_not_installed("nnet") skip_on_cran() mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() expect_equivalent( res$reference_row, c( NA, TRUE, FALSE, FALSE, FALSE, NA, NA, NA, TRUE, FALSE, FALSE, FALSE, NA, NA ) ) }) test_that("tidy_add_reference_rows() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") skip_if_not_installed("broom.mixed") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() expect_equal( res[res$reference_row & !is.na(res$reference_row), ]$effect, "fixed" ) }) test_that("tidy_add_reference_rows() works with glmmTMB::glmmTMB", { skip_on_cran() skip_if_not_installed("glmmTMB") skip_if_not_installed("broom.mixed") mod <- glmmTMB::glmmTMB(count ~ mined + spp, ziformula = ~mined, family = poisson, data = glmmTMB::Salamanders ) res <- mod %>% tidy_and_attach() %>% tidy_add_reference_rows() expect_equivalent( res$reference_row, c( NA, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, NA, TRUE, FALSE ) ) }) broom.helpers/tests/testthat/test-assert_package.R0000644000176200001440000000234314457457164022132 0ustar liggesuserstest_that(".assert_package() works", { # broom will always be installed with broom.helpers expect_error( .assert_package("broom"), NA ) expect_true(.assert_package("broom", boolean = TRUE)) expect_false(.assert_package("br000000m", boolean = TRUE)) mv <- c(Suggests = "1.1.28") attr(mv, "compare") <- ">=" expect_equal( .get_min_version_required("lme4"), mv ) expect_null( .get_min_version_required("brms", pkg_search = NULL) ) expect_null( .get_min_version_required("broom", pkg_search = NULL) ) expect_error( df_deps <- .get_package_dependencies(), NA ) expect_true( df_deps %>% inherits("data.frame") ) expect_equal( names(df_deps), c("pkg_search", "pkg_search_version", "dependency_type", "pkg", "version", "compare") ) expect_error( deps <- .get_all_packages_dependencies(), NA ) expect_true(nrow(deps) > 100) skip_if(interactive()) # expect an error msg for pkg that doesn't exist # note: if interactive(), user will be invited to install the missing pkg expect_error( .assert_package("br000000m") ) expect_error( .assert_package("br000000m", fn = "test_fun()") ) }) broom.helpers/tests/testthat/test-identify_variables.R0000644000176200001440000004462014457457421023021 0ustar liggesuserslibrary(survival) library(gtsummary) test_that("model_list_variables() tests", { mod <- glm(response ~ age + grade * trt + death, gtsummary::trial, family = binomial) res <- mod %>% model_list_variables() expect_equivalent( res$variable, c("response", "age", "grade", "trt", "death", "grade:trt") ) expect_equivalent( res$variable, mod %>% model_list_variables(only_variable = TRUE) ) expect_equivalent( res$var_class, c( response = "integer", age = "numeric", grade = "factor", trt = "character", death = "integer", NA ) ) mod <- lm(marker ~ as.logical(response), gtsummary::trial) res <- mod %>% model_list_variables( labels = list(marker = "MARKER", "as.logical(response)" = "RESPONSE") ) expect_equivalent( res$var_class, c("numeric", "logical") ) expect_equivalent( res$var_label, c("MARKER", "RESPONSE") ) expect_equal( .MFclass2(as.Date("2000-01-01")), "other" ) }) test_that("tidy_identify_variables() works for common models", { mod <- glm(response ~ age + grade * trt + death, gtsummary::trial, family = binomial) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("(Intercept)", "age", "grade", "grade", "trt", "death", "grade:trt", "grade:trt") ) expect_equivalent( res$var_class, c(NA, "numeric", "factor", "factor", "character", "integer", NA, NA) ) expect_equivalent( res$var_type, c( "intercept", "continuous", "categorical", "categorical", "dichotomous", "continuous", "interaction", "interaction" ) ) expect_equivalent( res$var_nlevels, c(NA, NA, 3L, 3L, 2L, NA, NA, NA) ) }) test_that("test tidy_identify_variables() checks", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) # expect an error if no model attached expect_error(mod %>% broom::tidy() %>% tidy_identify_variables()) # could be apply twice (no error) expect_error( mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_identify_variables(), NA ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_identify_variables() expect_true( all(c("variable", "var_type", "var_class", "var_nlevels") %in% names(res)) ) # cannot be applied after tidy_add_header_rows expect_error( mod %>% tidy_and_attach() %>% tidy_add_header_rows() %>% tidy_identify_variables() ) }) test_that("model_dientify_variables() works well with logical variables", { mod <- lm( age ~ response + marker, data = gtsummary::trial %>% dplyr::mutate(response = as.logical(response)) ) res <- model_identify_variables(mod) expect_equivalent( res %>% dplyr::filter(variable == "response") %>% purrr::pluck("var_type"), "dichotomous" ) expect_equivalent( res %>% dplyr::filter(variable == "response") %>% purrr::pluck("var_nlevels"), 2 ) expect_equivalent( model_get_xlevels(mod)$response, c("FALSE", "TRUE") ) }) test_that("model_identify_variables() works with different contrasts", { mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.treatment, grade = contr.SAS, trt = contr.SAS) ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c( NA, "stage", "stage", "stage", "grade", "grade", "trt", "grade:trt", "grade:trt" ) ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.helmert, trt = contr.sum) ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "stage", "stage", "stage", "grade", "grade", "trt", "grade:trt", "grade:trt") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with stats::poly()", { mod <- lm(Sepal.Length ~ poly(Sepal.Width, 3) + poly(Petal.Length, 2), iris) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c( NA, "Sepal.Width", "Sepal.Width", "Sepal.Width", "Petal.Length", "Petal.Length" ) ) expect_error(tb <- mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) expect_equivalent( tb$variable, c( "(Intercept)", "Sepal.Width", "Sepal.Width", "Sepal.Width", "Petal.Length", "Petal.Length" ) ) }) test_that("tidy_identify_variables() works with variables having non standard name", { # cf. https://github.com/ddsjoberg/gtsummary/issues/609 df <- gtsummary::trial %>% dplyr::mutate(`grade of kids` = grade) mod <- lm(age ~ marker * `grade of kids`, df) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c( "(Intercept)", "marker", "grade of kids", "grade of kids", "marker:grade of kids", "marker:grade of kids" ) ) expect_equivalent( res$var_class, c(NA, "numeric", "factor", "factor", NA, NA) ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) # interaction only term mod <- lm(age ~ marker:`grade of kids`, df) expect_equivalent( mod %>% model_list_variables(only_variable = TRUE), c("age", "marker", "grade of kids", "marker:grade of kids") ) expect_equivalent( mod %>% model_identify_variables() %>% purrr::pluck("variable"), c(NA, "marker:grade of kids", "marker:grade of kids", "marker:grade of kids") ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("(Intercept)", "marker:grade of kids", "marker:grade of kids", "marker:grade of kids") ) trial2 <- gtsummary::trial %>% dplyr::mutate( `treatment +name` = trt, `disease stage` = stage ) mod <- glm( response ~ `treatment +name` + `disease stage`, trial2, family = binomial(link = "logit") ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() %>% tidy_remove_intercept() expect_equivalent( res$variable, c( "treatment +name", "disease stage", "disease stage", "disease stage" ) ) expect_equivalent( res$var_type, c("dichotomous", "categorical", "categorical", "categorical") ) mod <- lm( hp ~ factor(`number + cylinders`):`miles :: galon` + factor(`type of transmission`), mtcars %>% dplyr::rename( `miles :: galon` = mpg, `type of transmission` = am, `number + cylinders` = cyl ) ) res <- tidy_plus_plus(mod) expect_equivalent( res$variable, c( "factor(`type of transmission`)", "factor(`type of transmission`)", "factor(`number + cylinders`):miles :: galon", "factor(`number + cylinders`):miles :: galon", "factor(`number + cylinders`):miles :: galon" ) ) }) test_that("model_identify_variables() works with lme4::lmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "Days") ) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_identify_variables(), NA ) mod <- lme4::lmer( age ~ stage + (stage | grade) + (1 | grade), gtsummary::trial ) res <- mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_identify_variables() expect_equal( res %>% dplyr::filter(effect == "ran_pars") %>% purrr::pluck("var_type") %>% unique(), "ran_pars" ) }) test_that("model_identify_variables() works with lme4::glmer", { skip_on_cran() skip_if_not_installed("lme4") mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial, data = lme4::cbpp ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "period", "period", "period") ) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_identify_variables(), NA ) }) test_that("model_identify_variables() works with survival::coxph", { df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c("ph.ecog", "age", "sex") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with survival::survreg", { mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "ecog.ps", "rx") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with nnet::multinom", { skip_if_not_installed("nnet") mod <- nnet::multinom(grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "stage", "stage", "stage", "marker", "age") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c( "(Intercept)", "stage", "stage", "stage", "marker", "age", "(Intercept)", "stage", "stage", "stage", "marker", "age" ) ) # should work also with sum/SAS contrasts mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c( "(Intercept)", "stage", "stage", "stage", "marker", "age", "(Intercept)", "stage", "stage", "stage", "marker", "age" ) ) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.SAS) ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c( "(Intercept)", "stage", "stage", "stage", "marker", "age", "(Intercept)", "stage", "stage", "stage", "marker", "age" ) ) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.helmert) ) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c( "(Intercept)", "stage", "stage", "stage", "marker", "age", "(Intercept)", "stage", "stage", "stage", "marker", "age" ) ) }) test_that("model_identify_variables() works with survey::svyglm", { skip_if_not_installed("survey") df <- survey::svydesign(~1, weights = ~1, data = gtsummary::trial) mod <- survey::svyglm(response ~ age + grade * trt, df, family = quasibinomial) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "age", "grade", "grade", "trt", "grade:trt", "grade:trt") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("1|2", "2|3", "3|4", "4|5", "temp", "contact", "temp:contact") ) mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine, threshold = "symmetric") res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("central.1", "central.2", "spacing.1", "temp", "contact", "temp:contact") ) mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine, threshold = "symmetric2") res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("spacing.1", "spacing.2", "temp", "contact", "temp:contact") ) mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine, threshold = "equidistant") res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("threshold.1", "spacing", "temp", "contact", "temp:contact") ) # nolint start # wait for https://github.com/runehaubo/ordinal/issues/37 # before testing nominal predictors # mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine, nominal = ~contact) # res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() # expect_equivalent( # res$variable, # c("1|2.(Intercept)", "2|3.(Intercept)", "3|4.(Intercept)", "4|5.(Intercept)", # "contact", "contact", "contact", "contact", "temp", "contactyes", # "temp:contact") # ) # nolint end }) test_that("model_identify_variables() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) res <- mod %>% tidy_and_attach() %>% tidy_identify_variables() expect_equivalent( res$variable, c("1|2", "2|3", "3|4", "4|5", "temp", "contact", "temp:contact") ) }) test_that("model_identify_variables() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "Infl", "Infl", "Type", "Type", "Type", "Cont") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with geepack::geeglm", { skip_if(packageVersion("geepack") < "1.3") df <- geepack::dietox df$Cu <- as.factor(df$Cu) mf <- formula(Weight ~ Cu * Time) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson("identity"), corstr = "ar1") ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "Cu", "Cu", "Time", "Cu:Time", "Cu:Time") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with gam::gam", { skip_if_not_installed("gam") data(kyphosis, package = "gam") mod <- gam::gam(Kyphosis ~ gam::s(Age, 4) + Number, family = binomial, data = kyphosis) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "gam::s(Age, 4)", "Number") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c(NA, "gam::lo(Solar.R)", "gam::lo(Wind, Temp)", "gam::lo(Wind, Temp)") ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) }) test_that("model_identify_variables() works with lavaan::lavaan", { skip_if_not_installed("lavaan") df <- lavaan::HolzingerSwineford1939 df$grade <- factor(df$grade, ordered = TRUE) HS.model <- "visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 + grade speed =~ x7 + x8 + x9 " mod <- lavaan::lavaan(HS.model, data = df, auto.var = TRUE, auto.fix.first = TRUE, auto.cov.lv.x = TRUE ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, mod@ParTable$lhs ) expect_error(mod %>% tidy_and_attach() %>% tidy_identify_variables(), NA) expect_vector( mod %>% model_list_variables(only_variable = TRUE) ) }) test_that("model_identify_variables() message when failure", { skip_if_not_installed("survival") df_models <- tibble::tibble(grade = c("I", "II", "III")) %>% dplyr::mutate( df_model = purrr::map(grade, ~ trial %>% dplyr::filter(grade == ..1)), mv_formula_char = "Surv(ttdeath, death) ~ trt + age + marker", mv_formula = purrr::map(mv_formula_char, as.formula), mv_model_form = purrr::map2( mv_formula, df_model, ~ survival::coxph(..1, data = ..2) ) ) expect_message( df_models %>% dplyr::mutate( mv_tbl_form = purrr::map( mv_model_form, ~ tidy_and_attach(.x) %>% tidy_identify_variables(quiet = FALSE) ) ) ) }) test_that("model_identify_variables() works with glmmTMB::glmmTMB", { skip_if_not_installed("glmmTMB") skip_if_not_installed("broom.mixed") skip_on_cran() mod <- suppressWarnings( glmmTMB::glmmTMB(count ~ mined + spp, ziformula = ~ mined + site, family = poisson, data = glmmTMB::Salamanders ) ) res <- mod %>% model_identify_variables() expect_equivalent( res$variable, c( NA, "mined", "spp", "spp", "spp", "spp", "spp", "spp", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site", "site" ) ) expect_error( mod %>% tidy_and_attach(tidy_fun = broom.mixed::tidy) %>% tidy_identify_variables(), NA ) }) test_that("model_identify_variables() works with plm::plm", { skip_if_not_installed("plm") skip_on_cran() data("Grunfeld", package = "plm") mod <- plm::plm( inv ~ value + capital, data = Grunfeld, model = "within", index = c("firm", "year") ) res <- mod %>% model_identify_variables() expect_equivalent( mod %>% model_get_model_matrix() %>% colnames(), c("(Intercept)", "value", "capital") ) expect_equivalent( res$term, c("(Intercept)", "value", "capital") ) expect_equivalent( res$variable, c(NA, "value", "capital") ) }) broom.helpers/tests/testthat.R0000644000176200001440000000011214357760764016173 0ustar liggesuserslibrary(testthat) library(broom.helpers) test_check("broom.helpers") broom.helpers/vignettes/0000755000176200001440000000000014464203466015052 5ustar liggesusersbroom.helpers/vignettes/tidy.Rmd0000644000176200001440000003777314464175037016512 0ustar liggesusers--- title: "Getting Started with broom.helpers" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Getting Started with broom.helpers} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>", rows.print = 25 ) # one of the functions below needs emmeans, so dont evaluate code check in vignette # on old R versions where emmeans is not available if (!rlang::is_installed("emmeans")) { knitr::opts_chunk$set(eval = FALSE) } ``` The `broom.helpers` package offers a suite of functions that make easy to interact, add information, and manipulate tibbles created with `broom::tidy()` (and friends). The suite includes functions to group regression model terms by variable, insert reference and header rows for categorical variables, add variable labels, and more. As a motivating example, let's summarize a logistic regression model with a forest plot and in a table. To begin, let's load our packages. ```{r setup, warning=FALSE, message=FALSE} library(broom.helpers) library(gtsummary) library(ggplot2) library(dplyr) # paged_table() was introduced only in rmarkdwon v1.2 print_table <- function(tab) { if (packageVersion("rmarkdown") >= "1.2") { rmarkdown::paged_table(tab) } else { knitr::kable(tab) } } ``` Our model predicts tumor response using chemotherapy treatment and tumor grade. The data set we're utilizing has already labelled the columns using the [labelled package](https://larmarange.github.io/labelled/). The column labels will be carried through to our figure and table. ```{r} model_logit <- glm(response ~ trt + grade, trial, family = binomial) broom::tidy(model_logit) ``` ## Forest Plot To create the figure, we'll need to add some information to the tidy tibble, i.e. we'll need to group the terms that belong to the same variable, add the reference row, etc. Parsing this information can be difficult, but the `broom.helper` package has made it simple. ```{r} tidy_forest <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding a reference value to appear in plot tidy_add_estimate_to_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # removing intercept estimate from model tidy_remove_intercept() tidy_forest ``` **Note:** we used `tidy_and_attach()` instead of `broom::tidy()`. `broom.helpers` functions needs a copy of the original model. To avoid passing the model at each step, the easier way is to attach the model as an attribute of the tibble with `tidy_attach_model()`. `tidy_and_attach()` is simply a shortcut of `model %>% broom::tidy() %>% tidy_and_attach(model)`. We now have a tibble with every piece of information we need to create our forest plot using `ggplot2`. ```{r, warning=FALSE} tidy_forest %>% mutate( plot_label = paste(var_label, label, sep = ":") %>% forcats::fct_inorder() %>% forcats::fct_rev() ) %>% ggplot(aes(x = plot_label, y = estimate, ymin = conf.low, ymax = conf.high, color = variable)) + geom_hline(yintercept = 1, linetype = 2) + geom_pointrange() + coord_flip() + theme(legend.position = "none") + labs( y = "Odds Ratio", x = " ", title = "Forest Plot using broom.helpers" ) ``` **Note::** for more advanced and nicely formatted plots of model coefficients, look at `ggstats::ggcoef_model()` and its [dedicated vignette](https://larmarange.github.io/ggstats/articles/ggcoef_model.html). `ggstats::ggcoef_model()` internally uses `broom.helpers`. ## Table Summary In addition to aiding in figure creation, the broom.helpers package can help summarize a model in a table. In the example below, we add header and reference rows, and utilize existing variable labels. Let's change the labels shown in our summary table as well. ```{r} tidy_table <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # add header row tidy_add_header_rows() %>% # removing intercept estimate from model tidy_remove_intercept() # print summary table options(knitr.kable.NA = "") tidy_table %>% # format model estimates select(label, estimate, conf.low, conf.high, p.value) %>% mutate(across(all_of(c("estimate", "conf.low", "conf.high")), style_ratio)) %>% mutate(across(p.value, style_pvalue)) %>% print_table() ``` **Note::** for more advanced and nicely formatted tables of model coefficients, look at `gtsummary::tbl_regression()` and its [dedicated vignette](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html). `gtsummary::tbl_regression()` internally uses `broom.helpers`. ## All-in-one function There is also a handy wrapper, called `tidy_plus_plus()`, for the most commonly used `tidy_*()` functions, and they can be executed with a single line of code: ```{r} model_logit %>% tidy_plus_plus(exponentiate = TRUE) ``` ```{r} model_logit %>% tidy_plus_plus(exponentiate = TRUE) %>% print_table() ``` See the documentation of `tidy_plus_plus()` for the full list of available options. ## Advanced examples `broom.helpers` can also handle different contrasts for categorical variables and the use of polynomial terms for continuous variables. ### Polynomial terms When polynomial terms of a continuous variable are defined with `stats::poly()`, `broom.helpers` will be able to identify the corresponding variable, create appropriate labels and add header rows. ```{r} model_poly <- glm(response ~ poly(age, 3) + ttdeath, na.omit(trial), family = binomial) model_poly %>% tidy_plus_plus( exponentiate = TRUE, add_header_rows = TRUE, variable_labels = c(age = "Age in years") ) %>% print_table() ``` ### Different type of contrasts By default, categorical variables are coded with a treatment contrasts (see `stats::contr.treatment()`). With such contrasts, model coefficients correspond to the effect of a modality compared with the reference modality (by default, the first one). `tidy_add_reference_rows()` allows to add a row for this reference modality and `tidy_add_estimate_to_reference_rows()` will populate the estimate value of these references rows by 0 (or 1 if `exponentiate = TRUE`). `tidy_add_term_labels()` is able to retrieve the label of the factor level associated with a specific model term. ```{r} model_1 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial ) model_1 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` Using `stats::contr.treatment()`, it is possible to defined alternative reference rows. It will be properly managed by `broom.helpers`. ```{r} model_2 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) model_2 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` You can also use sum contrasts (cf. `stats::contr.sum()`). In that case, each model coefficient corresponds to the difference of that modality with the grand mean. A variable with 4 modalities will be coded with 3 terms. However, a value could be computed (using `emmeans::emmeans()`) for the last modality, corresponding to the difference of that modality with the grand mean and equal to sum of all other coefficients multiplied by -1. `broom.helpers` will identify categorical variables coded with sum contrasts and could retrieve an estimate value for the reference term. ```{r} model_3 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sum, grade = contr.sum, trt = contr.sum ) ) model_3 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` Other types of contrasts exist, like Helmert (`contr.helmert()`) or polynomial (`contr.poly()`). They are more complex as a modality will be coded with a combination of terms. Therefore, for such contrasts, it will not be possible to associate a specific model term with a level of the original factor. `broom.helpers` will not add a reference term in such case. ```{r} model_4 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.poly, grade = contr.helmert, trt = contr.poly ) ) model_4 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` ### Pairwise contrasts of categorical variable Pairwise contrasts of categorical variables could be computed with `tidy_add_pairwise_contrasts()`. ```{r} model_logit <- glm(response ~ age + trt + grade, trial, family = binomial) model_logit %>% tidy_and_attach() %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(keep_model_terms = TRUE) %>% print_table() ``` ## Column Details Below is a summary of the additional columns that may be added by a `broom.helpers` function. The table includes the column name, the function that adds the column, and a short description of the information in the column. ```{r, echo=FALSE} # nolint start tibble::tribble( ~Column, ~Function, ~Description, "original_term", "`tidy_disambiguate_terms()`, `tidy_multgee()` or `tidy_zeroinfl()`", "Original term before disambiguation. This columns is added only when disambiguation is needed (i.e. for mixed models). Also used for \"multgee\", \"zeroinfl\" and \"hurdle\" models.", "variable", "`tidy_identify_variables()`", "String of variable names from the model. For categorical variables and polynomial terms defined with `stats::poly()`, terms belonging to the variable are identified.", "var_class", "`tidy_identify_variables()`", "Class of the variable.", "var_type", "`tidy_identify_variables()`", "One of \"intercept\", \"continuous\", \"dichotomous\", \"categorical\", \"interaction\", \"ran_pars\" or \"ran_vals\"", "var_nlevels", "`tidy_identify_variables()`", "Number of original levels for categorical variables", "contrasts", "`tidy_add_contrasts()`", "Contrasts used for categorical variables.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "contrasts_type", "`tidy_add_contrasts()`", "Type of contrasts (\"treatment\", \"sum\", \"poly\", \"helmert\", \"sdif\", \"other\" or \"no.contrast\"). \"pairwise\ is used for pairwise contrasts computed with `tidy_add_pairwise_contrasts()`.", "reference_row", "`tidy_add_reference_rows()`", "Logical indicating if a row is a reference row for categorical variables using a treatment or a sum contrast. Is equal to `NA` for variables who do not have a reference row.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
`tidy_add_reference_rows()` will not populate the label of the reference term. It is therefore better to apply `tidy_add_term_labels()` after `tidy_add_reference_rows()` rather than before.
", "var_label", "`tidy_add_variable_labels()`", "String of variable labels from the model. Columns labelled with the `labelled` package are retained. It is possible to pass a custom label for an interaction term with the `labels` argument.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "label", "`tidy_add_term_labels()`", "String of term labels based on (1) labels provided in `labels` argument if provided; (2) factor levels for categorical variables coded with treatment, SAS or sum contrasts; (3) variable labels when there is only one term per variable; and (4) term name otherwise.
Require \"variable_label\" column. If needed, will automatically apply `tidy_add_variable_labels()`.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
", "header_row", "`tidy_add_header_rows()`", "Logical indicating if a row is a header row for variables with several terms. Is equal to `NA` for variables who do not have an header row.
Require \"label\" column. If needed, will automatically apply `tidy_add_term_labels()`.
It is better to apply `tidy_add_header_rows()` after other `tidy_*` functions
", "n_obs", "`tidy_add_n()`", "Number of observations", "n_event", "`tidy_add_n()`", "Number of events (for binomial and multinomial logistic models, Poisson and Cox models)", "exposure", "`tidy_add_n()`", "Exposure time (for Poisson and Cox models)" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options( column_labels.font.weight = "bold" ) %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) # nolint end ``` Note: `tidy_add_estimate_to_reference_rows()` does not create an additional column; rather, it populates the 'estimate' column for reference rows. ## Additional attributes Below is a list of additional attributes that `broom.helpers` may attached to the results. The table includes the attribute name, the function that adds the attribute, and a short description. ```{r, echo=FALSE} tibble::tribble( ~Attribute, ~Function, ~Description, "exponentiate", "`tidy_and_attach()`", "Indicates if estimates were exponentiated", "conf.level", "`tidy_and_attach()`", "Level of confidence used for confidence intervals", "coefficients_type", "`tidy_add_coefficients_type()`", "Type of coefficients", "coefficients_label", "`tidy_add_coefficients_type()`", "Coefficients label", "variable_labels", "`tidy_add_variable_labels()`", "Custom variable labels passed to `tidy_add_variable_labels()`", "term_labels", "`tidy_add_term_labels()`", "Custom term labels passed to `tidy_add_term_labels()`", "N_obs", "`tidy_add_n()`", "Total number of observations", "N_event", "`tidy_add_n()`", "Total number of events", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) ``` ## Supported models ```{r, echo=FALSE} supported_models %>% dplyr::rename_with(stringr::str_to_title) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) ``` Note: this list of models has been tested. `broom.helpers` may or may not work properly or partially with other types of models. Do not hesitate to provide feedback on [GitHub](https://github.com/larmarange/broom.helpers/issues). broom.helpers/R/0000755000176200001440000000000014464175037013245 5ustar liggesusersbroom.helpers/R/tidy_add_contrasts.R0000644000176200001440000000370014457457130017250 0ustar liggesusers#' Add contrasts type for categorical variables #' #' Add a `contrasts` column corresponding to contrasts used for a #' categorical variable and a `contrasts_type` column equal to #' "treatment", "sum", "poly", "helmert", "other" or "no.contrast". #' #' @details #' If the `variable` column is not yet available in `x`, #' [tidy_identify_variables()] will be automatically applied. #' #' @param x a tidy tibble #' @param model the corresponding model, if not attached to `x` #' @param quiet logical argument whether broom.helpers should not return a message #' when `tidy_disambiguate_terms()` was already applied #' @export #' @family tidy_helpers #' @examples #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.helmert") #' ) %>% #' tidy_and_attach() %>% #' tidy_add_contrasts() tidy_add_contrasts <- function(x, model = tidy_get_model(x), quiet = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) if ("contrasts" %in% names(x)) { x <- x %>% dplyr::select(-dplyr::all_of("contrasts")) } if (!"variable" %in% names(x)) { if (!quiet) { x <- x %>% tidy_identify_variables() } } contrasts_list <- model_list_contrasts(model) if (is.null(contrasts_list)) { x$contrasts <- NA_character_ x$contrasts_type <- NA_character_ } else { x <- x %>% dplyr::left_join( contrasts_list %>% dplyr::select(dplyr::all_of(c("variable", "contrasts", "contrasts_type"))), by = "variable" ) } x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/tidy_disambiguate_terms.R0000644000176200001440000000415314464175037020274 0ustar liggesusers#' Disambiguate terms #' #' For mixed models, the `term` column returned by `broom.mixed` may have #' duplicated values for random-effect parameters and random-effect values. #' In such case, the terms could be disambiguated be prefixing them with the #' value of the `group` column. `tidy_disambiguate_terms()` will not change #' any term if there is no `group` column in `x`. The original term value #' is kept in a new column `original_term`. #' #' #' @param x a tidy tibble #' @param sep character, separator added between group name and term #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' if ( #' .assert_package("lme4", boolean = TRUE) && #' .assert_package("broom.mixed", boolean = TRUE) && #' .assert_package("gtsummary", boolean = TRUE) #' ) { #' mod <- lme4::lmer(marker ~ stage + (1 | grade) + (death | response), gtsummary::trial) #' mod %>% #' tidy_and_attach() %>% #' tidy_disambiguate_terms() #' } tidy_disambiguate_terms <- function(x, sep = ".", model = tidy_get_model(x), quiet = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if ("original_term" %in% names(x)) { if ( !quiet && !inherits(model, "LORgee") && # no alert for multgee models !inherits(model, "zeroinfl") && # or zeroninfl/hurdle !inherits(model, "hurdle") ) { cli_alert_danger(paste( "{.code tidy_disambiguate_terms()} has already been applied.", "x has been returned unchanged." )) } return(x) } .attributes <- .save_attributes(x) if ("group" %in% names(x)) { x <- x %>% dplyr::mutate( term = dplyr::if_else( is.na(.data$group), .data$term, paste(.data$group, .data$term, sep = sep) ), original_term = .data$term ) } x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_get_n.R0000644000176200001440000001420514457457112015645 0ustar liggesusers#' Get the number of observations #' #' For binomial and multinomial logistic models, will also return #' the number of events. #' #' For Poisson models, will return the number of events and exposure time #' (defined with [stats::offset()]). #' #' For Cox models ([survival::coxph()]), will return the number of events and #' exposure time. #' #' For competing risk regression models ([tidycmprsk::crr()]), `n_event` takes #' into account only the event of interest defined by `failcode.` #' #' See [tidy_add_n()] for more details. #' #' The total number of observations (`N_obs`), of events (`N_event`) and of #' exposure time (`Exposure`) are stored as attributes of the returned tibble. #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) %>% #' model_get_n() #' #' mod <- glm( #' response ~ stage * grade + trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list(stage = contr.sum, grade = contr.treatment(3, 2), trt = "contr.SAS") #' ) #' mod %>% model_get_n() #' #' \dontrun{ #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, family = binomial #' ) #' mod %>% model_get_n() #' #' d <- dplyr::as_tibble(Titanic) %>% #' dplyr::group_by(Class, Sex, Age) %>% #' dplyr::summarise( #' n_survived = sum(n * (Survived == "Yes")), #' n_dead = sum(n * (Survived == "No")) #' ) #' mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) #' mod %>% model_get_n() #' #' mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) #' mod %>% model_get_n() #' #' mod <- glm( #' response ~ trt * grade + offset(ttdeath), #' gtsummary::trial, #' family = poisson #' ) #' mod %>% model_get_n() #' #' dont #' df <- survival::lung %>% dplyr::mutate(sex = factor(sex)) #' mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) #' mod %>% model_get_n() #' #' mod <- lme4::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy) #' mod %>% model_get_n() #' #' mod <- lme4::glmer(response ~ trt * grade + (1 | stage), #' family = binomial, data = gtsummary::trial #' ) #' mod %>% model_get_n() #' #' mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), #' family = binomial, data = lme4::cbpp #' ) #' mod %>% model_get_n() #' } model_get_n <- function(model) { UseMethod("model_get_n") } #' @export #' @rdname model_get_n model_get_n.default <- function(model) { tcm <- model %>% model_compute_terms_contributions() if (is.null(tcm)) { return(NULL) } w <- model %>% model_get_weights() n <- dplyr::tibble( term = colnames(tcm), n_obs = colSums(tcm * w) ) attr(n, "N_obs") <- sum(w) n } #' @export #' @rdname model_get_n model_get_n.glm <- function(model) { tcm <- model %>% model_compute_terms_contributions() if (is.null(tcm)) { return(NULL) } # nocov w <- model %>% model_get_weights() n <- dplyr::tibble( term = colnames(tcm), n_obs = colSums(tcm * w) ) attr(n, "N_obs") <- sum(w) ct <- model %>% model_get_coefficients_type() if (ct %in% c("logistic", "poisson")) { y <- model %>% model_get_response() if (is.factor(y)) { # the first level denotes failure and all others success y <- as.integer(y != levels(y)[1]) } n$n_event <- colSums(tcm * y * w) attr(n, "N_event") <- sum(y * w) } if (ct == "poisson") { off <- model %>% model_get_offset() if (is.null(off)) off <- 0L n$exposure <- colSums(tcm * exp(off) * w) attr(n, "Exposure") <- sum(exp(off) * w) } n } #' @export #' @rdname model_get_n model_get_n.glmerMod <- model_get_n.glm #' @export #' @rdname model_get_n model_get_n.multinom <- function(model) { tcm <- model %>% model_compute_terms_contributions() if (is.null(tcm)) { return(NULL) } # nocov w <- model %>% model_get_weights() y <- model %>% model_get_response() if (!is.factor(y)) y <- factor(y) n <- purrr::map_df( levels(y)[-1], ~ dplyr::tibble( y.level = .x, term = colnames(tcm), n_obs = colSums(tcm * w), n_event = colSums((y == .x) * tcm * w) ) ) attr(n, "N_obs") <- sum(w) attr(n, "N_event") <- sum((y != levels(y)[1]) * w) n } #' @export #' @rdname model_get_n model_get_n.LORgee <- function(model) { if (stringr::str_detect(model$title, "NOMINAL")) { model_get_n.multinom(model) } else { model_get_n.default(model) } } #' @export #' @rdname model_get_n model_get_n.coxph <- function(model) { tcm <- model %>% model_compute_terms_contributions() if (is.null(tcm)) { return(NULL) } # nocov w <- model %>% model_get_weights() n <- dplyr::tibble( term = colnames(tcm), n_obs = colSums(tcm * w) ) attr(n, "N_obs") <- sum(w) y <- model %>% model_get_response() status <- y[, ncol(y)] if (ncol(y) == 3) { time <- y[, 2] - y[, 1] } else { time <- y[, 1] } n$n_event <- colSums(tcm * status * w) attr(n, "N_event") <- sum(status * w) n$exposure <- colSums(tcm * time * w) attr(n, "Exposure") <- sum(time * w) n } #' @export #' @rdname model_get_n model_get_n.survreg <- model_get_n.coxph #' @export #' @rdname model_get_n model_get_n.model_fit <- function(model) { model_get_n(model$fit) } #' @export #' @rdname model_get_n model_get_n.tidycrr <- function(model) { tcm <- model %>% model_compute_terms_contributions() if (is.null(tcm)) { return(NULL) } # nocov w <- model %>% model_get_weights() n <- dplyr::tibble( term = colnames(tcm), n_obs = colSums(tcm * w) ) attr(n, "N_obs") <- sum(w) y <- model %>% model_get_response() time <- y[, 1] status <- as.integer(y[, 2] == model$failcode) n$n_event <- colSums(tcm * status * w) attr(n, "N_event") <- sum(status * w) n$exposure <- colSums(tcm * time * w) attr(n, "Exposure") <- sum(time * w) n } broom.helpers/R/model_identify_variables.R0000644000176200001440000001446214457457120020420 0ustar liggesusers#' Identify for each coefficient of a model the corresponding variable #' #' It will also identify interaction terms and intercept(s). #' @param model a model object #' @return #' A tibble with four columns: #' * `term`: coefficients of the model #' * `variable`: the corresponding variable #' * `var_class`: class of the variable (cf. [stats::.MFclass()]) #' * `var_type`: `"continuous"`, `"dichotomous"` (categorical variable with 2 levels), #' `"categorical"` (categorical variable with 3 or more levels), `"intercept"` #' or `"interaction"` #' * `var_nlevels`: number of original levels for categorical variables #' @export #' @family model_helpers #' @seealso [tidy_identify_variables()] #' @examples #' Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' glm( #' Survived ~ Class + Age * Sex, #' data = ., weights = .$n, #' family = binomial #' ) %>% #' model_identify_variables() #' #' iris %>% #' lm( #' Sepal.Length ~ poly(Sepal.Width, 2) + Species, #' data = ., #' contrasts = list(Species = contr.sum) #' ) %>% #' model_identify_variables() model_identify_variables <- function(model) { UseMethod("model_identify_variables") } #' @rdname model_identify_variables #' @export model_identify_variables.default <- function(model) { assign <- model %>% model_get_assign() model_matrix <- attr(assign, "model_matrix") if (is.null(model_matrix) || is.null(assign)) { # return an empty tibble return( dplyr::tibble( variable = NA_character_, var_class = NA_character_, var_type = NA_character_, var_nlevels = NA_integer_ ) %>% dplyr::filter(FALSE) ) } assign[assign == 0] <- NA model_terms <- model_get_terms(model) variable_names <- model %>% model_list_variables(only_variable = TRUE) variables <- attr(model_terms, "term.labels") %>% .clean_backticks(variable_names = variable_names) tibble::tibble( term = colnames(model_matrix), variable = variables[assign] ) %>% # specific case of polynomial terms defined with poly() dplyr::mutate( variable = stringr::str_replace(.data$variable, "^poly\\((.*),(.*)\\)$", "\\1") ) %>% dplyr::left_join( model_list_variables(model) %>% dplyr::select("variable", "var_class"), by = "variable" ) %>% dplyr::left_join( model_get_nlevels(model), by = "variable" ) %>% .compute_var_type() } #' @rdname model_identify_variables #' @export model_identify_variables.lavaan <- function(model) { tibble::tibble( term = paste(model@ParTable$lhs, model@ParTable$op, model@ParTable$rhs), variable = .clean_backticks(model@ParTable$lhs) ) %>% dplyr::left_join( tibble::tibble( variable = .clean_backticks(model@Data@ov$name), var_class = model@Data@ov$type, var_nlevels = model@Data@ov$nlev ), by = "variable" ) %>% dplyr::mutate( var_nlevels = dplyr::if_else( .data$var_nlevels == 0, NA_integer_, .data$var_nlevels ), var_class = dplyr::if_else( .data$var_class == "ordered", "factor", .data$var_class ) ) %>% .compute_var_type() } # for stats::aov(), variable is equal to term #' @rdname model_identify_variables #' @export model_identify_variables.aov <- function(model) { model %>% model_list_variables() %>% dplyr::mutate(term = .data$variable) %>% dplyr::select(dplyr::all_of(c("term", "variable", "var_class"))) %>% dplyr::left_join( model %>% model_get_nlevels(), by = "variable" ) %>% .compute_var_type() } #' @rdname model_identify_variables #' @export model_identify_variables.clm <- function(model) { res <- model_identify_variables.default(model) if (is.null(model$alpha.mat)) { res <- dplyr::bind_rows( res %>% dplyr::filter(.data$term != "(Intercept)"), dplyr::tibble( term = names(model$alpha), var_type = "intercept" ) ) } else { y.levels <- colnames(model$alpha.mat) nominal_terms <- rownames(model$alpha.mat) res <- dplyr::bind_rows( res %>% dplyr::filter(!.data$term %in% nominal_terms), res %>% dplyr::filter(.data$term %in% nominal_terms) %>% tidyr::crossing(y.level = y.levels) %>% dplyr::mutate(term = paste(.data$y.level, .data$term, sep = ".")) ) } res } #' @rdname model_identify_variables #' @export model_identify_variables.clmm <- model_identify_variables.clm #' @rdname model_identify_variables #' @export model_identify_variables.gam <- function(model) { model_identify_variables.default(model) %>% dplyr::bind_rows( # suppressWarnings to avoid a warning when the result is an empty tibble suppressWarnings(broom::tidy(model, parametric = FALSE)) %>% dplyr::bind_rows(tibble::tibble(term = character(0))) %>% dplyr::select(dplyr::all_of("term")) %>% dplyr::mutate(variable = .data$term, var_type = "continuous") ) } #' @export #' @rdname model_identify_variables model_identify_variables.model_fit <- function(model) { model_identify_variables(model$fit) } #' @rdname model_identify_variables #' @importFrom dplyr add_row #' @export model_identify_variables.logitr <- function(model) { res <- model_identify_variables.default(model) if (!is.null(model$data$scalePar)) { res <- res %>% dplyr::add_row( term = "scalePar", variable = "scalePar", var_class = "numeric", var_nlevels = NA, var_type = "continuous" ) } res } ## model_identify_variables() helpers -------------------------- .compute_var_type <- function(x) { cat_classes <- c("factor", "character", "logical") x %>% dplyr::mutate( var_type = dplyr::case_when( is.na(.data$variable) ~ "intercept", .data$var_class %in% cat_classes & .data$var_nlevels <= 2 ~ "dichotomous", .data$var_class %in% cat_classes ~ "categorical", !is.na(.data$var_class) ~ "continuous", is.na(.data$var_class) & stringr::str_detect(.data$variable, ":") ~ "interaction" ) ) } broom.helpers/R/tidy_identify_variables.R0000644000176200001440000001037714457457457020307 0ustar liggesusers#' Identify the variable corresponding to each model coefficient #' #' `tidy_identify_variables()` will add to the tidy tibble #' three additional columns: `variable`, `var_class`, `var_type` and `var_nlevels`. #' #' It will also identify interaction terms and intercept(s). #' #' `var_type` could be: #' #' * `"continuous"`, #' * `"dichotomous"` (categorical variable with 2 levels), #' * `"categorical"` (categorical variable with 3 levels or more), #' * `"intercept"` #' * `"interaction"` #' * `"ran_pars` (random-effect parameters for mixed models) #' * `"ran_vals"` (random-effect values for mixed models) #' * `"unknown"` in the rare cases where `tidy_identify_variables()` #' will fail to identify the list of variables #' #' For dichotomous and categorical variables, `var_nlevels` corresponds to the number #' of original levels in the corresponding variables. #' @param x a tidy tibble #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @seealso [model_identify_variables()] #' @family tidy_helpers #' @examples #' Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) %>% #' tidy_and_attach() %>% #' tidy_identify_variables() #' #' lm( #' Sepal.Length ~ poly(Sepal.Width, 2) + Species, #' data = iris, #' contrasts = list(Species = contr.sum) #' ) %>% #' tidy_and_attach(conf.int = TRUE) %>% #' tidy_identify_variables() tidy_identify_variables <- function(x, model = tidy_get_model(x), quiet = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if ("header_row" %in% names(x)) { cli::cli_abort(paste( "{.fn tidy_identify_variables} cannot be applied", "after {.fn tidy_add_header_rows}." )) } .attributes <- .save_attributes(x) # specific case for marginal means / effects / predictions / contrasts if ( isTRUE( stringr::str_starts(.attributes$coefficients_type, "marginal") && "variable" %in% names(x) ) ) { x <- x %>% dplyr::left_join( model_list_variables(model, add_var_type = TRUE), by = "variable" ) %>% tidy_attach_model(model = model, .attributes = .attributes) return(x) } if ("variable" %in% names(x)) { x <- x %>% dplyr::select( -any_of(c("variable", "var_class", "var_type", "var_nlevels")) ) } variables_list <- model_identify_variables(model) if (nrow(variables_list) > 0) { x <- x %>% dplyr::left_join(variables_list, by = "term") # management of random parameters (mixed models) if ("effect" %in% names(x)) { x <- x %>% dplyr::mutate( var_type = dplyr::if_else( .data$effect %in% c("ran_pars", "ran_vals"), .data$effect, .data$var_type ) ) } x %>% dplyr::mutate( var_type = dplyr::if_else( is.na(.data$var_type), "intercept", .data$var_type ), variable = dplyr::if_else( is.na(.data$variable), .data$term, .data$variable ) ) %>% tidy_attach_model(model = model, .attributes = .attributes) } else { if (!quiet) { cli_alert_danger(paste0( "Unable to identify the list of variables.\n\n", "This is usually due to an error calling {.code stats::model.frame(x)}", "or {.code stats::model.matrix(x)}.\n", "It could be the case if that type of model does not implement these methods.\n", "Rarely, this error may occur if the model object was created within\na ", "functional programming framework (e.g. using {.code lappy()}, ", "{.code purrr::map()}, etc.)." )) } x %>% dplyr::mutate( variable = .data$term, var_class = NA_integer_, var_type = "unknown", var_nlevels = NA_integer_ ) %>% tidy_attach_model(model = model, .attributes = .attributes) } } broom.helpers/R/model_get_offset.R0000644000176200001440000000121114457457113016670 0ustar liggesusers#' Get model offset #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' mod <- glm( #' response ~ trt + offset(log(ttdeath)), #' gtsummary::trial, #' family = poisson #' ) #' mod %>% model_get_offset() model_get_offset <- function(model) { UseMethod("model_get_offset") } #' @export #' @rdname model_get_offset model_get_offset.default <- function(model) { tryCatch( model %>% model_get_model_frame() %>% stats::model.offset(), error = function(e) { NULL # nocov } ) } broom.helpers/R/model_get_nlevels.R0000644000176200001440000000142714457457113017063 0ustar liggesusers#' Get the number of levels for each factor used in `xlevels` #' #' @param model a model object #' @return a tibble with two columns: `"variable"` and `"var_nlevels"` #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_nlevels() model_get_nlevels <- function(model) { UseMethod("model_get_nlevels") } #' @export #' @rdname model_get_nlevels model_get_nlevels.default <- function(model) { nlevels <- model_get_xlevels(model) %>% lapply(length) if (length(nlevels) == 0) { return( dplyr::tibble(variable = NA_character_, var_nlevels = NA_integer_) %>% dplyr::filter(FALSE) # empty tibble ) } dplyr::tibble( variable = names(nlevels), var_nlevels = unlist(nlevels) ) } broom.helpers/R/assert_package.R0000644000176200001440000001321214457457076016353 0ustar liggesusers#' Check a package installation status or minimum required version #' #' The function `.assert_package()` checks whether a package is installed and #' returns an error or `FALSE` if not available. If a package search is provided, #' the function will check whether a minimum version of a package is required. #' The function `.get_package_dependencies()` returns a tibble with all #' dependencies of a specific package. Finally, `.get_min_version_required()` #' will return, if any, the minimum version of `pkg` required by `pkg_search`, #' `NULL` if no minimum version required. #' #' @param pkg Package required #' @param fn Calling function from the user perspective. Used to write #' informative error messages. #' @param pkg_search the package the function will search for a minimum #' required version from. #' @param boolean logical indicating whether to return a `TRUE`/`FALSE`, rather #' than error when package/package version not available. Default is `FALSE`, #' which will return an error if `pkg` is not installed. #' @param remove_duplicates if several versions of a package are installed, #' should only the first one be returned? #' @param lib.loc location of `R` library trees to search through, see #' `utils::installed.packages()`. #' @details #' `get_all_packages_dependencies()` could be used to get the list of #' dependencies of all installed packages. #' #' @return logical or error for `.assert_package()`, `NULL` or character with #' the minimum version required for `.get_min_version_required()`, a tibble for #' `.get_package_dependencies()`. #' #' @name assert_package #' @examplesIf interactive() #' .assert_package("broom", boolean = TRUE) #' .get_package_dependencies() #' .get_min_version_required("brms") NULL #' @rdname assert_package #' @export .assert_package <- function(pkg, fn = NULL, pkg_search = "broom.helpers", boolean = FALSE) { # check if min version is required ------------------------------------------- version <- .get_min_version_required(pkg, pkg_search) compare <- purrr::attr_getter("compare")(version) # check installation TRUE/FALSE ---------------------------------------------- if (isTRUE(boolean)) { return(rlang::is_installed(pkg = pkg, version = version, compare = compare)) } # prompt user to install package --------------------------------------------- rlang::check_installed( pkg = pkg, version = version, compare = compare, reason = switch(!is.null(fn), stringr::str_glue("for `{fn}`") ) ) invisible() } #' @rdname assert_package #' @export .get_package_dependencies <- function(pkg_search = "broom.helpers") { if (is.null(pkg_search)) { return(NULL) } description <- utils::packageDescription(pkg_search) if (identical(description, NA)) { return(NULL) } description %>% unclass() %>% tibble::as_tibble() %>% dplyr::select(dplyr::any_of( c( "Package", "Version", "Imports", "Depends", "Suggests", "Enhances", "LinkingTo" ) )) %>% dplyr::rename( pkg_search = "Package", pkg_search_version = "Version" ) %>% tidyr::pivot_longer( -dplyr::all_of(c("pkg_search", "pkg_search_version")), values_to = "pkg", names_to = "dependency_type", ) %>% tidyr::separate_rows("pkg", sep = ",") %>% dplyr::mutate(pkg = stringr::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 %>% stringr::str_extract(pattern = "[>=<]+"), version = .data$version %>% stringr::str_remove_all(pattern = "[\\(\\) >=<]") ) } #' @rdname assert_package #' @export .get_all_packages_dependencies <- function( pkg_search = NULL, remove_duplicates = FALSE, lib.loc = NULL) { deps <- utils::installed.packages(lib.loc = lib.loc) %>% tibble::as_tibble() %>% dplyr::select(dplyr::all_of( c("Package", "Version", "LibPath", "Imports", "Depends", "Suggests", "Enhances", "LinkingTo") )) %>% dplyr::rename( pkg_search = "Package", pkg_search_version = "Version", lib_path = "LibPath" ) if (!is.null(pkg_search)) { deps <- deps %>% dplyr::filter(.data$pkg_search %in% .env$pkg_search) } if (remove_duplicates) { deps <- deps %>% dplyr::distinct("pkg_search", .keep_all = TRUE) } deps %>% tidyr::pivot_longer( -dplyr::all_of(c("pkg_search", "pkg_search_version", "lib_path")), values_to = "pkg", names_to = "dependency_type", ) %>% tidyr::separate_rows("pkg", sep = ",") %>% dplyr::mutate(pkg = stringr::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 %>% stringr::str_extract(pattern = "[>=<]+"), version = .data$version %>% stringr::str_remove_all(pattern = "[\\(\\) >=<]") ) } #' @rdname assert_package #' @export .get_min_version_required <- function(pkg, pkg_search = "broom.helpers") { if (is.null(pkg_search)) { return(NULL) } res <- .get_package_dependencies(pkg_search) %>% dplyr::filter(.data$pkg == .env$pkg & !is.na(.data$version)) if (nrow(res) == 0) { return(NULL) } version <- res %>% purrr::pluck("version") attr(version, "compare") <- res %>% purrr::pluck("compare") names(version) <- res %>% purrr::pluck("dependency_type") version } broom.helpers/R/tidy_remove_intercept.R0000644000176200001440000000212514370455162017767 0ustar liggesusers#' Remove intercept(s) #' #' Will remove terms where `var_type == "intercept"`. #' #' @details #' If the `variable` column is not yet available in `x`, #' [tidy_identify_variables()] will be automatically applied. #' @param x a tidy tibble #' @param model the corresponding model, if not attached to `x` #' @export #' @family tidy_helpers #' @examples #' Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived)) %>% #' glm(Survived ~ Class + Age + Sex, data = ., weights = .$n, family = binomial) %>% #' tidy_and_attach() %>% #' tidy_remove_intercept() tidy_remove_intercept <- function(x, model = tidy_get_model(x)) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) if (!"var_type" %in% names(x)) { x <- x %>% tidy_identify_variables(model = model) } x %>% dplyr::filter(.data$var_type != "intercept") %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/tidy_add_header_rows.R0000644000176200001440000002511314464175037017535 0ustar liggesusers#' Add header rows variables with several terms #' #' For variables with several terms (usually categorical variables but #' could also be the case of continuous variables with polynomial terms #' or splines), `tidy_add_header_rows()` will add an additional row #' per variable, where `label` will be equal to `var_label`. #' These additional rows could be identified with `header_row` column. #' #' The `show_single_row` argument allows to specify a list #' of dichotomous variables that should be displayed on a single row #' instead of two rows. #' #' The added `header_row` column will be equal to: #' #' * `TRUE` for an header row; #' * `FALSE` for a normal row of a variable with an header row; #' * `NA` for variables without an header row. #' #' If the `label` column is not yet available in `x`, #' [tidy_add_term_labels()] will be automatically applied. #' @param x a tidy tibble #' @param show_single_row a vector indicating the names of binary #' variables that should be displayed on a single row. #' Accepts [tidyselect][dplyr::select] syntax. Default is `NULL`. #' See also [all_dichotomous()] #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' if (.assert_package("gtsummary", boolean = TRUE)) { #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' res <- df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.SAS") #' ) %>% #' tidy_and_attach() %>% #' tidy_add_variable_labels(labels = list(Class = "Custom label for Class")) %>% #' tidy_add_reference_rows() #' res %>% tidy_add_header_rows() #' res %>% tidy_add_header_rows(show_single_row = all_dichotomous()) #' #' glm( #' response ~ stage + grade * trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list( #' stage = contr.treatment(4, base = 3), #' grade = contr.treatment(3, base = 2), #' trt = contr.treatment(2, base = 2) #' ) #' ) %>% #' tidy_and_attach() %>% #' tidy_add_reference_rows() %>% #' tidy_add_header_rows() #' } tidy_add_header_rows <- function(x, show_single_row = NULL, model = tidy_get_model(x), quiet = FALSE, strict = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if ("header_row" %in% names(x)) { if (!quiet) { cli_alert_danger(paste( "{.code tidy_add_header_rows()} has already been applied.", "x has been returned unchanged." )) } return(x) } .attributes <- .save_attributes(x) if (!"label" %in% names(x)) { x <- x %>% tidy_add_term_labels(model = model) } # management of show_single_row -------------- # if reference_rows have been defined, removal of reference row variables_to_simplify <- NULL # obtain character vector of selected variables show_single_row <- .select_to_varnames( {{ show_single_row }}, var_info = x, arg_name = "show_single_row" ) has_reference_row <- "reference_row" %in% names(x) if (!has_reference_row) { x$reference_row <- FALSE } xx <- x if ( "y.level" %in% names(x) && # specific case for multinomial models (inherits(model, "multinom") || inherits(model, "LORgee")) ) { xx <- xx %>% dplyr::filter(.data$y.level == x$y.level[1]) } # checking if variables incorrectly requested for single row summary if ("component" %in% colnames(xx)) { bad_single_row <- xx %>% dplyr::filter( !is.na(.data$variable), is.na(.data$reference_row) | !.data$reference_row, .data$variable %in% show_single_row ) %>% dplyr::group_by(.data$component, .data$variable) %>% dplyr::count() %>% dplyr::filter(.data$n > 1) %>% dplyr::pull(.data$variable) } else { bad_single_row <- xx %>% dplyr::filter( !is.na(.data$variable), is.na(.data$reference_row) | !.data$reference_row, .data$variable %in% show_single_row ) %>% dplyr::group_by(.data$variable) %>% dplyr::count() %>% dplyr::filter(.data$n > 1) %>% dplyr::pull(.data$variable) } if (length(bad_single_row) > 0) { if (!quiet) { paste( "Variable(s) {paste(shQuote(bad_single_row), collapse = \", \")} were", "incorrectly requested to be printed on a single row." ) %>% cli_alert_danger() } if (strict) { cli::cli_abort( "Incorrect call with `show_single_row=`. Quitting execution.", call = NULL ) } show_single_row <- setdiff(show_single_row, bad_single_row) } if ( length(show_single_row) > 0 && any(x$variable %in% show_single_row) ) { if ("component" %in% colnames(xx)) { variables_to_simplify <- xx %>% dplyr::filter( .data$variable %in% show_single_row & !.data$reference_row ) %>% dplyr::count(.data$component, .data$variable) %>% dplyr::filter(.data$n == 1) %>% purrr::pluck("variable") %>% unique() } else { variables_to_simplify <- xx %>% dplyr::filter( .data$variable %in% show_single_row & !.data$reference_row ) %>% dplyr::count(.data$variable) %>% dplyr::filter(.data$n == 1) %>% purrr::pluck("variable") } # removing reference rows of those variables if (length(variables_to_simplify) > 0) { x <- x %>% dplyr::filter( is.na(.data$variable) | !.data$variable %in% variables_to_simplify | (.data$variable %in% variables_to_simplify & !.data$reference_row) ) } # for variables in show_single_row # label should be equal to var_label x <- x %>% dplyr::mutate( label = dplyr::if_else( .data$variable %in% show_single_row, .data$var_label, .data$label ) ) } if (!has_reference_row) { x <- x %>% dplyr::select(-dplyr::all_of("reference_row")) } # computing header rows --------------- x <- x %>% dplyr::mutate( rank = seq_len(dplyr::n()) # for sorting table at the end ) if ( "y.level" %in% names(x) && # specific case for multinomial models (inherits(model, "multinom") || inherits(model, "LORgee")) ) { header_rows <- x %>% dplyr::filter(!is.na(.data$variable) & !.data$variable %in% show_single_row) if (nrow(header_rows) > 0) { header_rows <- header_rows %>% dplyr::mutate(term_cleaned = .clean_backticks(.data$term, .data$variable)) %>% dplyr::group_by(.data$variable, .data$y.level) %>% dplyr::summarise( var_class = dplyr::first(.data$var_class), var_type = dplyr::first(.data$var_type), var_label = dplyr::first(.data$var_label), var_nlevels = dplyr::first(.data$var_nlevels), contrasts = dplyr::first(.data$contrasts), contrasts_type = dplyr::first(.data$contrasts_type), var_nrow = dplyr::n(), var_test = sum(.data$term_cleaned != .data$variable), rank = min(.data$rank) - .25, .groups = "drop_last" ) %>% dplyr::filter(.data$var_nrow >= 2 | .data$var_test > 0) %>% dplyr::select(-dplyr::all_of(c("var_nrow", "var_test"))) %>% dplyr::mutate( header_row = TRUE, label = .data$var_label ) } } else if ("component" %in% names(x)) { header_rows <- x %>% dplyr::filter(!is.na(.data$variable) & !.data$variable %in% show_single_row) if (nrow(header_rows) > 0) { header_rows <- header_rows %>% dplyr::mutate(term_cleaned = .clean_backticks(.data$term, .data$variable)) %>% dplyr::group_by(.data$variable, .data$component) %>% dplyr::summarise( var_class = dplyr::first(.data$var_class), var_type = dplyr::first(.data$var_type), var_label = dplyr::first(.data$var_label), var_nlevels = dplyr::first(.data$var_nlevels), contrasts = dplyr::first(.data$contrasts), contrasts_type = dplyr::first(.data$contrasts_type), var_nrow = dplyr::n(), var_test = sum(.data$term_cleaned != .data$variable), rank = min(.data$rank) - .25, .groups = "drop_last" ) %>% dplyr::filter(.data$var_nrow >= 2 | .data$var_test > 0) %>% dplyr::select(-dplyr::all_of(c("var_nrow", "var_test"))) %>% dplyr::mutate( header_row = TRUE, label = .data$var_label ) } } else { header_rows <- x %>% dplyr::filter( !is.na(.data$variable) & !.data$variable %in% show_single_row & !.data$var_type %in% c("ran_pars", "ran_vals") ) if (nrow(header_rows) > 0) { header_rows <- header_rows %>% dplyr::mutate(term_cleaned = .clean_backticks(.data$term, .data$variable)) %>% dplyr::group_by(.data$variable) %>% dplyr::summarise( var_class = dplyr::first(.data$var_class), var_type = dplyr::first(.data$var_type), var_label = dplyr::first(.data$var_label), var_nlevels = dplyr::first(.data$var_nlevels), contrasts = dplyr::first(.data$contrasts), contrasts_type = dplyr::first(.data$contrasts_type), var_nrow = dplyr::n(), # for dichotomous variables with no reference row var_test = sum(.data$term_cleaned != .data$variable), rank = min(.data$rank) - .25, .groups = "drop_last" ) %>% dplyr::filter(.data$var_nrow >= 2 | .data$var_test > 0) %>% dplyr::select(-dplyr::all_of(c("var_nrow", "var_test"))) %>% dplyr::mutate( header_row = TRUE, label = .data$var_label ) } } x <- x %>% dplyr::mutate( header_row = dplyr::if_else(.data$variable %in% header_rows$variable, FALSE, NA) ) %>% dplyr::bind_rows(header_rows) %>% dplyr::arrange(.data$rank) %>% dplyr::select(-dplyr::all_of("rank")) x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_get_response_variable.R0000644000176200001440000000201714360056067021106 0ustar liggesusers#' Get the name of the response variable #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) %>% #' model_get_response_variable() #' #' mod <- glm( #' response ~ stage * grade + trt, #' gtsummary::trial, #' family = binomial #' ) #' mod %>% model_get_response_variable() #' #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, #' family = binomial #' ) #' mod %>% model_get_response_variable() model_get_response_variable <- function(model) { UseMethod("model_get_response_variable") } #' @export #' @rdname model_get_response_variable model_get_response_variable.default <- function(model) { model_frame <- model %>% model_get_model_frame() model_terms <- model %>% model_get_terms() if (!is.null(model_terms) && inherits(model_terms, "terms")) { return(names(model_frame)[attr(model_terms, "response")]) } else { return(NULL) } } broom.helpers/R/helpers.R0000644000176200001440000000265014357760764015045 0ustar liggesusers#' Escapes any characters that would have special #' meaning in a regular expression #' #' This functions has been adapted from `Hmisc::escapeRegex()` #' @param string a character vector #' @export #' @family other_helpers .escape_regex <- function(string) { gsub( "([.|()\\^{}+$*?]|\\[|\\])", "\\\\\\1", string ) } #' Remove backticks around variable names #' #' @param x a character vector to be cleaned #' @param variable_names list of variable names, #' could be obtained with #' [model_list_variables(only_variable = TRUE)][model_list_variables()] #' to properly take into account interaction only terms/variables #' #' @export #' @family other_helpers .clean_backticks <- function(x, variable_names = x) { saved_names <- names(x) variable_names <- variable_names %>% stats::na.omit() %>% unique() %>% .escape_regex() # cleaning existing backticks in variable_names variable_names <- ifelse( # does string starts and ends with backticks stringr::str_detect(variable_names, "^`.*`$"), # if yes remove first and last character of string stringr::str_sub(variable_names, 2, -2), # otherwise, return original string variable_names ) # cleaning x, including interaction terms for (v in variable_names) { x <- stringr::str_replace_all( x, paste0("`", v, "`"), v ) } names(x) <- saved_names x } broom.helpers/R/model_get_contrasts.R0000644000176200001440000000364014464175037017432 0ustar liggesusers#' Get contrasts used in the model #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' glm( #' am ~ mpg + factor(cyl), #' data = mtcars, #' family = binomial, #' contrasts = list(`factor(cyl)` = contr.sum) #' ) %>% #' model_get_contrasts() model_get_contrasts <- function(model) { UseMethod("model_get_contrasts") } #' @export model_get_contrasts.default <- function(model) { # we try 3 different approaches in a row mc <- model_get_contrasts_1(model) if (is.null(mc)) { mc <- model_get_contrasts_2(model) } if (is.null(mc)) { mc <- model_get_contrasts_3(model) } mc } model_get_contrasts_1 <- function(model) { tryCatch( purrr::chuck(model, "contrasts"), error = function(e) { NULL } ) } model_get_contrasts_2 <- function(model) { tryCatch( attr(model_get_model_matrix(model), "contrasts"), error = function(e) { NULL } ) } model_get_contrasts_3 <- function(model) { tryCatch( attr(stats::model.matrix(stats::terms(model), stats::model.frame(model)), "contrasts"), error = function(e) { NULL } ) } #' @export #' @rdname model_get_contrasts model_get_contrasts.model_fit <- function(model) { model_get_contrasts(model$fit) } #' @export #' @rdname model_get_contrasts model_get_contrasts.zeroinfl <- function(model) { mc <- model_get_contrasts_1(model) res <- mc$count # merging/combining the two lists for (v in names(mc$zero)) res[[v]] <- mc$zero[[v]] res } #' @export #' @rdname model_get_contrasts model_get_contrasts.hurdle <- model_get_contrasts.zeroinfl #' @export #' @rdname model_get_contrasts model_get_contrasts.betareg <- function(model) { mc <- model_get_contrasts_1(model) res <- mc$mean # merging/combining the two lists for (v in names(mc$precision)) res[[v]] <- mc$precision[[v]] res } broom.helpers/R/tidy_add_variable_labels.R0000644000176200001440000001055614370455162020343 0ustar liggesusers#' Add variable labels #' #' Will add variable labels in a `var_label` column, based on: #' 1. labels provided in `labels` argument if provided; #' 2. variable labels defined in the original data frame with #' the `label` attribute (cf. [labelled::var_label()]); #' 3. variable name otherwise. #' #' @details #' If the `variable` column is not yet available in `x`, #' [tidy_identify_variables()] will be automatically applied. #' #' It is possible to pass a custom label for an interaction #' term in `labels` (see examples). #' @param x a tidy tibble #' @param labels an optional named list or named vector of #' custom variable labels #' @param interaction_sep separator for interaction terms #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examples #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' labelled::set_variable_labels( #' Class = "Passenger's class", #' Sex = "Sex" #' ) #' #' df %>% #' glm(Survived ~ Class * Age * Sex, data = ., weights = .$n, family = binomial) %>% #' tidy_and_attach() %>% #' tidy_add_variable_labels( #' labels = list( #' "(Intercept)" = "Custom intercept", #' Sex = "Gender", #' "Class:Age" = "Custom label" #' ) #' ) tidy_add_variable_labels <- function(x, labels = NULL, interaction_sep = " * ", model = tidy_get_model(x), quiet = FALSE, strict = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if ("header_row" %in% names(x)) { cli::cli_abort(paste( "{.fn tidy_add_variable_labels} cannot be applied", "after {.fn tidy_add_header_rows}." )) } .attributes <- .save_attributes(x) if ("var_label" %in% names(x)) { x <- x %>% dplyr::select(-dplyr::all_of("var_label")) } if (!"variable" %in% names(x) || !"var_type" %in% names(x)) { x <- x %>% tidy_identify_variables(model = model) } labels <- .formula_list_to_named_list(labels, var_info = x, arg_name = "labels") if (is.list(labels)) { labels <- unlist(labels) } # start with the list of terms var_labels <- unique(x$term) names(var_labels) <- var_labels # add the list of variables from x additional_labels <- x$variable[!is.na(x$variable)] %>% unique() names(additional_labels) <- additional_labels var_labels <- var_labels %>% .update_vector(additional_labels) # add the list of variables from model_list_variables variable_list <- model_list_variables(model, labels = labels) additional_labels <- variable_list$var_label names(additional_labels) <- variable_list$variable var_labels <- var_labels %>% .update_vector(additional_labels) # check if all elements of labels are in x # show a message otherwise not_found <- setdiff(names(labels), names(var_labels)) if (length(not_found) > 0 && !quiet) { cli_alert_danger("{.code {not_found}} terms have not been found in {.code x}.") } if (length(not_found) > 0 && strict) { cli::cli_abort("Incorrect call with `labels=`. Quitting execution.", call = NULL) } var_labels <- var_labels %>% .update_vector(labels) # save custom labels .attributes$variable_labels <- labels # management of interaction terms interaction_terms <- x$variable[!is.na(x$var_type) & x$var_type == "interaction"] # do not treat those specified in labels interaction_terms <- setdiff(interaction_terms, names(labels)) names(interaction_terms) <- interaction_terms # compute labels for interaction terms interaction_terms <- interaction_terms %>% strsplit(":") %>% lapply(function(x) { paste(var_labels[x], collapse = interaction_sep) }) %>% unlist() var_labels <- var_labels %>% .update_vector(interaction_terms) x %>% dplyr::left_join( tibble::tibble( variable = names(var_labels), var_label = var_labels ), by = "variable" ) %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/tidy_and_attach.R0000644000176200001440000001157714457457141016523 0ustar liggesusers#' Attach a full model to the tibble of model terms #' #' To facilitate the use of broom helpers with pipe, it is recommended to #' attach the original model as an attribute to the tibble of model terms #' generated by `broom::tidy()`. #' #' `tidy_attach_model()` attach the model to a tibble already generated while #' `tidy_and_attach()` will apply `broom::tidy()` and attach the model. #' #' Use `tidy_get_model()` to get the model attached to the tibble and #' `tidy_detach_model()` to remove the attribute containing the model. #' @param model a model to be attached/tidied #' @param x a tibble of model terms #' @param tidy_fun option to specify a custom tidier function #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level level of confidence for confidence intervals (default: 95%) #' @param exponentiate logical indicating whether or not to exponentiate the #' coefficient estimates. This is typical for logistic, Poisson and Cox models, #' but a bad idea if there is no log or logit link; defaults to `FALSE` #' @param .attributes named list of additional attributes to be attached to `x` #' @param ... other arguments passed to `tidy_fun()` #' @family tidy_helpers #' @examples #' mod <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) #' tt <- mod %>% #' tidy_and_attach(conf.int = TRUE) #' tt #' tidy_get_model(tt) #' @export tidy_attach_model <- function(x, model, .attributes = NULL) { x <- x %>% dplyr::as_tibble() %>% .order_tidy_columns() class(x) <- c("broom.helpers", class(x)) model <- model_get_model(model) # if force_contr.treatment if (isTRUE(attr(x, "force_contr.treatment"))) { for (v in names(model$contrasts)) { model$contrasts[[v]] <- "contr.treatment" } } attr(x, "model") <- model for (a in names(.attributes)) { if (!is.null(.attributes[[a]])) { attr(x, a) <- .attributes[[a]] } } x } #' @rdname tidy_attach_model #' @export tidy_and_attach <- function( model, tidy_fun = tidy_with_broom_or_parameters, conf.int = TRUE, conf.level = .95, exponentiate = FALSE, ...) { # exponentiate cannot be used with lm models # but broom will not produce an error and will return unexponentiated estimates if (identical(class(model), "lm") && exponentiate) { cli::cli_abort("{.code exponentiate = TRUE} is not valid for this type of model.") } tidy_args <- list(...) tidy_args$x <- model tidy_args$conf.int <- conf.int if (conf.int) tidy_args$conf.level <- conf.level tidy_args$exponentiate <- exponentiate # test if exponentiate can be passed to tidy_fun, and if tidy_fun runs without error result <- tryCatch( do.call(tidy_fun, tidy_args) %>% tidy_attach_model( model, .attributes = list( exponentiate = exponentiate, conf.level = conf.level ) ), error = function(e) { # `tidy_fun()` fails for two primary reasons: # 1. `tidy_fun()` does not accept the `exponentiate=` arg # - in this case, we re-run `tidy_fun()` without the `exponentiate=` argument # 2. Incorrect input or incorrect custom `tidy_fun()` passed # - in this case, we print a message explaining the likely source of error # first attempting to run without `exponentiate=` argument tryCatch( { tidy_args$exponentiate <- NULL xx <- do.call(tidy_fun, tidy_args) %>% tidy_attach_model( model, .attributes = list(exponentiate = FALSE, conf.level = conf.level) ) if (exponentiate) { cli::cli_alert_warning( "`exponentiate = TRUE` is not valid for this type of model and was ignored." ) } xx }, error = function(e) { # if error persists, then there is a problem with either model input or `tidy_fun=` paste0( "There was an error calling {.code tidy_fun()}. ", "Most likely, this is because the function supplied in {.code tidy_fun=} ", "was misspelled, does not exist, is not compatible with your object, ", "or was missing necessary arguments (e.g. {.code conf.level=} ", "or {.code conf.int=}). See error message below." ) %>% stringr::str_wrap() %>% cli_alert_danger() cli::cli_abort(as.character(e), call = NULL) } ) } ) # return result result } #' @rdname tidy_attach_model #' @export tidy_get_model <- function(x) { attr(x, "model") } #' @rdname tidy_attach_model #' @export tidy_detach_model <- function(x) { attr(x, "model") <- NULL x } broom.helpers/R/model_get_model_matrix.R0000644000176200001440000000717414464175037020104 0ustar liggesusers#' Get the model matrix of a model #' #' The structure of the object returned by [stats::model.matrix()] #' could slightly differ for certain types of models. #' `model_get_model_matrix()` will always return an object #' with the same structure as [stats::model.matrix.default()]. #' #' @param model a model object #' @param ... additional arguments passed to [stats::model.matrix()] #' @export #' @family model_helpers #' @seealso [stats::model.matrix()] #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_model_matrix() %>% #' head() model_get_model_matrix <- function(model, ...) { UseMethod("model_get_model_matrix") } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.default <- function(model, ...) { tryCatch( stats::model.matrix(model, ...), error = function(e) { tryCatch( # test second approach stats::model.matrix(stats::terms(model), model$model, ...), error = function(e) { NULL } ) } ) } #' @export #' @rdname model_get_model_matrix # For multinom models, names of the model matrix are not # consistent with the terms names when contrasts other # than treatment are used, resulting in an issue for # the identification of variables model_get_model_matrix.multinom <- function(model, ...) { mm <- stats::model.matrix(model, ...) co <- stats::coef(model) if (is.matrix(co)) { colnames(mm) <- colnames(co) } else { colnames(mm) <- names(co) } mm } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.clm <- function(model, ...) { stats::model.matrix(model, ...)[[1]] } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.brmsfit <- function(model, ...) { model %>% brms::standata() %>% purrr::pluck("X") } #' @export #' @rdname model_get_model_matrix #' @details #' For models fitted with `glmmTMB::glmmTMB()`, it will return a model matrix #' taking into account all components ("cond", "zi" and "disp"). For a more #' restricted model matrix, please refer to `glmmTMB::model.matrix.glmmTMB()`. model_get_model_matrix.glmmTMB <- function(model, ...) { # load lme4 if available .assert_package("lme4", fn = "broom.helpers::model_get_model_matrix.glmmTMB()") stats::model.matrix( lme4::nobars(model$modelInfo$allForm$combForm), stats::model.frame(model, ...), contrasts.arg = model$modelInfo$contrasts ) } #' @export #' @rdname model_get_model_matrix #' @details #' For [plm::plm()] models, constant columns are not removed. model_get_model_matrix.plm <- function(model, ...) { stats::model.matrix(model, cstcovar.rm = "none", ...) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.biglm <- function(model, ...) { stats::model.matrix( model, data = stats::model.frame.default(model) ) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.model_fit <- function(model, ...) { model_get_model_matrix(model$fit, ...) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.fixest <- function(model, ...) { stats::model.matrix.default(model$fml, data = get(model$call$data, model$call_env), ...) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.LORgee <- function(model, ...) { stats::model.matrix.default( model, data = stats::model.frame(model) ) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.betareg <- function(model, ...) { stats::model.matrix.default( model %>% model_get_terms(), data = model %>% model_get_model_frame() ) } broom.helpers/R/marginal_tidiers.R0000644000176200001440000012261114457460664016715 0ustar liggesusers#' Average Marginal Effects with `margins::margins()` #' #' `r lifecycle::badge("experimental")` #' Use `margins::margins()` to estimate average marginal effects (AME) and #' return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. See `margins::margins()` for a list of supported models. #' @details #' By default, `margins::margins()` estimate average marginal effects (AME): an #' effect is computed for each observed value in the original dataset before #' being averaged. #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @note When applying `margins::margins()`, custom contrasts are ignored. #' Treatment contrasts (`stats::contr.treatment()`) are applied to all #' categorical variables. Interactions are also ignored. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to `margins::margins()` #' @family marginal_tieders #' @seealso `margins::margins()` #' @export #' @examplesIf interactive() #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_margins(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_margins) tidy_margins <- function(x, conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("margins") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_margins}.") # nolint } res <- broom::tidy( margins::margins(x, ...), conf.int = conf.int, conf.level = conf.level ) attr(res, "coefficients_type") <- "marginal_effects_average" attr(res, "force_contr.treatment") <- TRUE res } #' Marginal Predictions at the mean with `effects::allEffects()` #' #' `r lifecycle::badge("experimental")` #' Use `effects::allEffects()` to estimate marginal predictions and #' return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. #' See `vignette("functions-supported-by-effects", package = "effects")` for #' a list of supported models. #' @details #' By default, `effects::allEffects()` estimate marginal predictions at the mean #' at the observed means for continuous variables and weighting modalities #' of categorical variables according to their observed distribution in the #' original dataset. Marginal predictions are therefore computed at #' a sort of averaged situation / typical values for the other variables fixed #' in the model. #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @note #' If the model contains interactions, `effects::allEffects()` will return #' marginal predictions for the different levels of the interactions. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to `effects::allEffects()` #' @family marginal_tieders #' @seealso `effects::allEffects()` #' @export #' @examplesIf interactive() #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_all_effects(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_all_effects) tidy_all_effects <- function(x, conf.int = TRUE, conf.level = .95, ...) { .assert_package("effects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_all_effects}.") # nolint } if ( inherits(x, "multinom") || inherits(x, "polr") || inherits(x, "clm") || inherits(x, "clmm") ) { return(tidy_all_effects_effpoly(x, conf.int, conf.level, ...)) } .clean <- function(x) { # merge first columns if interaction x <- tidyr::unite(x, "term", 1:(ncol(x) - 4), sep = ":") names(x) <- c("term", "estimate", "std.error", "conf.low", "conf.high") x$term <- as.character(x$term) rownames(x) <- NULL x } res <- x %>% effects::allEffects(se = conf.int, level = conf.level, ...) %>% as.data.frame() %>% purrr::map(.clean) %>% dplyr::bind_rows(.id = "variable") %>% dplyr::relocate("variable", "term") attr(res, "coefficients_type") <- "marginal_predictions_at_mean" attr(res, "skip_add_reference_rows") <- TRUE attr(res, "find_missing_interaction_terms") <- TRUE res } tidy_all_effects_effpoly <- function(x, conf.int = TRUE, conf.level = .95, ...) { res <- x %>% effects::allEffects(se = conf.int, level = conf.level, ...) %>% purrr::map(effpoly_to_df) %>% dplyr::bind_rows(.id = "variable") %>% dplyr::relocate("y.level", "variable", "term") attr(res, "coefficients_type") <- "marginal_predictions_at_mean" attr(res, "skip_add_reference_rows") <- TRUE attr(res, "find_missing_interaction_terms") <- TRUE res } effpoly_to_df <- function(x) { factors <- sapply(x$variables, function(x) x$is.factor) factor.levels <- lapply(x$variables[factors], function(x) x$levels) if (!length(factor.levels) == 0) { factor.names <- names(factor.levels) for (fac in factor.names) { x$x[[fac]] <- factor(x$x[[fac]], levels = factor.levels[[fac]], exclude = NULL ) } } result <- rep.int(list(x$x), length(x$y.levels)) names(result) <- x$y.levels result <- result %>% dplyr::bind_rows(.id = "y.level") # merge columns if interaction result <- result %>% tidyr::unite("term", 2:ncol(result), sep = ":") result$estimate <- as.vector(x$prob) result$std.error <- as.vector(x$se.prob) if (!is.null(x$confidence.level)) { result$conf.low <- as.vector(x$lower.prob) result$conf.high <- as.vector(x$upper.prob) } result } #' Marginal Predictions with `ggeffects::ggpredict()` #' #' `r lifecycle::badge("experimental")` #' Use `ggeffects::ggpredict()` to estimate marginal predictions #' and return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. #' See for a list of supported #' models. #' @details #' By default, `ggeffects::ggpredict()` estimate marginal predictions at the #' observed mean of continuous variables and at the first modality of categorical #' variables (regardless of the type of contrasts used in the model). #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @note #' By default, `ggeffects::ggpredict()` estimates marginal predictions for each #' individual variable, regardless of eventual interactions. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to `ggeffects::ggpredict()` #' @family marginal_tieders #' @seealso `ggeffects::ggpredict()` #' @export #' @examplesIf interactive() #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_ggpredict(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_ggpredict) tidy_ggpredict <- function(x, conf.int = TRUE, conf.level = .95, ...) { .assert_package("ggeffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_ggpredict}.") # nolint } if (isFALSE(conf.int)) conf.level <- NA res <- x %>% ggeffects::ggpredict(ci.lvl = conf.level) %>% # add ... purrr::map( ~ .x %>% dplyr::as_tibble() %>% dplyr::mutate(x = as.character(.data$x)) ) %>% dplyr::bind_rows() %>% dplyr::rename( variable = "group", term = "x", estimate = "predicted" ) %>% dplyr::relocate("variable", "term") # multinomial models if ("response.level" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "response.level") %>% dplyr::relocate("y.level") } attr(res, "coefficients_type") <- "marginal_predictions" attr(res, "skip_add_reference_rows") <- TRUE res } #' Marginal Slopes / Effects with `marginaleffects::avg_slopes()` #' #' `r lifecycle::badge("experimental")` #' Use `marginaleffects::avg_slopes()` to estimate marginal slopes / effects and #' return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. See `marginaleffects::avg_slopes()` for a list of supported #' models. #' @details #' By default, `marginaleffects::avg_slopes()` estimate average marginal #' effects (AME): an effect is computed for each observed value in the original #' dataset before being averaged. Marginal Effects at the Mean (MEM) could be #' computed by specifying `newdata = "mean"`. Other types of marginal effects #' could be computed. Please refer to the documentation page of #' `marginaleffects::avg_slopes()`. #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to #' `marginaleffects::avg_slopes()` #' @family marginal_tieders #' @seealso `marginaleffects::avg_slopes()` #' @export #' @examplesIf interactive() #' # Average Marginal Effects (AME) #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_avg_slopes(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes) #' #' mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) #' tidy_avg_slopes(mod2) #' #' # Marginal Effects at the Mean (MEM) #' tidy_avg_slopes(mod, newdata = "mean") #' tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes, newdata = "mean") tidy_avg_slopes <- function(x, conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("marginaleffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_avg_slopes}.") # nolint } dots$exponentiate <- NULL dots$conf_level <- conf.level dots$model <- x res <- do.call(marginaleffects::avg_slopes, dots) %>% dplyr::rename(variable = "term") if ("contrast" %in% names(res)) { res <- res %>% dplyr::rename(term = "contrast") } else { res <- res %>% dplyr::mutate(term = .data$variable) } res <- res %>% dplyr::relocate("variable", "term") # multinomial models if ("group" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "group") %>% dplyr::relocate("y.level") } attr(res, "coefficients_type") <- dplyr::case_when( is.null(dots$newdata) ~ "marginal_effects_average", isTRUE(dots$newdata == "mean") ~ "marginal_effects_at_mean", isTRUE(dots$newdata == "marginalmeans") ~ "marginal_effects_at_marginalmeans", TRUE ~ "marginal_effects" ) attr(res, "skip_add_reference_rows") <- TRUE res %>% dplyr::as_tibble() } #' Marginal Contrasts with `marginaleffects::avg_comparisons()` #' #' `r lifecycle::badge("experimental")` #' Use `marginaleffects::avg_comparisons()` to estimate marginal contrasts and #' return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. See `marginaleffects::avg_comparisons()` for a list of supported #' models. #' @details #' By default, `marginaleffects::avg_comparisons()` estimate average marginal #' contrasts: a contrast is computed for each observed value in the original #' dataset (counterfactual approach) before being averaged. #' Marginal Contrasts at the Mean could be computed by specifying #' `newdata = "mean"`. The `variables` argument can be used to select the #' contrasts to be computed. Please refer to the documentation page of #' `marginaleffects::avg_comparisons()`. #' #' See also `tidy_marginal_contrasts()` for taking into account interactions. #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to #' `marginaleffects::avg_comparisons()` #' @family marginal_tieders #' @seealso `marginaleffects::avg_comparisons()` #' @export #' @examplesIf interactive() #' # Average Marginal Contrasts #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_avg_comparisons(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons) #' #' mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) #' tidy_avg_comparisons(mod2) #' #' # Custumizing the type of contrasts #' tidy_avg_comparisons( #' mod2, #' variables = list(Petal.Width = 2, Species = "pairwise") #' ) #' #' # Marginal Contrasts at the Mean #' tidy_avg_comparisons(mod, newdata = "mean") #' tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons, newdata = "mean") tidy_avg_comparisons <- function(x, conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("marginaleffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_avg_comparisons}.") # nolint } dots$exponentiate <- NULL dots$conf_level <- conf.level dots$model <- x res <- do.call(marginaleffects::avg_comparisons, dots) %>% dplyr::rename(variable = "term") if ("contrast" %in% names(res)) { res <- res %>% dplyr::rename(term = "contrast") } else { res <- res %>% dplyr::mutate(term = .data$variable) } res <- res %>% dplyr::relocate("variable", "term") # multinomial models if ("group" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "group") %>% dplyr::relocate("y.level") } attr(res, "coefficients_type") <- dplyr::case_when( is.null(dots$newdata) ~ "marginal_contrasts_average", isTRUE(dots$newdata == "mean") ~ "marginal_contrasts_at_mean", isTRUE(dots$newdata == "marginalmeans") ~ "marginal_contrasts_at_marginalmeans", TRUE ~ "marginal_contrasts" ) attr(res, "skip_add_reference_rows") <- TRUE res %>% dplyr::as_tibble() } #' Marginal Means with `marginaleffects::marginal_means()` #' #' `r lifecycle::badge("experimental")` #' Use `marginaleffects::marginal_means()` to estimate marginal means and #' return a tibble tidied in a way that it could be used by `broom.helpers` #' functions. See `marginaleffects::marginal_means()()` for a list of supported #' models. #' @details #' `marginaleffects::marginal_means()` estimate marginal means: #' adjusted predictions, averaged across a grid of categorical predictors, #' holding other numeric predictors at their means. Please refer to the #' documentation page of `marginaleffects::marginal_means()`. Marginal means #' are defined only for categorical variables. #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to #' `marginaleffects::marginal_means()` #' @family marginal_tieders #' @seealso `marginaleffects::marginal_means()` #' @export #' @examplesIf interactive() #' # Average Marginal Means #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_marginal_means(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_marginal_means) #' #' mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) #' tidy_marginal_means(mod2) tidy_marginal_means <- function(x, conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("marginaleffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_marginal_means}.") # nolint } dots$exponentiate <- NULL dots$conf_level <- conf.level dots$model <- x res <- do.call(marginaleffects::marginal_means, dots) %>% dplyr::rename( variable = "term", term = "value" ) %>% dplyr::mutate(term = as.character(.data$term)) # multinomial models if ("group" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "group") %>% dplyr::relocate("y.level") } attr(res, "coefficients_type") <- "marginal_means" attr(res, "skip_add_reference_rows") <- TRUE res %>% dplyr::as_tibble() } #' Marginal Predictions with `marginaleffects::avg_predictions()` #' #' `r lifecycle::badge("experimental")` #' Use `marginaleffects::avg_predictions()` to estimate marginal predictions for #' each variable of a model and return a tibble tidied in a way that it could #' be used by `broom.helpers` functions. #' See `marginaleffects::avg_predictions()` for a list of supported models. #' @details #' Marginal predictions are obtained by calling, for each variable, #' `marginaleffects::avg_predictions()` with the same variable being used for #' the `variables` and the `by` argument. #' #' Considering a categorical variable named `cat`, `tidy_marginal_predictions()` #' will call `avg_predictions(model, variables = list(cat = unique), by = "cat")` #' to obtain average marginal predictions for this variable. #' #' Considering a continuous variable named `cont`, `tidy_marginal_predictions()` #' will call `avg_predictions(model, variables = list(cont = "fivenum"), by = "cont")` #' to obtain average marginal predictions for this variable at the minimum, the #' first quartile, the median, the third quartile and the maximum of the observed #' values of `cont`. #' #' By default, *average marginal predictions* are computed: predictions are made #' using a counterfactual grid for each value of the variable of interest, #' before averaging the results. *Marginal predictions at the mean* could be #' obtained by indicating `newdata = "mean"`. Other assumptions are possible, #' see the help file of `marginaleffects::avg_predictions()`. #' #' `tidy_marginal_predictions()` will compute marginal predictions for each #' variable or combination of variables, before stacking the results in a unique #' tibble. This is why `tidy_marginal_predictions()` has a `variables_list` #' argument consisting of a list of specifications that will be passed #' sequentially to the `variables` argument of `marginaleffects::avg_predictions()`. #' #' The helper function `variables_to_predict()` could be used to automatically #' generate a suitable list to be used with `variables_list`. By default, all #' unique values are retained for categorical variables and `fivenum` (i.e. #' Tukey's five numbers, minimum, quartiles and maximum) for continuous variables. #' When `interactions = FALSE`, `variables_to_predict()` will return a list of #' all individual variables used in the model. If `interactions = FALSE`, it #' will search for higher order combinations of variables (see #' `model_list_higher_order_variables()`). #' #' `variables_list`'s default value, `"auto"`, calls #' `variables_to_predict(interactions = TRUE)` while `"no_interaction"` is a #' shortcut for `variables_to_predict(interactions = FALSE)`. #' #' You can also provide custom specifications (see examples). #' #' `plot_marginal_predictions()` works in a similar way and returns a list of #' plots that could be combined with `patchwork::wrap_plots()` (see examples). #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @param x a model #' @param variables_list a list whose elements will be sequentially passed to #' `variables` in `marginaleffects::avg_predictions()` (see details below); #' alternatively, it could also be the string `"auto"` (default) or #' `"no_interaction"` #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to #' `marginaleffects::avg_predictions()` #' @family marginal_tieders #' @seealso `marginaleffects::avg_predictions()` #' @export #' @examplesIf interactive() #' # Average Marginal Predictions #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_marginal_predictions(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_marginal_predictions) #' if (require("patchwork")) { #' plot_marginal_predictions(mod) %>% patchwork::wrap_plots() #' plot_marginal_predictions(mod) %>% #' patchwork::wrap_plots() & #' ggplot2::scale_y_continuous(limits = c(0, 1), label = scales::percent) #' } #' #' mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) #' tidy_marginal_predictions(mod2) #' if (require("patchwork")) { #' plot_marginal_predictions(mod2) %>% patchwork::wrap_plots() #' } #' tidy_marginal_predictions( #' mod2, #' variables_list = variables_to_predict(mod2, continuous = "threenum") #' ) #' tidy_marginal_predictions( #' mod2, #' variables_list = list( #' list(Petal.Width = c(0, 1, 2, 3)), #' list(Species = unique) #' ) #' ) #' tidy_marginal_predictions( #' mod2, #' variables_list = list(list(Species = unique, Petal.Width = 1:3)) #' ) #' #' # Model with interactions #' mod3 <- glm( #' Survived ~ Sex * Age + Class, #' data = df, family = binomial #' ) #' tidy_marginal_predictions(mod3) #' tidy_marginal_predictions(mod3, "no_interaction") #' if (require("patchwork")) { #' plot_marginal_predictions(mod3) %>% #' patchwork::wrap_plots() #' plot_marginal_predictions(mod3, "no_interaction") %>% #' patchwork::wrap_plots() #' } #' tidy_marginal_predictions( #' mod3, #' variables_list = list( #' list(Class = unique, Sex = "Female"), #' list(Age = unique) #' ) #' ) #' #' # Marginal Predictions at the Mean #' tidy_marginal_predictions(mod, newdata = "mean") #' if (require("patchwork")) { #' plot_marginal_predictions(mod, newdata = "mean") %>% #' patchwork::wrap_plots() #' } tidy_marginal_predictions <- function(x, variables_list = "auto", conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("marginaleffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_marginal_predictions}.") # nolint } dots$exponentiate <- NULL dots$conf_level <- conf.level dots$model <- x if (is.character(variables_list) && variables_list == "auto") { variables_list <- variables_to_predict(x, interactions = TRUE) } if (is.character(variables_list) && variables_list == "no_interaction") { variables_list <- variables_to_predict(x, interactions = FALSE) } if (!is.list(variables_list)) { cli::cli_abort("{.arg variables_list} should be a list or \"auto\" or \"no_interaction\".") } res <- purrr::map_df(variables_list, .tidy_one_marginal_prediction, dots) attr(res, "coefficients_type") <- dplyr::case_when( is.null(dots$newdata) ~ "marginal_predictions_average", isTRUE(dots$newdata == "mean") ~ "marginal_predictions_at_mean", isTRUE(dots$newdata == "marginalmeans") ~ "marginal_predictions_at_marginalmeans", TRUE ~ "marginal_predictions" ) attr(res, "skip_add_reference_rows") <- TRUE res } .tidy_one_marginal_prediction <- function(variables, dots) { dots$variables <- variables dots$by <- names(variables) if ( inherits(dots$model, "multinom") || inherits(dots$model, "polr") || inherits(dots$model, "clm") || inherits(dots$model, "clmm") ) { dots$by <- c(dots$by, "group") } res <- do.call(marginaleffects::avg_predictions, dots) %>% dplyr::mutate(variable = paste(names(variables), collapse = ":")) %>% tidyr::unite(col = "term", sep = " * ", dplyr::all_of(names(variables))) %>% dplyr::relocate("variable", "term") if ("group" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "group") %>% dplyr::relocate("y.level") } res } #' @export #' @param model a model #' @param interactions should combinations of variables corresponding to #' interactions be returned? #' @param categorical default value for categorical variables #' @param continuous default value for continuous variables #' @rdname tidy_marginal_predictions variables_to_predict <- function(model, interactions = TRUE, categorical = unique, continuous = stats::fivenum) { variables <- model %>% model_list_variables(add_var_type = TRUE) if (interactions) { keep <- model_list_higher_order_variables(model) } else { keep <- variables[variables$var_type != "interaction", ]$variable } response_variable <- model %>% model_get_response_variable() if (!is.null(response_variable)) { keep <- keep[keep != response_variable] } ret <- list( categorical = categorical, dichotomous = categorical, continuous = continuous ) variables <- variables %>% tibble::column_to_rownames("variable") one_element <- function(v) { v <- strsplit(v, ":") %>% unlist() one <- variables[v, "var_type"] one <- ret[one] names(one) <- v one } lapply(keep, one_element) } #' @export #' @rdname tidy_marginal_predictions plot_marginal_predictions <- function(x, variables_list = "auto", conf.level = 0.95, ...) { .assert_package("marginaleffects") .assert_package("ggplot2") dots <- rlang::dots_list(...) dots$conf_level <- conf.level dots$model <- x if (is.character(variables_list) && variables_list == "auto") { variables_list <- variables_to_predict(x, interactions = TRUE) %>% purrr::map(rev) } if (is.character(variables_list) && variables_list == "no_interaction") { variables_list <- variables_to_predict(x, interactions = FALSE) %>% purrr::map(rev) } if (!is.list(variables_list)) { cli::cli_abort("{.arg variables_list} should be a list or \"auto\" or \"no_interaction\".") } purrr::map(variables_list, .plot_one_marginal_prediction, dots) } .plot_one_marginal_prediction <- function(variables, dots) { if (length(variables) >= 4) { cli::cli_abort(paste( "Combination of 4 or more variables. {.fun plot_marginal_predictions} can", "manage only combinations of 3 variables or less." )) } multinom <- inherits(dots$model, "multinom") | inherits(dots$model, "polr") | inherits(dots$model, "clm") | inherits(dots$model, "clmm") list_variables <- dots$model %>% model_list_variables(add_var_type = TRUE) x_variable <- names(variables[1]) x_type <- list_variables %>% dplyr::filter(.data$variable == x_variable) %>% dplyr::pull("var_type") if (x_type == "dichotomous") x_type <- "categorical" x_label <- list_variables %>% dplyr::filter(.data$variable == x_variable) %>% dplyr::pull("var_label") if (is.character(variables[[1]]) && variables[[1]] == "fivenum") { variables[[1]] <- broom.helpers::seq_range } dots$variables <- variables dots$by <- names(variables) if (multinom) { dots$by <- c(dots$by, "group") } d <- do.call(marginaleffects::avg_predictions, dots) mapping <- ggplot2::aes( x = .data[[x_variable]], y = .data[["estimate"]], ymin = .data[["conf.low"]], ymax = .data[["conf.high"]] ) if (x_type == "continuous") { mapping$group <- ggplot2::aes(group = 1L)$group } if (length(variables) >= 2) { colour_variable <- names(variables[2]) d[[colour_variable]] <- factor(d[[colour_variable]]) colour_label <- list_variables %>% dplyr::filter(.data$variable == colour_variable) %>% dplyr::pull("var_label") mapping$colour <- ggplot2::aes(colour = .data[[colour_variable]])$colour if (x_type == "continuous") { mapping$fill <- ggplot2::aes(fill = .data[[colour_variable]])$fill mapping$group <- ggplot2::aes(group = .data[[colour_variable]])$group } } if (x_type == "continuous") { p <- ggplot2::ggplot(d, mapping = mapping) + ggplot2::geom_ribbon( mapping = ggplot2::aes(colour = NULL), alpha = 0.1, show.legend = FALSE ) + ggplot2::geom_line() } else { p <- ggplot2::ggplot(d, mapping = mapping) + ggplot2::geom_pointrange(position = ggplot2::position_dodge(.5)) } if (length(variables) >= 2) { p <- p + ggplot2::labs(colour = colour_label, fill = colour_label) } if (length(variables) == 3 && !multinom) { facet_variable <- names(variables[3]) p <- p + ggplot2::facet_wrap(facet_variable) } if (multinom && length(variables) <= 2) { p <- p + ggplot2::facet_wrap("group") } if (multinom && length(variables) == 3) { facet_variable <- c("group", names(variables[3])) p <- p + ggplot2::facet_wrap(facet_variable) } p + ggplot2::xlab(x_label) + ggplot2::ylab(NULL) + ggplot2::theme_light() + ggplot2::theme(legend.position = "bottom") } #' Marginal Contrasts with `marginaleffects::avg_comparisons()` #' #' `r lifecycle::badge("experimental")` #' Use `marginaleffects::avg_comparisons()` to estimate marginal contrasts for #' each variable of a model and return a tibble tidied in a way that it could #' be used by `broom.helpers` functions. #' See `marginaleffects::avg_comparisons()` for a list of supported models. #' @details #' Marginal contrasts are obtained by calling, for each variable or combination #' of variables, `marginaleffects::avg_comparisons()`. #' #' `tidy_marginal_contrasts()` will compute marginal contrasts for each #' variable or combination of variables, before stacking the results in a unique #' tibble. This is why `tidy_marginal_contrasts()` has a `variables_list` #' argument consisting of a list of specifications that will be passed #' sequentially to the `variables` and the `by` argument of #' `marginaleffects::avg_comparisons()`. #' #' Considering a single categorical variable named `cat`, `tidy_marginal_contrasts()` #' will call `avg_comparisons(model, variables = list(cat = "reference"))` #' to obtain average marginal contrasts for this variable. #' #' Considering a single continuous variable named `cont`, `tidy_marginalcontrasts()` #' will call `avg_comparisons(model, variables = list(cont = 1))` #' to obtain average marginal contrasts for an increase of one unit. #' #' For a combination of variables, there are several possibilities. You could #' compute "cross-contrasts" by providing simultaneously several variables #' to `variables` and specifying `cross = TRUE` to #' `marginaleffects::avg_comparisons()`. Alternatively, you could compute the #' contrasts of a first variable specified to `variables` for the #' different values of a second variable specified to `by`. #' #' The helper function `variables_to_contrast()` could be used to automatically #' generate a suitable list to be used with `variables_list`. Each combination #' of variables should be a list with two named elements: `"variables"` a list #' of named elements passed to `variables` and `"by"` a list of named elements #' used for creating a relevant `datagrid` and whose names are passed to `by`. #' #' `variables_list`'s default value, `"auto"`, calls #' `variables_to_contrast(interactions = TRUE, cross = FALSE)` while #' `"no_interaction"` is a shortcut for #' `variables_to_contrast(interactions = FALSE)`. `"cross"` calls #' `variables_to_contrast(interactions = TRUE, cross = TRUE)` #' #' You can also provide custom specifications (see examples). #' #' By default, *average marginal contrasts* are computed: contrasts are computed #' using a counterfactual grid for each value of the variable of interest, #' before averaging the results. *Marginal contrasts at the mean* could be #' obtained by indicating `newdata = "mean"`. Other assumptions are possible, #' see the help file of `marginaleffects::avg_comparisons()`. #' #' For more information, see `vignette("marginal_tidiers", "broom.helpers")`. #' @param x a model #' @param variables_list a list whose elements will be sequentially passed to #' `variables` in `marginaleffects::avg_comparisons()` (see details below); #' alternatively, it could also be the string `"auto"` (default), `"cross"` or #' `"no_interaction"` #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to #' `marginaleffects::avg_comparisons()` #' @family marginal_tieders #' @seealso `marginaleffects::avg_comparisons()`, `tidy_avg_comparisons()` #' @export #' @examplesIf interactive() #' # Average Marginal Contrasts #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' tidyr::uncount(n) %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' mod <- glm( #' Survived ~ Class + Age + Sex, #' data = df, family = binomial #' ) #' tidy_marginal_contrasts(mod) #' tidy_plus_plus(mod, tidy_fun = tidy_marginal_contrasts) #' #' mod2 <- lm(Petal.Length ~ poly(Petal.Width, 2) + Species, data = iris) #' tidy_marginal_contrasts(mod2) #' tidy_marginal_contrasts( #' mod2, #' variables_list = variables_to_predict( #' mod2, #' continuous = 3, #' categorical = "pairwise" #' ) #' ) #' #' # Model with interactions #' mod3 <- glm( #' Survived ~ Sex * Age + Class, #' data = df, family = binomial #' ) #' tidy_marginal_contrasts(mod3) #' tidy_marginal_contrasts(mod3, "no_interaction") #' tidy_marginal_contrasts(mod3, "cross") #' tidy_marginal_contrasts( #' mod3, #' variables_list = list( #' list(variables = list(Class = "pairwise"), by = list(Sex = unique)), #' list(variables = list(Age = "all")), #' list(variables = list(Class = "sequential", Sex = "reference")) #' ) #' ) #' #' mod4 <- lm(Sepal.Length ~ Petal.Length * Petal.Width + Species, data = iris) #' tidy_marginal_contrasts(mod4) #' tidy_marginal_contrasts( #' mod4, #' variables_list = list( #' list( #' variables = list(Species = "sequential"), #' by = list(Petal.Length = c(2, 5)) #' ), #' list( #' variables = list(Petal.Length = 2), #' by = list(Species = unique, Petal.Width = 2:4) #' ) #' ) #' ) #' #' # Marginal Contrasts at the Mean #' tidy_marginal_contrasts(mod, newdata = "mean") #' tidy_marginal_contrasts(mod3, newdata = "mean") tidy_marginal_contrasts <- function(x, variables_list = "auto", conf.int = TRUE, conf.level = 0.95, ...) { .assert_package("marginaleffects") dots <- rlang::dots_list(...) if (isTRUE(dots$exponentiate)) { cli::cli_abort("{.arg exponentiate = TRUE} is not relevant for {.fun broom.helpers::tidy_marginal_contrasts}.") # nolint } dots$exponentiate <- NULL dots$conf_level <- conf.level dots$model <- x if (is.character(variables_list) && variables_list == "auto") { variables_list <- variables_to_contrast( x, interactions = TRUE, cross = FALSE ) } if (is.character(variables_list) && variables_list == "no_interaction") { variables_list <- variables_to_contrast( x, interactions = FALSE ) } if (is.character(variables_list) && variables_list == "cross") { variables_list <- variables_to_contrast( x, interactions = TRUE, cross = TRUE ) } if (!is.list(variables_list)) { cli::cli_abort("{.arg variables_list} should be a list or \"auto\" or \"no_interaction\".") } res <- purrr::map_df(variables_list, .tidy_one_marginal_contrast, dots) attr(res, "coefficients_type") <- dplyr::case_when( is.null(dots$newdata) ~ "marginal_contrasts_average", isTRUE(dots$newdata == "mean") ~ "marginal_contrasts_at_mean", isTRUE(dots$newdata == "marginalmeans") ~ "marginal_contrasts_at_marginalmeans", TRUE ~ "marginal_contrasts" ) attr(res, "skip_add_reference_rows") <- TRUE res } .tidy_one_marginal_contrast <- function(variables, dots) { # allowing passing directly variables names if (length(variables) > 0 && !all(names(variables) %in% c("variables", "by"))) { variables <- list(variables = variables) } dots$variables <- variables$variables dots$cross <- TRUE if (!is.null(variables$by)) { dots$by <- names(variables$by) } if (!is.null(variables$by) && is.null(dots$newdata)) { args <- variables$by args$model <- dots$model dots$newdata <- do.call(marginaleffects::datagridcf, args) } if (!is.null(variables$by) && identical(dots$newdata, "mean")) { args <- variables$by args$model <- dots$model dots$newdata <- do.call(marginaleffects::datagrid, args) } res <- do.call(marginaleffects::avg_comparisons, dots) %>% dplyr::select(-dplyr::any_of("term")) if (is.null(variables$by)) { res <- res %>% dplyr::mutate( variable = paste(names(variables$variables), collapse = ":") ) } else { res <- res %>% dplyr::mutate( variable = paste( paste(names(variables$by), collapse = ":"), paste(names(variables$variables), collapse = ":"), sep = ":" ) ) } res <- res %>% tidyr::unite( col = "term", sep = " * ", dplyr::all_of(names(variables$by)), dplyr::starts_with("contrast") ) %>% dplyr::relocate("variable", "term") if ("group" %in% names(res)) { res <- res %>% dplyr::rename(y.level = "group") %>% dplyr::relocate("y.level") } res } #' @export #' @param model a model #' @param interactions should combinations of variables corresponding to #' interactions be returned? #' @param cross if `interaction` is `TRUE`, should "cross-contrasts" be #' computed? (if `FALSE`, only the last term of an interaction is passed to #' `variable` and the other terms are passed to `by`) #' @param var_categorical default `variable` value for categorical variables #' @param var_continuous default `variable` value for continuous variables #' @param by_categorical default `by` value for categorical variables #' @param by_continuous default `by` value for continuous variables #' @rdname tidy_marginal_contrasts variables_to_contrast <- function(model, interactions = TRUE, cross = FALSE, var_categorical = "reference", var_continuous = 1, by_categorical = unique, by_continuous = stats::fivenum) { variables <- model %>% model_list_variables(add_var_type = TRUE) if (interactions) { keep <- model_list_higher_order_variables(model) } else { keep <- variables[variables$var_type != "interaction", ]$variable } response_variable <- model %>% model_get_response_variable() if (!is.null(response_variable)) { keep <- keep[keep != response_variable] } var_ret <- list( categorical = var_categorical, dichotomous = var_categorical, continuous = var_continuous ) by_ret <- list( categorical = by_categorical, dichotomous = by_categorical, continuous = by_continuous ) variables <- variables %>% tibble::column_to_rownames("variable") one_element <- function(v) { v <- strsplit(v, ":") %>% unlist() if (length(v) == 1 || isTRUE(cross)) { one_variables <- variables[v, "var_type"] one_variables <- var_ret[one_variables] names(one_variables) <- v one_by <- NULL } else { one_variables <- variables[utils::tail(v, 1), "var_type"] one_variables <- var_ret[one_variables] names(one_variables) <- utils::tail(v, 1) one_by <- variables[utils::head(v, -1), "var_type"] one_by <- by_ret[one_by] names(one_by) <- utils::head(v, -1) } list(variables = one_variables, by = one_by) } lapply(keep, one_element) } broom.helpers/R/reexport.R0000644000176200001440000000133014357760764015245 0ustar liggesusers#' @importFrom dplyr `%>%` #' @export dplyr::`%>%` #' @importFrom dplyr vars #' @export dplyr::vars #' @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 broom.helpers/R/custom_tidiers.R0000644000176200001440000002701114464175037016426 0ustar liggesusers#' Tidy a model with parameters package #' #' Use [parameters::model_parameters()] to tidy a model and apply #' `parameters::standardize_names(style = "broom")` to the output #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to [parameters::model_parameters()] #' @note #' For [betareg::betareg()], the component column in the results is standardized #' with [broom::tidy()], using `"mean"` and `"precision"` values. #' @examplesIf interactive() #' if (.assert_package("parameters", boolean = TRUE)) { #' lm(Sepal.Length ~ Sepal.Width + Species, data = iris) %>% #' tidy_parameters() #' } #' @export #' @family custom_tieders tidy_parameters <- function(x, conf.int = TRUE, conf.level = .95, ...) { .assert_package("parameters", fn = "broom.helpers::tidy_parameters()") args <- list(...) if (!conf.int) conf.level <- NULL args$ci <- conf.level args$model <- x if ( inherits(x, "betareg") && !is.null(args$component) && args$component == "mean" ) { args$component <- "conditional" } res <- do.call(parameters::model_parameters, args) %>% parameters::standardize_names(style = "broom") if (inherits(x, "multinom")) { if ("response" %in% colnames(res)) { res <- res %>% dplyr::rename(y.level = "response") } else { # binary res$y.level <- x$lev %>% utils::tail(n = 1) } } if (!is.null(args$component)) { attr(res, "component") <- args$component } # for betareg, need to standardize component with tidy::broom() if (inherits(x, "betareg")) { if (is.null(args$component) || args$component == "conditional") { res$component <- "mean" } if (!is.null(args$component) && args$component == "precision") { res$component <- "precision" } if (!is.null(args$component) && args$component == "all") { res$component[res$component == "conditional"] <- "mean" } } res } #' Tidy a model with broom or parameters #' #' Try to tidy a model with `broom::tidy()`. If it fails, will try to tidy the #' model using `parameters::model_parameters()` through `tidy_parameters()`. #' @param x a model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to `broom::tidy()` or #' `parameters::model_parameters()` #' @export #' @family custom_tieders tidy_with_broom_or_parameters <- function(x, conf.int = TRUE, conf.level = .95, ...) { # load broom.mixed if available if (any(c("glmerMod", "lmerMod", "glmmTMB", "glmmadmb", "stanreg", "brmsfit") %in% class(x))) { .assert_package("broom.mixed", fn = "broom.helpers::tidy_with_broom_or_parameters()") } if (inherits(x, "LORgee")) { cli::cli_alert_info("{.pkg multgee} model detected.") cli::cli_alert_success("{.fn tidy_multgee} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_multgee} to quiet these messages." ) return(tidy_multgee(x, conf.int = conf.int, conf.level = conf.level, ...)) } if (inherits(x, "zeroinfl")) { cli::cli_alert_info("{.cls zeroinfl} model detected.") cli::cli_alert_success("{.fn tidy_zeroinfl} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_zeroinfl} to quiet these messages." ) return(tidy_zeroinfl(x, conf.int = conf.int, conf.level = conf.level, ...)) } if (inherits(x, "hurdle")) { cli::cli_alert_info("{.cls hurdle} model detected.") cli::cli_alert_success("{.fn tidy_zeroinfl} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_zeroinfl} to quiet these messages." ) return(tidy_zeroinfl(x, conf.int = conf.int, conf.level = conf.level, ...)) } tidy_args <- list(...) tidy_args$x <- x tidy_args$conf.int <- conf.int if (conf.int) tidy_args$conf.level <- conf.level # class of models known for tidy() not supporting exponentiate argument # and for ignoring it if (any(c("fixest", "plm", "felm", "lavaan", "nls", "survreg") %in% class(x))) { if (isFALSE(tidy_args$exponentiate)) { tidy_args$exponentiate <- NULL } else { cli::cli_abort("'exponentiate = TRUE' is not valid for this type of model.") } } # for betareg, if exponentiate = TRUE, forcing tidy_parameters, # by adding `component = "all" to the arguments` if (inherits(x, "betareg")) { if (isFALSE(tidy_args$exponentiate)) { tidy_args$exponentiate <- NULL } else if (isTRUE(tidy_args$exponentiate)) { component <- tidy_args$component cli::cli_alert_info( "{.code exponentiate = TRUE} not valid for {.cl betareg} with {.fn broom::tidy()}." ) if (is.null(component)) { cli::cli_alert_success("{.code tidy_parameters(component = \"all\")} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_parameters} to quiet these messages." ) return( tidy_parameters( x, conf.int = conf.int, conf.level = conf.level, component = "all", ... ) ) } else { cli::cli_alert_success("{.code tidy_parameters()} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_parameters} to quiet these messages." ) return( tidy_parameters( x, conf.int = conf.int, conf.level = conf.level, ... ) ) } } } res <- tryCatch( do.call(tidy_broom, tidy_args), error = function(e) { NULL } ) # trying without exponentiate if (is.null(res)) { tidy_args2 <- tidy_args tidy_args2$exponentiate <- NULL res <- tryCatch( do.call(tidy_broom, tidy_args2), error = function(e) { NULL } ) if (!is.null(res) && !is.null(tidy_args$exponentiate) && tidy_args$exponentiate) { # changing to FALSE is managed by tidy_and_attach() cli::cli_abort("'exponentiate = TRUE' is not valid for this type of model.") } } if (is.null(res)) { cli::cli_alert_warning("{.code broom::tidy()} failed to tidy the model.") res <- tryCatch( do.call(tidy_parameters, tidy_args), error = function(e) { cli::cli_alert_warning("{.code tidy_parameters()} also failed.") cli::cli_alert_danger(e) NULL } ) if (is.null(res)) { cli::cli_abort("Unable to tidy {.arg x}.") } else { # success of parameters cli::cli_alert_success("{.code tidy_parameters()} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_parameters} to quiet these messages." ) } } res } #' Tidy with `broom::tidy()` and checks that all arguments are used #' #' @param x a model to tidy #' @param ... additional parameters passed to `broom::tidy()` #' @family custom_tieders #' @export tidy_broom <- function(x, ...) { rlang::check_dots_used() broom::tidy(x, ...) } #' Tidy a `multgee` model #' #' `r lifecycle::badge("experimental")` #' A tidier for models generated with `multgee::nomLORgee()` or `multgee::ordLORgee()`. #' Term names will be updated to be consistent with generic models. The original #' term names are preserved in an `"original_term"` column. #' @param x a `multgee::nomLORgee()` or a `multgee::ordLORgee()` model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param ... additional parameters passed to `parameters::model_parameters()` #' @export #' @family custom_tieders #' @examplesIf interactive() #' if (.assert_package("multgee", boolean = TRUE)) { #' library(multgee) #' #' mod <- multgee::nomLORgee( #' y ~ factor(time) * sec, #' data = multgee::housing, #' id = id, #' repeated = time, #' ) #' mod %>% tidy_multgee() #' #' mod2 <- ordLORgee( #' formula = y ~ factor(time) + factor(trt) + factor(baseline), #' data = multgee::arthritis, #' id = id, #' repeated = time, #' LORstr = "uniform" #' ) #' mod2 %>% tidy_multgee() #' } tidy_multgee <- function(x, conf.int = TRUE, conf.level = .95, ...) { if (!inherits(x, "LORgee")) { cli::cli_abort(paste( "Only {.fn multgee::nomLORgee} and {.fn multgee::ordLORgee} models", "are supported." )) } res <- tidy_parameters(x, conf.int = conf.int, conf.level = conf.level, ...) res$original_term <- res$term # multinomial model if (stringr::str_detect(x$title, "NOMINAL")) { mf <- x %>% model_get_model_frame() if (!is.factor(mf[[1]])) { mf[[1]] <- factor(mf[[1]]) } y.levels <- levels(mf[[1]])[-1] mm <- x %>% model_get_model_matrix() t <- colnames(mm) res$term <- rep.int(t, times = length(y.levels)) res$y.level <- rep(y.levels, each = length(t)) return(res) } else { mm <- x %>% model_get_model_matrix() t <- colnames(mm) t <- t[t != "(Intercept)"] b <- res$term[stringr::str_starts(res$term, "beta")] res$term <- c(b, t) return(res) } } #' Tidy a `zeroinfl` or a `hurdle` model #' #' `r lifecycle::badge("experimental")` #' A tidier for models generated with `pscl::zeroinfl()` or `pscl::hurdle()`. #' Term names will be updated to be consistent with generic models. The original #' term names are preserved in an `"original_term"` column. #' @param x a `pscl::zeroinfl()` or a `pscl::hurdle()` model #' @param conf.int logical indicating whether or not to include a confidence #' interval in the tidied output #' @param conf.level the confidence level to use for the confidence interval #' @param component `NULL` or one of `"all"`, `"conditional"`, `"zi"`, or #' `"zero_inflated"` #' @param ... additional parameters passed to `parameters::model_parameters()` #' @export #' @family custom_tieders #' @examplesIf interactive() #' if (.assert_package("pscl", boolean = TRUE)) { #' library(pscl) #' mod <- zeroinfl( #' art ~ fem + mar + phd, #' data = pscl::bioChemists #' ) #' #' mod %>% tidy_zeroinfl(exponentiate = TRUE) #' } tidy_zeroinfl <- function( x, conf.int = TRUE, conf.level = .95, component = NULL, ...) { if (!inherits(x, "zeroinfl") && !inherits(x, "hurdle")) { cli::cli_abort("{.arg x} should be of class {.cls zeroinfl} or {.cls hurdle}") } # nolint res <- tidy_parameters( x, conf.int = conf.int, conf.level = conf.level, component = component, ... ) res$original_term <- res$term starts_zero <- stringr::str_starts(res$term, "zero_") res$term[starts_zero] <- stringr::str_sub(res$term[starts_zero], 6) starts_count <- stringr::str_starts(res$term, "count_") res$term[starts_count] <- stringr::str_sub(res$term[starts_count], 7) if (!is.null(component) && component %in% c("conditional", "zero_inflated")) { res$component <- component } if (!is.null(component) && component == "zi") { res$component <- "zero_inflated" } attr(res, "component") <- component res } broom.helpers/R/select_utilities.R0000644000176200001440000003712514457460717016756 0ustar liggesusers#' Convert formula selector to a named list #' #' Functions takes a list of formulas, a named list, or a combination of named #' elements with formula elements and returns a named list. #' For example, `list(age = 1, starts_with("stage") ~ 2)`. #' #' @section Shortcuts: #' A shortcut for specifying an option be applied to all columns/variables #' is omitting the LHS of the formula. #' For example, `list(~ 1)` is equivalent to passing `list(everything() ~ 1)`. #' #' Additionally, a single formula may be passed instead of placing a single #' formula in a list; e.g. `everything() ~ 1` is equivalent to #' passing `list(everything() ~ 1)` #' #' @param x list of selecting formulas #' @param type_check A predicate function that checks the elements passed on #' the RHS of the formulas in `x=` (or the element in a named list) #' satisfy the function. #' @param type_check_msg When the `type_check=` fails, the string provided #' here will be printed as the error message. When `NULL`, a generic #' error message will be printed. #' @param null_allowed Are `NULL` values accepted for the right hand side of #' formulas? #' @inheritParams .select_to_varnames #' #' @export .formula_list_to_named_list <- function(x, data = NULL, var_info = NULL, arg_name = NULL, select_single = FALSE, type_check = NULL, type_check_msg = NULL, null_allowed = TRUE) { # if NULL provided, return NULL ---------------------------------------------- if (is.null(x)) { return(NULL) } # converting to list if single element passed -------------------------------- if (inherits(x, "formula")) { x <- list(x) } # checking the input is valid ------------------------------------------------ .check_valid_input(x = x, arg_name = arg_name, type_check = type_check) # convert to a named list ---------------------------------------------------- len_x <- length(x) named_list <- vector(mode = "list", length = len_x) for (i in seq_len(len_x)) { if (rlang::is_named(x[i])) { named_list[i] <- list(x[i]) } else if (rlang::is_formula(x[[i]])) { named_list[i] <- .single_formula_to_list(x[[i]], data = data, var_info = var_info, arg_name = arg_name, select_single = select_single, type_check = type_check, type_check_msg = type_check_msg, null_allowed = null_allowed ) %>% list() } else { .formula_select_error(arg_name = arg_name) } .rhs_checks( x = named_list[i][[1]], arg_name = arg_name, type_check = type_check, type_check_msg = type_check_msg, null_allowed = null_allowed ) } named_list <- purrr::flatten(named_list) # removing duplicates (using the last one listed if variable occurs more than once) tokeep <- names(named_list) %>% rev() %>% { !duplicated(.) } %>% rev() # nolint result <- named_list[tokeep] if (isTRUE(select_single) && length(result) > 1) { .select_single_error_msg(names(result), arg_name = arg_name) } result } .select_single_error_msg <- function(selected, arg_name) { if (!rlang::is_empty(arg_name)) { stringr::str_glue( "Error in `{arg_name}=` argument--select only a single column. ", "The following columns were selected, ", "{paste(sQuote(selected), collapse = ', ')}" ) %>% cli::cli_abort(call = NULL) } stringr::str_glue( "Error in selector--select only a single column. ", "The following columns were selected, ", "{paste(sQuote(selected), collapse = ', ')}" ) %>% cli::cli_abort(call = NULL) } .check_valid_input <- function(x, arg_name, type_check) { if ( !rlang::is_list(x) && !(rlang::is_vector(x) && rlang::is_named(x)) ) { err_msg <- stringr::str_glue( "Error processing the `{arg_name %||% ''}` argument. ", "Expecting a list or formula.\n", "Review syntax details at", "'https://www.danieldsjoberg.com/gtsummary/reference/syntax.html'" ) if (tryCatch(do.call(type_check, list(x)), error = function(e) FALSE)) { x_string <- suppressWarnings(tryCatch( switch(rlang::is_string(x), x ) %||% as.character(deparse(x)), error = function(e) NULL )) if (!is.null(x_string) && length(x_string) == 1 && nchar(x_string) <= 50) { err_msg <- paste( err_msg, stringr::str_glue("Did you mean `everything() ~ {x_string}`?"), sep = "\n\n" ) } } cli::cli_abort(err_msg, call = NULL) } return(invisible()) } # checking the type/class/NULL of the RHS of formula .rhs_checks <- function(x, arg_name, type_check, type_check_msg, null_allowed) { purrr::imap( x, function(rhs, lhs) { if (!null_allowed && is.null(rhs)) { stringr::str_glue( "Error processing `{arg_name %||% ''}` argument for element '{lhs[[1]]}'. ", "A NULL value is not allowed." ) %>% cli::cli_abort(call = NULL) } # check the type of RHS ------------------------------------------------------ if (!is.null(type_check) && !is.null(rhs) && !type_check(rhs)) { stringr::str_glue( "Error processing `{arg_name %||% ''}` argument for element '{lhs[[1]]}'. ", type_check_msg %||% "The value passed is not the expected type/class." ) %>% cli::cli_abort(call = NULL) } } ) return(invisible()) } .single_formula_to_list <- function(x, data, var_info, arg_name, select_single, type_check, type_check_msg, null_allowed) { # for each formula extract lhs and rhs --------------------------------------- # checking the LHS is not empty f_lhs_quo <- .f_side_as_quo(x, "lhs") if (rlang::quo_is_null(f_lhs_quo)) f_lhs_quo <- rlang::expr(everything()) # extract LHS of formula lhs <- .select_to_varnames( select = !!f_lhs_quo, data = data, var_info = var_info, arg_name = arg_name, select_single = select_single ) # evaluate RHS of formula in the original formula environment rhs <- .f_side_as_quo(x, "rhs") %>% rlang::eval_tidy() # checking if RHS is NULL ---------------------------------------------------- # converting rhs and lhs into a named list purrr::map( lhs, ~ list(rhs) %>% rlang::set_names(.x) ) %>% purrr::flatten() } #' Variable selector #' #' Function takes `select()`-like inputs and converts the selector to #' a character vector of variable names. Functions accepts tidyselect syntax, #' and additional selector functions defined within the package #' #' @param select A single object selecting variables, e.g. `c(age, stage)`, #' `starts_with("age")` #' @param data A data frame to select columns from. Default is NULL #' @param var_info A data frame of variable names and attributes. May also pass #' a character vector of variable names. Default is NULL #' @param arg_name Optional string indicating the source argument name. This #' helps in the error messaging. Default is NULL. #' @param select_single Logical indicating whether the result must be a single #' variable. Default is `FALSE` #' #' @return A character vector of variable names #' @export .select_to_varnames <- function(select, data = NULL, var_info = NULL, arg_name = NULL, select_single = FALSE) { if (is.null(data) && is.null(var_info)) { cli::cli_abort("At least one of {.arg data} or {.arg var_info} must be specified.") } select <- rlang::enquo(select) # if NULL passed, return NULL if (rlang::quo_is_null(select)) { return(NULL) } # convert var_info to data frame if data not provided ------------------------ if (is.null(data)) data <- .var_info_to_df(var_info) if (!is.null(var_info)) { # scoping the variable types .scope_var_info(var_info) # un-scoping on exit on.exit(rm(list = ls(envir = env_variable_type), envir = env_variable_type)) } # determine if selecting input begins with `var()` select_input_starts_var <- !rlang::quo_is_symbol(select) && # if not a symbol (ie name) tryCatch( identical( eval(as.list(rlang::quo_get_expr(select)) %>% purrr::pluck(1)), dplyr::vars ), error = function(e) FALSE ) # performing selecting res <- tryCatch( { if (select_input_starts_var) { # `vars()` was deprecated on June 6, 2022, gtsummary will stop # exporting `vars()` at some point as well. paste( "Use of {.code vars()} is now {.strong deprecated} and support will soon be removed.", "Please replace calls to {.code vars()} with {.code c()}." ) %>% cli::cli_alert_warning() # `vars()` evaluates to a list of quosures; unquoting them in `select()` names(dplyr::select(data, !!!rlang::eval_tidy(select))) } else { names(dplyr::select(data, !!select)) } }, error = function(e) { if (!is.null(arg_name)) { error_msg <- stringr::str_glue( "Error in `{arg_name}=` argument input. Select from ", "{paste(sQuote(names(data)), collapse = ', ')}" ) } else { error_msg <- as.character(e) } # nocov cli::cli_abort(error_msg, call = NULL) } ) # assuring only a single column is selected if (select_single == TRUE && length(res) > 1) { .select_single_error_msg(res, arg_name = arg_name) } # if nothing is selected, return a NULL if (length(res) == 0) { return(NULL) } res } #' Generate a custom selector function #' #' @param variable_column string indicating column variable names are stored #' @param select_column character vector of columns used in the `select_expr=` argument #' @param select_expr unquoted predicate command to subset a data frame to select variables #' @param fun_name quoted name of function where `.generic_selector()` is being used. #' This helps with error messaging. #' #' @details #' `.is_selector_scoped()` checks if a selector has been properly registered #' in `env_variable_type$df_var_info`. #' #' @return custom selector functions #' @export .generic_selector <- function(variable_column, select_column, select_expr, fun_name) { # ensuring the proper data has been scoped to use this function if (!.is_selector_scoped(variable_column, select_column)) { cli_alert_danger("Cannot use selector '{fun_name}()' in this context.") cli::cli_abort("Invalid syntax", call = NULL) } # selecting the variable from the variable information data frame env_variable_type$df_var_info %>% dplyr::select(all_of(c(variable_column, select_column))) %>% dplyr::filter(stats::complete.cases(.)) %>% dplyr::filter({{ select_expr }}) %>% dplyr::pull(dplyr::all_of(variable_column)) %>% unique() } #' @rdname dot-generic_selector #' @export .is_selector_scoped <- function(variable_column, select_column) { exists("df_var_info", envir = env_variable_type) && all(c(variable_column, select_column) %in% names(env_variable_type$df_var_info)) } # scoping the variable characteristics .scope_var_info <- function(x) { # removing everything from selecting environment rm(list = ls(envir = env_variable_type), envir = env_variable_type) if (!inherits(x, "data.frame")) { return(invisible(NULL)) } # saving var_info to selecting environment, where it may be utilized by selecting fns env_variable_type$df_var_info <- x return(invisible(NULL)) } # function that converts a meta_data tibble to a tibble of variable names (to be used in selecting) .var_info_to_df <- function(x) { # converting variable name and class into data frame so users can use `where(predicate)`-types if (inherits(x, "data.frame") && all(c("variable", "var_class") %in% names(x))) { # keep unique var names x <- dplyr::select(x, all_of(c("variable", "var_class"))) %>% dplyr::distinct() %>% dplyr::filter(!is.na(.data$variable)) df <- purrr::map2_dfc( x$variable, x$var_class, function(var, class) { switch(class, "numeric" = data.frame(pi), "character" = data.frame(letters[1]), "factor" = data.frame(datasets::iris$Species[1]), "ordered" = data.frame(factor(datasets::iris$Species[1], ordered = TRUE)), "integer" = data.frame(1L), "Date" = data.frame(Sys.Date()), "POSIXlt" = data.frame(as.POSIXlt(Sys.Date())), "POSIXct" = data.frame(as.POSIXct(Sys.Date())), "difftime" = data.frame(Sys.Date() - Sys.Date()) ) %||% data.frame(NA) %>% purrr::set_names(var) } ) } else if (inherits(x, "data.frame") && "variable" %in% names(x)) { # if a data.frame df <- purrr::map_dfc(unique(x$variable), ~ data.frame(NA) %>% purrr::set_names(.x)) } else if (rlang::is_vector(x) && !is.list(x)) { # if only a vector of names were passed, converting them to a data frame df <- purrr::map_dfc(unique(x), ~ data.frame(NA) %>% purrr::set_names(.x)) } # return data frame with variables as column names df } # extract LHS/RHS of formula as quosure. attached env will be the formula env .f_side_as_quo <- function(x, side = c("lhs", "rhs")) { side <- match.arg(side) f_expr <- switch(side, "lhs" = rlang::f_lhs(x), "rhs" = rlang::f_rhs(x) ) f_quo <- rlang::quo(!!f_expr) attr(f_quo, ".Environment") <- rlang::f_env(x) f_quo } # there are a couple of places the users input may result in an error. # this function prints an informative error msg with correct syntax example .formula_select_error <- function(arg_name) { example_text <- formula_select_examples[[arg_name %||% "not_an_arg"]] %||% paste(c( "label = list(age ~ \"Age, years\")", "statistic = list(all_continuous() ~ \"{mean} ({sd})\")", "type = list(c(response, death) ~ \"categorical\")" )) # printing error for argument input if (!is.null(arg_name)) { cli_alert_danger( "There was a problem with the {.code {arg_name}=} argument input." ) } else { cli_alert_danger("There was a problem with one of the function argument inputs.") } cli_alert_info("Below is an example of correct syntax.") cli_code(example_text) cli::cli_abort("Invalid argument syntax", call = NULL) } formula_select_examples <- list( labels = "labels = list(age ~ \"Age, years\", response ~ \"Tumor Response\")", label = "label = list(age ~ \"Age, years\", response ~ \"Tumor Response\")", type = "type = list(age ~ \"continuous\", where(is.integer) ~ \"categorical\")", statistic = c( paste( "statistic = list(all_continuous() ~ \"{mean} ({sd})\",", "all_categorical() ~ \"{n} / {N} ({p}%)\")" ), "statistic = list(age ~ \"{median}\")" ), digits = c("digits = list(age ~ 2)", "digits = list(all_continuous() ~ 2)"), value = c("value = list(grade ~ \"III\")", "value = list(all_logical() ~ FALSE)"), test = c("test = list(all_continuous() ~ \"t.test\")", "test = list(age ~ \"kruskal.test\")") ) # set new environment for new tidyselect funs env_variable_type <- rlang::new_environment() broom.helpers/R/data.R0000644000176200001440000000045214357760763014311 0ustar liggesusers#' Listing of Supported Models #' #' @format A data frame with one row per supported model #' \describe{ #' \item{model}{Model} #' \item{notes}{Notes} #' } #' #' @section Supported models: #' #' ```{r, echo = FALSE} #' knitr::kable(supported_models) #' ``` "supported_models" broom.helpers/R/tidy_add_coefficients_type.R0000644000176200001440000001032014457457127020734 0ustar liggesusers#' Add coefficients type and label as attributes #' #' Add the type of coefficients ("generic", "logistic", "poisson", #' "relative_risk" or "prop_hazard") and the corresponding coefficient labels, #' as attributes to `x` (respectively #' named `coefficients_type` and `coefficients_label`). #' #' @param x a tidy tibble #' @param exponentiate logical indicating whether or not to exponentiate the #' coefficient estimates. It should be consistent with the original call to #' [broom::tidy()] #' @param model the corresponding model, if not attached to `x` #' @export #' @family tidy_helpers #' @examples #' ex1 <- lm(hp ~ mpg + factor(cyl), mtcars) %>% #' tidy_and_attach() %>% #' tidy_add_coefficients_type() #' attr(ex1, "coefficients_type") #' attr(ex1, "coefficients_label") #' #' ex2 <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) %>% #' tidy_and_attach(exponentiate = TRUE) %>% #' tidy_add_coefficients_type() #' attr(ex2, "coefficients_type") #' attr(ex2, "coefficients_label") tidy_add_coefficients_type <- function( x, exponentiate = attr(x, "exponentiate"), model = tidy_get_model(x)) { if (is.null(exponentiate) || !is.logical(exponentiate)) { cli::cli_abort("'exponentiate' is not provided. You need to pass it explicitely.") } if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) .attributes$exponentiate <- exponentiate # specific case for marginal effects / means / contrasts / prediction # where coefficients_type is already define by the tidier if (isTRUE(stringr::str_starts(.attributes$coefficients_type, "marginal"))) { coefficients_type <- .attributes$coefficients_type coefficients_label <- dplyr::case_when( coefficients_type == "marginal_effects_average" ~ "Average Marginal Effects", coefficients_type == "marginal_effects_at_mean" ~ "Marginal Effects at the Mean", coefficients_type == "marginal_effects_at_marginalmeans" ~ "Marginal Effects at Marginal Means", stringr::str_starts(coefficients_type, "marginal_effects") ~ "Marginal Effects", coefficients_type == "marginal_contrasts_average" ~ "Average Marginal Contrasts", coefficients_type == "marginal_contrasts_at_mean" ~ "Marginal Contrasts at the Mean", coefficients_type == "marginal_contrasts_at_marginalmeans" ~ "Marginal Contrasts at Marginal Means", stringr::str_starts(coefficients_type, "marginal_contrasts") ~ "Marginal Contrasts", stringr::str_starts(coefficients_type, "marginal_means") ~ "Marginal Means", coefficients_type == "marginal_predictions_average" ~ "Average Marginal Predictions", coefficients_type == "marginal_predictions_at_mean" ~ "Marginal Predictions at the Mean", coefficients_type == "marginal_predictions_at_marginalmeans" ~ "Marginal Predictions at Marginal Means", stringr::str_starts(coefficients_type, "marginal_predictions") ~ "Marginal Predictions", TRUE ~ "Marginal values" ) } else { coefficients_type <- model_get_coefficients_type(model) if (exponentiate) { coefficients_label <- dplyr::case_when( coefficients_type == "logistic" ~ "OR", coefficients_type == "poisson" ~ "IRR", coefficients_type == "relative_risk" ~ "RR", coefficients_type == "prop_hazard" ~ "HR", TRUE ~ "exp(Beta)" ) } else { coefficients_label <- dplyr::case_when( coefficients_type == "logistic" ~ "log(OR)", coefficients_type == "poisson" ~ "log(IRR)", coefficients_type == "relative_risk" ~ "log(RR)", coefficients_type == "prop_hazard" ~ "log(HR)", TRUE ~ "Beta" ) } } attr(x, "coefficients_type") <- coefficients_type attr(x, "coefficients_label") <- coefficients_label x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_compute_terms_contributions.R0000644000176200001440000001115714457457106022427 0ustar liggesusers#' Compute a matrix of terms contributions #' #' @description #' #' Used for [model_get_n()]. For each row and term, equal 1 if this row should #' be taken into account in the estimate of the number of observations, #' 0 otherwise. #' #' @details #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model a model object #' @export #' @family model_helpers #' @examplesIf interactive() #' mod <- lm(Sepal.Length ~ Sepal.Width, iris) #' mod %>% model_compute_terms_contributions() #' #' mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) #' mod %>% model_compute_terms_contributions() #' #' mod <- glm( #' response ~ stage * grade + trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list( #' stage = contr.sum, #' grade = contr.treatment(3, 2), #' trt = "contr.SAS" #' ) #' ) #' mod %>% model_compute_terms_contributions() #' #' mod <- glm( #' response ~ stage * trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list(stage = contr.poly) #' ) #' mod %>% model_compute_terms_contributions() #' #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, family = binomial #' ) #' mod %>% model_compute_terms_contributions() #' #' d <- dplyr::as_tibble(Titanic) %>% #' dplyr::group_by(Class, Sex, Age) %>% #' dplyr::summarise( #' n_survived = sum(n * (Survived == "Yes")), #' n_dead = sum(n * (Survived == "No")) #' ) #' mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) #' mod %>% model_compute_terms_contributions() model_compute_terms_contributions <- function(model) { UseMethod("model_compute_terms_contributions") } #' @export #' @rdname model_compute_terms_contributions model_compute_terms_contributions.default <- function(model) { contr <- model %>% model_get_contrasts() # check poly contrasts # we change the contrasts arguments to force positive values if (!is.null(contr)) { list.contr.poly <- model %>% model_list_contrasts() %>% dplyr::filter(.data$contrasts == "contr.poly") %>% purrr::pluck("variable") for (v in list.contr.poly) { contr[[v]] <- contr.poly.abs } } tcm <- tryCatch( { formula <- model_get_terms(model) if (is.null(formula)) { return(NULL) } # stop # continuous variables converted to 1 to force positive values d <- model %>% purrr::pluck("data") if (is.null(d)) d <- model %>% model_get_model_frame() if (is.null(d)) { return(NULL) } # stop d <- d %>% dplyr::mutate( dplyr::across( where(~ is.numeric(.x) & ( # check is.matrix for cbind variables # but include polynomial terms !is.matrix(.x) | inherits(.x, "poly") )), ~ abs(.x) + 1 # force positive value ) ) stats::model.matrix(formula, data = d, contrasts.arg = contr) }, error = function(e) { NULL # nocov } ) if (is.null(tcm)) { return(NULL) # nocov } tcm <- .add_ref_terms_to_tcm(model, tcm) # keep only positive terms tcm <- tcm > 0 storage.mode(tcm) <- "integer" tcm } contr.poly.abs <- function(...) { stats::contr.poly(...) %>% abs() } .add_ref_terms_to_tcm <- function(model, tcm) { # adding reference terms # for treatment and sum contrasts tl <- model %>% model_list_terms_levels() for (v in unique(tl$variable)) { ct <- tl %>% dplyr::filter(.data$variable == v) %>% purrr::chuck("contrasts_type") %>% dplyr::first() ref_term <- tl %>% dplyr::filter(.data$variable == v & .data$reference) %>% purrr::chuck("term") nonref_terms <- tl %>% dplyr::filter(.data$variable == v & !.data$reference) %>% purrr::chuck("term") if (ct == "treatment" && all(nonref_terms %in% colnames(tcm))) { tcm <- cbind( tcm, matrix( as.integer( rowSums(tcm[, nonref_terms, drop = FALSE] == 0L) == length(nonref_terms) ), ncol = 1, dimnames = list(NULL, ref_term) ) ) } if (ct == "sum" && all(nonref_terms %in% colnames(tcm))) { tcm <- cbind( tcm, matrix( as.integer( rowSums(tcm[, nonref_terms, drop = FALSE] == -1L) == length(nonref_terms) ), ncol = 1, dimnames = list(NULL, ref_term) ) ) } } tcm } broom.helpers/R/model_get_xlevels.R0000644000176200001440000000367214464175037017101 0ustar liggesusers#' Get xlevels used in the model #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_xlevels() model_get_xlevels <- function(model) { UseMethod("model_get_xlevels") } #' @export #' @rdname model_get_xlevels model_get_xlevels.default <- function(model) { xlevels <- tryCatch( model %>% purrr::chuck("xlevels"), error = function(e) { NULL # nocov } ) if (is.null(xlevels)) { xlevels <- tryCatch( stats::.getXlevels( model %>% model_get_terms(), model %>% model_get_model_frame() ), error = function(e) { NULL # nocov } ) } xlevels %>% .add_xlevels_for_logical_variables(model) } .add_xlevels_for_logical_variables <- function(xlevels, model) { log_vars <- model %>% model_list_variables() %>% dplyr::filter(.data$var_class == "logical") %>% purrr::pluck("variable") for (v in setdiff(log_vars, names(xlevels))) { xlevels[[v]] <- c("FALSE", "TRUE") } xlevels } #' @export #' @rdname model_get_xlevels model_get_xlevels.lmerMod <- function(model) { stats::model.frame(model) %>% lapply(levels) %>% purrr::compact() %>% # keep only not null .add_xlevels_for_logical_variables(model) } #' @export #' @rdname model_get_xlevels model_get_xlevels.glmerMod <- model_get_xlevels.lmerMod #' @export #' @rdname model_get_xlevels model_get_xlevels.felm <- model_get_xlevels.lmerMod #' @export #' @rdname model_get_xlevels model_get_xlevels.brmsfit <- model_get_xlevels.lmerMod #' @export #' @rdname model_get_xlevels model_get_xlevels.glmmTMB <- model_get_xlevels.lmerMod #' @export #' @rdname model_get_xlevels model_get_xlevels.plm <- model_get_xlevels.lmerMod #' @export #' @rdname model_get_xlevels model_get_xlevels.model_fit <- function(model) { model_get_xlevels(model$fit) } broom.helpers/R/model_list_variables.R0000644000176200001440000001615514457457124017565 0ustar liggesusers#' List all the variables used in a model #' #' Including variables used only in an interaction. #' #' @param model a model object #' @param labels an optional named list or named vector of #' custom variable labels #' @param only_variable if `TRUE`, will return only "variable" #' column #' @param add_var_type if `TRUE`, add `var_nlevels` and `var_type` columns #' @return #' A tibble with three columns: #' * `variable`: the corresponding variable #' * `var_class`: class of the variable (cf. [stats::.MFclass()]) #' * `label_attr`: variable label defined in the original data frame #' with the label attribute (cf. [labelled::var_label()]) #' * `var_label`: a variable label (by priority, `labels` if defined, #' `label_attr` if available, otherwise `variable`) #' #' If `add_var_type = TRUE`: #' * `var_type`: `"continuous"`, `"dichotomous"` (categorical variable with 2 levels), #' `"categorical"` (categorical variable with 3 or more levels), `"intercept"` #' or `"interaction"` #' * `var_nlevels`: number of original levels for categorical variables #' #' @export #' @family model_helpers #' @examplesIf interactive() #' if (.assert_package("gtsummary", boolean = TRUE)) { #' Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' glm( #' Survived ~ Class + Age:Sex, #' data = ., weights = .$n, #' family = binomial #' ) %>% #' model_list_variables() #' #' iris %>% #' lm( #' Sepal.Length ~ poly(Sepal.Width, 2) + Species, #' data = ., #' contrasts = list(Species = contr.sum) #' ) %>% #' model_list_variables() #' #' glm( #' response ~ poly(age, 3) + stage + grade * trt, #' na.omit(gtsummary::trial), #' family = binomial, #' ) %>% #' model_list_variables() #' } model_list_variables <- function(model, labels = NULL, only_variable = FALSE, add_var_type = FALSE) { UseMethod("model_list_variables") } #' @rdname model_list_variables #' @export model_list_variables.default <- function(model, labels = NULL, only_variable = FALSE, add_var_type = FALSE) { model_frame <- model_get_model_frame(model) model_terms <- model_get_terms(model) if (!is.null(model_terms) && inherits(model_terms, "terms")) { variable_names <- attr(model_terms, "term.labels") dataClasses <- purrr::map(model_frame, .MFclass2) %>% unlist() if (is.null(dataClasses)) { dataClasses <- attr(model_terms, "dataClasses") } } else { dataClasses <- model_frame %>% lapply(.MFclass2) %>% unlist() variable_names <- names(dataClasses) } if (is.null(variable_names)) { return(NULL) } # update the list with all elements of dataClasses variable_names <- names(dataClasses) %>% c(variable_names) %>% .clean_backticks() %>% unique() res <- tibble::tibble( variable = variable_names ) %>% .add_var_class(dataClasses) %>% .add_label_attr(model) %>% # specific case of polynomial terms defined with poly() dplyr::mutate( variable = stringr::str_replace(.data$variable, "^poly\\((.*),(.*)\\)$", "\\1") ) %>% .compute_var_label(labels) if (only_variable) { return(res$variable) } if (add_var_type) { return(.add_var_type(res, model)) } res } #' @rdname model_list_variables #' @export model_list_variables.lavaan <- function(model, labels = NULL, only_variable = FALSE, add_var_type = FALSE) { res <- tibble::tibble( variable = .clean_backticks(unique(model@ParTable$lhs)) ) %>% dplyr::left_join( tibble::tibble( variable = .clean_backticks(model@Data@ov$name), var_class = model@Data@ov$type ), by = "variable" ) %>% dplyr::mutate( var_class = dplyr::if_else( .data$var_class == "ordered", "factor", .data$var_class ) ) %>% .add_label_attr(model) %>% .compute_var_label(labels) if (only_variable) { return(res$variable) } if (add_var_type) { return(.add_var_type(res, model)) } res } #' @rdname model_list_variables #' @export model_list_variables.logitr <- function(model, labels = NULL, only_variable = FALSE, add_var_type = FALSE) { res <- model_list_variables.default(model, labels, FALSE) if (!is.null(model$data$scalePar)) { label_scalePar <- labels %>% purrr::pluck("scalePar") res <- res %>% dplyr::add_row( variable = "scalePar", var_class = "numeric", label_attr = ifelse( is.null(label_scalePar), NA, label_scalePar ), var_label = ifelse( is.null(label_scalePar), "scalePar", label_scalePar ) ) } if (only_variable) { return(res$variable) } if (add_var_type) { return(.add_var_type(res, model)) } res } ## model_list_variables() helpers -------------------------- .add_var_class <- function(x, dataClasses) { x %>% dplyr::left_join( tibble::tibble( variable = names(dataClasses), var_class = dataClasses ), by = "variable" ) } .add_label_attr <- function(x, model) { labels <- unlist(labelled::var_label(model_get_model_frame(model))) if (length(labels) > 0) { x %>% dplyr::left_join( dplyr::tibble( variable = names(labels), label_attr = labels ), by = "variable" ) } else { x %>% dplyr::mutate(label_attr = NA) } } # stats::.MFclass do not distinct integer and numeric .MFclass2 <- function(x) { if (is.logical(x)) { return("logical") } if (is.ordered(x)) { return("ordered") } if (is.factor(x)) { return("factor") } if (is.character(x)) { return("character") } if (is.matrix(x) && is.numeric(x)) { return(paste0("nmatrix.", ncol(x))) } if (is.integer(x)) { return("integer") } if (is.numeric(x)) { return("numeric") } return("other") } .compute_var_label <- function(x, labels = NULL) { if (is.list(labels)) { labels <- unlist(labels) } if (is.null(labels)) { x$var_custom_label <- NA_character_ } else { x <- x %>% dplyr::left_join( dplyr::tibble( variable = names(labels), var_custom_label = labels ), by = "variable" ) } x %>% dplyr::mutate( label_attr = as.character(.data$label_attr), var_label = dplyr::case_when( !is.na(.data$var_custom_label) ~ .data$var_custom_label, !is.na(.data$label_attr) ~ .data$label_attr, TRUE ~ .data$variable ) ) %>% dplyr::select(-dplyr::all_of("var_custom_label")) } .add_var_type <- function(x, model) { x <- x %>% dplyr::left_join( model_get_nlevels(model), by = "variable" ) x %>% .compute_var_type() } broom.helpers/R/select_helpers.R0000644000176200001440000000761714457457125016407 0ustar liggesusers#' 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_categorical()` selects categorical (including `"dichotomous"`) variables #' - `all_dichotomous()` selects only type `"dichotomous"` #' - `all_interaction()` selects interaction terms from a regression model #' - `all_intercepts()` selects intercept terms from a regression model #' - `all_contrasts()` selects variables in regression model based on their type #' of contrast #' - `all_ran_pars()` and `all_ran_vals()` for random-effect parameters and #' values from a mixed model #' (see `vignette("broom_mixed_intro", package = "broom.mixed")`) #' @name select_helpers #' @rdname select_helpers #' @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")` #' #' @return A character vector of column names selected #' @examplesIf interactive() #' glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) %>% #' tidy_plus_plus(exponentiate = TRUE, include = all_categorical()) #' #' glm(response ~ age + trt + grade + stage, #' gtsummary::trial, #' family = binomial, #' contrasts = list(trt = contr.SAS, grade = contr.sum, stage = contr.poly) #' ) %>% #' tidy_plus_plus( #' exponentiate = TRUE, #' include = all_contrasts(c("treatment", "sum")) #' ) NULL #' @rdname select_helpers #' @export all_continuous <- function() { .generic_selector("variable", "var_type", startsWith(.data$var_type, "continuous"), fun_name = "all_continuous" ) } #' @rdname select_helpers #' @export all_dichotomous <- function() { .generic_selector("variable", "var_type", .data$var_type %in% "dichotomous", fun_name = "all_dichotomous" ) } #' @rdname select_helpers #' @export all_categorical <- function(dichotomous = TRUE) { types <- switch(dichotomous, c("categorical", "dichotomous") ) %||% "categorical" .generic_selector("variable", "var_type", .data$var_type %in% .env$types, fun_name = "all_categorical" ) } #' @rdname select_helpers #' @export all_interaction <- function() { .generic_selector("variable", "var_type", .data$var_type %in% "interaction", fun_name = "all_interaction" ) } #' @rdname select_helpers #' @export all_ran_pars <- function() { .generic_selector("variable", "var_type", .data$var_type %in% "ran_pars", fun_name = "all_ran_pars" ) } #' @rdname select_helpers #' @export all_ran_vals <- function() { .generic_selector("variable", "var_type", .data$var_type %in% "ran_vals", fun_name = "all_ran_vals" ) } #' @rdname select_helpers #' @export all_intercepts <- function() { .generic_selector("variable", "var_type", .data$var_type %in% "intercept", fun_name = "all_intercepts" ) } #' @rdname select_helpers #' @export all_contrasts <- function(contrasts_type = NULL) { # if no types specified, select all contrasts if (is.null(contrasts_type)) { return( .generic_selector("variable", "contrasts_type", !is.na(.data$contrasts_type), fun_name = "all_contrasts" ) ) # otherwise, select those specified in `contrasts_type=` } else { contrasts_type <- match.arg(contrasts_type, c("treatment", "sum", "poly", "helmert", "other"), several.ok = TRUE ) return( .generic_selector("variable", "contrasts_type", .data$contrasts_type %in% .env$contrasts_type, fun_name = "all_contrasts" ) ) } } broom.helpers/R/model_list_higher_order_variables.R0000644000176200001440000000304714457457121022277 0ustar liggesusers#' List higher order variables of a model #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) %>% #' model_list_higher_order_variables() #' #' mod <- glm( #' response ~ stage * grade + trt:stage, #' gtsummary::trial, #' family = binomial #' ) #' mod %>% model_list_higher_order_variables() #' #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, #' family = binomial #' ) #' mod %>% model_list_higher_order_variables() model_list_higher_order_variables <- function(model) { UseMethod("model_list_higher_order_variables") } #' @export #' @rdname model_list_higher_order_variables model_list_higher_order_variables.default <- function(model) { variables <- model %>% model_list_variables(only_variable = TRUE) # exclude response variable response_variable <- model %>% model_get_response_variable() if (!is.null(response_variable)) { variables <- variables[!variables %in% response_variable] } # exclude (weights) variables <- variables[variables != "(weights)"] terms <- strsplit(variables, ":") # count the number of times a combination of terms appear .count_combination <- function(i) { lapply( terms, function(x) { all(i %in% x) } ) %>% unlist() %>% sum() } count <- lapply(terms, .count_combination) %>% unlist() # keep combinations appearing only once variables[count == 1] } broom.helpers/R/tidy_add_n.R0000644000176200001440000001355614457457133015502 0ustar liggesusers#' Add the (weighted) number of observations #' #' Add the number of observations in a new column `n_obs`, taking into account any #' weights if they have been defined. #' #' For continuous variables, it corresponds to all valid observations #' contributing to the model. #' #' For categorical variables coded with treatment or sum contrasts, #' each model term could be associated to only one level of the original #' categorical variable. Therefore, `n_obs` will correspond to the number of #' observations associated with that level. `n_obs` will also be computed for #' reference rows. For polynomial contrasts (defined with [stats::contr.poly()]), #' all levels will contribute to the computation of each model term. Therefore, #' `n_obs` will be equal to the total number of observations. For Helmert and custom #' contrasts, only rows contributing positively (i.e. with a positive contrast) #' to the computation of a term will be considered for estimating `n_obs`. The #' result could therefore be difficult to interpret. For a better understanding #' of which observations are taken into account to compute `n_obs` values, you #' could look at [model_compute_terms_contributions()]. #' #' For interaction terms, only rows contributing to all the terms of the #' interaction will be considered to compute `n_obs`. #' #' For binomial logistic models, `tidy_add_n()` will also return the #' corresponding number of events (`n_event`) for each term, taking into account #' any defined weights. Observed proportions could be obtained as `n_obs / n_event`. #' #' Similarly, a number of events will be computed for multinomial logistic #' models (`nnet::multinom()`) for each level of the outcome (`y.level`), #' corresponding to the number of observations equal to that outcome level. #' #' For Poisson models, `n_event` will be equal to the number of counts per term. #' In addition, a third column `exposure` will be computed. If no offset is #' defined, exposure is assumed to be equal to 1 (eventually multiplied by #' weights) per observation. If an offset is defined, `exposure` will be equal #' to the (weighted) sum of the exponential of the offset (as a reminder, to #' model the effect of `x` on the ratio `y / z`, a Poisson model will be defined #' as `glm(y ~ x + offset(log(z)), family = poisson)`). Observed rates could be #' obtained with `n_event / exposure`. #' #' For Cox models ([survival::coxph()]), an individual could be coded #' with several observations (several rows). `n_obs` will correspond to the weighted #' number of observations which could be different from the number of #' individuals. `tidy_add_n()` will also compute a (weighted) number of events #' (`n_event`) according to the definition of the [survival::Surv()] object. #' Exposure time is also returned in `exposure` column. It is equal to the #' (weighted) sum of the time variable if only one variable time is passed to #' [survival::Surv()], and to the (weighted) sum of `time2 - time` if two time #' variables are defined in [survival::Surv()]. #' #' For competing risk regression models ([tidycmprsk::crr()]), `n_event` takes #' into account only the event of interest defined by `failcode.` #' #' The (weighted) total number of observations (`N_obs`), of events (`N_event`) and #' of exposure time (`Exposure`) are stored as attributes of the returned #' tibble. #' #' @param x a tidy tibble #' @param model the corresponding model, if not attached to `x` #' @export #' @family tidy_helpers #' @examplesIf interactive() #' lm(Petal.Length ~ ., data = iris) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' lm(Petal.Length ~ ., data = iris, contrasts = list(Species = contr.sum)) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' lm(Petal.Length ~ ., data = iris, contrasts = list(Species = contr.poly)) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' lm(Petal.Length ~ poly(Sepal.Length, 2), data = iris) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.helmert") #' ) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' df %>% #' glm( #' Survived ~ Class * (Age:Sex), #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.helmert") #' ) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) %>% #' tidy_and_attach() %>% #' tidy_add_n() #' #' glm( #' response ~ trt * grade + offset(log(ttdeath)), #' gtsummary::trial, #' family = poisson #' ) %>% #' tidy_and_attach() %>% #' tidy_add_n() tidy_add_n <- function(x, model = tidy_get_model(x)) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) if (any(c("n_obs", "n_event", "exposure") %in% names(x))) { x <- x %>% dplyr::select(-dplyr::any_of(c("n_obs", "n_event", "exposure"))) } n <- model %>% model_get_n() if (is.null(n)) { x$n <- NA_real_ } else { if ("y.level" %in% names(n)) { x <- x %>% dplyr::left_join(n, by = c("y.level", "term")) } else { x <- x %>% dplyr::left_join(n, by = "term") } } if (!is.null(attr(n, "N_obs"))) { .attributes$N_obs <- attr(n, "N_obs") } if (!is.null(attr(n, "N_event"))) { .attributes$N_event <- attr(n, "N_event") } if (!is.null(attr(n, "Exposure"))) { .attributes$Exposure <- attr(n, "Exposure") } x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/tidy_add_estimate_to_reference_rows.R0000644000176200001440000001541714463417025022641 0ustar liggesusers#' Add an estimate value to references rows for categorical variables #' #' For categorical variables with a treatment contrast #' ([stats::contr.treatment()]) or a SAS contrast ([stats::contr.SAS()]), #' will add an estimate equal to `0` (or `1` if `exponentiate = TRUE`) #' to the reference row. #' #' For categorical variables with a sum contrast ([stats::contr.sum()]), #' the estimate value of the reference row will be equal to the sum of #' all other coefficients multiplied by `-1` (eventually exponentiated if #' `exponentiate = TRUE`), and obtained with `emmeans::emmeans()`. #' The `emmeans` package should therefore be installed. #' For sum contrasts, the model coefficient corresponds #' to the difference of each level with the grand mean. #' For sum contrasts, confidence intervals and p-values will also #' be computed and added to the reference rows. #' #' For other variables, no change will be made. #' #' @details #' If the `reference_row` column is not yet available in `x`, #' [tidy_add_reference_rows()] will be automatically applied. #' #' @param x a tidy tibble #' @param exponentiate logical indicating whether or not to exponentiate the #' coefficient estimates. It should be consistent with the original call to #' [broom::tidy()] #' @param conf.level confidence level, by default use the value indicated #' previously in [tidy_and_attach()], used only for sum contrasts #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' if (.assert_package("gtsummary", boolean = TRUE) && .assert_package("emmeans", boolean = TRUE)) { #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(dplyr::across(where(is.character), factor)) #' #' df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.SAS") #' ) %>% #' tidy_and_attach(exponentiate = TRUE) %>% #' tidy_add_reference_rows() %>% #' tidy_add_estimate_to_reference_rows() #' #' glm( #' response ~ stage + grade * trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list( #' stage = contr.treatment(4, base = 3), #' grade = contr.treatment(3, base = 2), #' trt = contr.treatment(2, base = 2) #' ) #' ) %>% #' tidy_and_attach() %>% #' tidy_add_reference_rows() %>% #' tidy_add_estimate_to_reference_rows() #' } tidy_add_estimate_to_reference_rows <- function( x, exponentiate = attr(x, "exponentiate"), conf.level = attr(x, "conf.level"), model = tidy_get_model(x), quiet = FALSE) { if (is.null(exponentiate) || !is.logical(exponentiate)) { cli::cli_abort("{.arg exponentiate} is not provided. You need to pass it explicitely.") } if (is.null(conf.level) || !is.numeric(conf.level)) { cli::cli_abort("{.arg conf.level} is not provided. You need to pass it explicitely.") } if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) .attributes$exponentiate <- exponentiate if (!"reference_row" %in% names(x)) { x <- x %>% tidy_add_reference_rows(model = model) } if (!"estimate" %in% names(x)) { # to avoid a problem with certain types of model (e.g. gam) return(x %>% tidy_attach_model(model)) } # treatment contrasts x <- x %>% dplyr::mutate( estimate = dplyr::if_else( !is.na(.data$reference_row) & .data$reference_row & stringr::str_starts(.data$contrasts, "contr.treatment|contr.SAS"), dplyr::if_else(exponentiate, 1, 0), .data$estimate ) ) # sum contrasts ref_rows_sum <- which(x$reference_row & x$contrasts == "contr.sum") if (length(ref_rows_sum) > 0) { for (i in ref_rows_sum) { est <- .get_ref_row_estimate_contr_sum( x$variable[i], model = model, exponentiate = exponentiate, conf.level = conf.level, quiet = quiet ) x$estimate[i] <- est$estimate x$std.error[i] <- est$std.error x$p.value[i] <- est$p.value if (all(c("conf.low", "conf.high") %in% names(x))) { x$conf.low[i] <- est$conf.low x$conf.high[i] <- est$conf.high } } } x %>% tidy_attach_model(model = model, .attributes = .attributes) } .get_ref_row_estimate_contr_sum <- function(variable, model, exponentiate = FALSE, conf.level = .95, quiet = FALSE) { if (inherits(model, "multinom")) { dc <- NULL if (!quiet) { cli_alert_info(paste0( "Sum contrasts are not supported for 'multinom' models.\n", "Reference row of variable '", variable, "' remained unchanged." )) } } else if (inherits(model, "LORgee")) { dc <- NULL if (!quiet) { cli_alert_info(paste0( "Sum contrasts are not supported for {.pkg multgee} models.\n", "Reference row of variable '", variable, "' remained unchanged." )) } } else { .assert_package("emmeans", fn = "broom.helpers::tidy_add_estimate_to_reference_rows()") dc <- tryCatch( suppressMessages( emmeans::emmeans(model, specs = variable, contr = "eff") ), error = function(e) { if (!quiet) { cli_alert_info(paste0( "No emmeans() method for this type of model.\n", "Reference row of variable '", variable, "' remained unchanged." )) } NULL } ) } if (is.null(dc)) { res <- data.frame( estimate = NA_real_, std.error = NA_real_, p.value = NA_real_, conf.low = NA_real_, conf.high = NA_real_ ) } else { res <- dc$contrasts %>% as.data.frame(destroy.annotations = TRUE) %>% dplyr::last() %>% dplyr::select("estimate", std.error = "SE", "p.value") ci <- dc$contrasts %>% stats::confint(level = conf.level) %>% as.data.frame() %>% dplyr::last() if ("asymp.LCL" %in% names(ci)) { res$conf.low <- ci$asymp.LCL res$conf.high <- ci$asymp.UCL } else if ("lower.CL" %in% names(ci)) { res$conf.low <- ci$lower.CL res$conf.high <- ci$upper.CL } else if ("lower.PL" %in% names(ci)) { res$conf.low <- ci$lower.PL res$conf.high <- ci$upper.PL } else { res$conf.low <- NA_real_ res$conf.high <- NA_real_ } } if (exponentiate) { res$estimate <- exp(res$estimate) res$conf.low <- exp(res$conf.low) res$conf.high <- exp(res$conf.high) } res } broom.helpers/R/tidy_select_variables.R0000644000176200001440000000573714464175037017744 0ustar liggesusers#' Select variables to keep/drop #' #' Will remove unselected variables from the results. #' To remove the intercept, use [tidy_remove_intercept()]. #' #' @details #' If the `variable` column is not yet available in `x`, #' [tidy_identify_variables()] will be automatically applied. #' @param x a tidy tibble #' @param include variables to include. Accepts [tidyselect][dplyr::select] #' syntax. Use `-` to remove a variable. Default is `everything()`. #' See also [all_continuous()], [all_categorical()], [all_dichotomous()] #' and [all_interaction()] #' @return #' The `x` tibble limited to the included variables (and eventually the intercept), #' sorted according to the `include` parameter. #' #' @param model the corresponding model, if not attached to `x` #' @export #' @family tidy_helpers #' @examples #' res <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived)) %>% #' glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) %>% #' tidy_and_attach() %>% #' tidy_identify_variables() #' #' res #' res %>% tidy_select_variables() #' res %>% tidy_select_variables(include = "Class") #' res %>% tidy_select_variables(include = -c("Age", "Sex")) #' res %>% tidy_select_variables(include = starts_with("A")) #' res %>% tidy_select_variables(include = all_categorical()) #' res %>% tidy_select_variables(include = all_dichotomous()) #' res %>% tidy_select_variables(include = all_interaction()) #' res %>% tidy_select_variables( #' include = c("Age", all_categorical(dichotomous = FALSE), all_interaction()) #' ) tidy_select_variables <- function( x, include = everything(), model = tidy_get_model(x)) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if (!"variable" %in% names(x)) { x <- x %>% tidy_identify_variables(model = model) } .attributes <- .save_attributes(x) # obtain character vector of selected variables include <- .select_to_varnames({{ include }}, var_info = x, arg_name = "include") # order result, intercept first then by the order of include if ("y.level" %in% names(x)) { x$group_order <- factor(x$y.level) %>% forcats::fct_inorder() } else if ("component" %in% names(x)) { x$group_order <- factor(x$component) %>% forcats::fct_inorder() } else { x$group_order <- 1 } x %>% dplyr::filter( .data$var_type == "intercept" | .data$variable %in% include ) %>% dplyr::mutate( log_intercept = .data$var_type == "intercept", fct_variable = factor(.data$variable, levels = include) ) %>% dplyr::arrange( .data$group_order, dplyr::desc(.data$log_intercept), .data$fct_variable ) %>% dplyr::select( -dplyr::any_of(c("group_order", "log_intercept", "fct_variable")) ) %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_list_contrasts.R0000644000176200001440000001037114463417025017620 0ustar liggesusers#' List contrasts used by a model #' #' @param model a model object #' @return #' A tibble with three columns: #' * `variable`: variable name #' * `contrasts`: contrasts used #' * `contrasts_type`: type of contrasts #' ("treatment", "sum", "poly", "helmert", "sdiff, "other" or "no.contrast") #' * `reference`: for variables with treatment, SAS #' or sum contrasts, position of the reference level #' @details #' For models with no intercept, no contrasts will be applied to one of the #' categorical variable. In such case, one dummy term will be returned for each #' level of the categorical variable. #' @export #' @family model_helpers #' @examples #' glm( #' am ~ mpg + factor(cyl), #' data = mtcars, #' family = binomial, #' contrasts = list(`factor(cyl)` = contr.sum) #' ) %>% #' model_list_contrasts() model_list_contrasts <- function(model) { UseMethod("model_list_contrasts") } #' @export #' @rdname model_list_contrasts model_list_contrasts.default <- function(model) { model_contrasts <- model_get_contrasts(model) if (length(model_contrasts) == 0) { return(NULL) } contrasts_list <- tibble::tibble( variable = names(model_contrasts), contrasts = NA_character_, reference = NA_integer_ ) xlevels <- model_get_xlevels(model) model_variables <- model_identify_variables(model) for (i in seq_len(nrow(contrasts_list))) { n_levels <- length(xlevels[[contrasts_list$variable[i]]]) n_terms <- model_variables %>% dplyr::filter(.data$variable == contrasts_list$variable[i]) %>% nrow() if (n_levels == n_terms) { contrasts_list$contrasts[[i]] <- "no.contrast" } else if ( is.character(model_contrasts[[i]]) && length(is.character(model_contrasts[[i]]) == 1) ) { contrasts_list$contrasts[[i]] <- model_contrasts[[i]] if (model_contrasts[[i]] == "contr.treatment") { contrasts_list$reference[[i]] <- 1 } if (model_contrasts[[i]] == "contr.SAS" || model_contrasts[[i]] == "contr.sum") { contrasts_list$reference[[i]] <- n_levels } if (model_contrasts[[i]] == "contr.sdif") { contrasts_list$reference[[i]] <- NA } } else if (all(model_contrasts[[i]] == stats::contr.treatment(n_levels))) { contrasts_list$contrasts[[i]] <- "contr.treatment" contrasts_list$reference[[i]] <- 1 } else if (all(model_contrasts[[i]] == stats::contr.sum(n_levels))) { contrasts_list$contrasts[[i]] <- "contr.sum" contrasts_list$reference[[i]] <- n_levels } else if (all(model_contrasts[[i]] == stats::contr.helmert(n_levels))) { contrasts_list$contrasts[[i]] <- "contr.helmert" } else if (all(model_contrasts[[i]] == stats::contr.poly(n_levels))) { contrasts_list$contrasts[[i]] <- "contr.poly" } else if (all(model_contrasts[[i]] == stats::contr.SAS(n_levels))) { contrasts_list$contrasts[[i]] <- "contr.SAS" contrasts_list$reference[[i]] <- n_levels } else if ( .assert_package("MASS", boolean = TRUE) && all(model_contrasts[[i]] == MASS::contr.sdif(n_levels)) ) { contrasts_list$contrasts[[i]] <- "contr.sdif" contrasts_list$reference[[i]] <- NA } else { for (j in 2:n_levels) { # testing treatment coding width different value for base variable if (all(model_contrasts[[i]] == stats::contr.treatment(n_levels, base = j))) { contrasts_list$contrasts[[i]] <- paste0("contr.treatment(base=", j, ")") contrasts_list$reference[[i]] <- j } } } # if still not found, just indicate custom contrast if (is.na(contrasts_list$contrasts[[i]])) { contrasts_list$contrasts[[i]] <- "custom" } } contrasts_list %>% dplyr::mutate( contrasts_type = dplyr::case_when( .data$contrasts %>% stringr::str_starts("contr.treatment") ~ "treatment", .data$contrasts == "contr.SAS" ~ "treatment", .data$contrasts == "contr.sum" ~ "sum", .data$contrasts == "contr.helmert" ~ "helmert", .data$contrasts == "contr.poly" ~ "poly", .data$contrasts == "contr.sdif" ~ "sdif", .data$contrasts == "no.contrast" ~ "no.contrast", TRUE ~ "other" ) ) } broom.helpers/R/model_get_assign.R0000644000176200001440000000277314457457106016706 0ustar liggesusers#' Get the assign attribute of model matrix of a model #' #' Return the assign attribute attached to the object returned by #' [stats::model.matrix()]. #' #' @param model a model object #' @export #' @family model_helpers #' @seealso [stats::model.matrix()] #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_assign() model_get_assign <- function(model) { UseMethod("model_get_assign") } #' @export #' @rdname model_get_assign model_get_assign.default <- function(model) { model_matrix <- model_get_model_matrix(model) get_assign <- purrr::attr_getter("assign") assign <- model_matrix %>% get_assign() if (is.null(assign)) { # an alternative generic way to compute assign # (e.g. for felm models) model_matrix <- tryCatch( stats::model.matrix(stats::terms(model), stats::model.frame(model)), error = function(e) { NULL # nocov } ) assign <- model_matrix %>% get_assign() } if (!is.atomic(assign)) { return(NULL) } # nocov attr(assign, "model_matrix") <- model_matrix assign } #' @export #' @rdname model_get_assign model_get_assign.vglm <- function(model) { model_matrix <- model_get_model_matrix(model) get_assign <- purrr::attr_getter("orig.assign.lm") assign <- model_matrix %>% get_assign() attr(assign, "model_matrix") <- model_matrix assign } #' @export #' @rdname model_get_assign model_get_assign.model_fit <- function(model) { model_get_assign(model$fit) } broom.helpers/R/tidy_plus_plus.R0000644000176200001440000002031014457457142016445 0ustar liggesusers#' Tidy a model and compute additional informations #' #' This function will apply sequentially: #' * [tidy_and_attach()] #' * [tidy_disambiguate_terms()] #' * [tidy_identify_variables()] #' * [tidy_add_contrasts()] #' * [tidy_add_reference_rows()] #' * [tidy_add_pairwise_contrasts()] #' * [tidy_add_estimate_to_reference_rows()] #' * [tidy_add_variable_labels()] #' * [tidy_add_term_labels()] #' * [tidy_add_header_rows()] #' * [tidy_add_n()] #' * [tidy_remove_intercept()] #' * [tidy_select_variables()] #' * [tidy_add_coefficients_type()] #' * [tidy_detach_model()] #' #' @param model a model to be attached/tidied #' @param tidy_fun option to specify a custom tidier function #' @param conf.int should confidence intervals be computed? (see [broom::tidy()]) #' @param conf.level level of confidence for confidence intervals (default: 95%) #' @param exponentiate logical indicating whether or not to exponentiate the #' coefficient estimates. This is typical for logistic, Poisson and Cox models, #' but a bad idea if there is no log or logit link; defaults to `FALSE`. #' @param variable_labels a named list or a named vector of custom variable labels #' @param term_labels a named list or a named vector of custom term labels #' @param interaction_sep separator for interaction terms #' @param categorical_terms_pattern a [glue pattern][glue::glue()] for #' labels of categorical terms with treatment or sum contrasts #' (see [model_list_terms_levels()]) #' @param disambiguate_terms should terms be disambiguated with #' [tidy_disambiguate_terms()]? (default `TRUE`) #' @param disambiguate_sep separator for [tidy_disambiguate_terms()] #' @param add_reference_rows should reference rows be added? #' @param no_reference_row variables (accepts [tidyselect][dplyr::select] notation) #' for those no reference row should be added, when `add_reference_rows = TRUE` #' @param add_pairwise_contrasts apply [tidy_add_pairwise_contrasts()]? #' `r lifecycle::badge("experimental")` #' @param pairwise_variables variables to add pairwise contrasts #' (accepts [tidyselect][dplyr::select] notation) #' @param keep_model_terms keep original model terms for variables where #' pairwise contrasts are added? (default is `FALSE`) #' @param pairwise_reverse determines whether to use `"pairwise"` (if `TRUE`) #' or `"revpairwise"` (if `FALSE`), see [emmeans::contrast()] #' @param contrasts_adjust optional adjustment method when computing contrasts, #' see [emmeans::contrast()] (if `NULL`, use `emmeans` default) #' @param emmeans_args list of additional parameter to pass to #' [emmeans::emmeans()] when computing pairwise contrasts #' @param add_estimate_to_reference_rows should an estimate value be added #' to reference rows? #' @param add_header_rows should header rows be added? #' @param show_single_row variables that should be displayed #' on a single row (accepts [tidyselect][dplyr::select] notation), when #' `add_header_rows` is `TRUE` #' @param add_n should the number of observations be added? #' @param intercept should the intercept(s) be included? #' @inheritParams tidy_select_variables #' @param keep_model should the model be kept as an attribute of the final #' result? #' @param quiet logical argument whether broom.helpers should not return #' a message when requested output cannot be generated. Default is `FALSE` #' @param strict logical argument whether broom.helpers should return an error #' when requested output cannot be generated. Default is `FALSE` #' @param ... other arguments passed to `tidy_fun()` #' @family tidy_helpers #' @examplesIf interactive() #' ex1 <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) %>% #' tidy_plus_plus() #' ex1 #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate( #' Survived = factor(Survived, c("No", "Yes")) #' ) %>% #' labelled::set_variable_labels( #' Class = "Passenger's class", #' Sex = "Gender" #' ) #' ex2 <- glm( #' Survived ~ Class + Age * Sex, #' data = df, weights = df$n, #' family = binomial #' ) %>% #' tidy_plus_plus( #' exponentiate = TRUE, #' add_reference_rows = FALSE, #' categorical_terms_pattern = "{level} / {reference_level}", #' add_n = TRUE #' ) #' ex2 #' if (.assert_package("gtsummary", boolean = TRUE)) { #' ex3 <- #' glm( #' response ~ poly(age, 3) + stage + grade * trt, #' na.omit(gtsummary::trial), #' family = binomial, #' contrasts = list( #' stage = contr.treatment(4, base = 3), #' grade = contr.sum #' ) #' ) %>% #' tidy_plus_plus( #' exponentiate = TRUE, #' variable_labels = c(age = "Age (in years)"), #' add_header_rows = TRUE, #' show_single_row = all_dichotomous(), #' term_labels = c("poly(age, 3)3" = "Cubic age"), #' keep_model = TRUE #' ) #' ex3 #' } #' @export tidy_plus_plus <- function(model, tidy_fun = tidy_with_broom_or_parameters, conf.int = TRUE, conf.level = .95, exponentiate = FALSE, variable_labels = NULL, term_labels = NULL, interaction_sep = " * ", categorical_terms_pattern = "{level}", disambiguate_terms = TRUE, disambiguate_sep = ".", add_reference_rows = TRUE, no_reference_row = NULL, add_pairwise_contrasts = FALSE, pairwise_variables = all_categorical(), keep_model_terms = FALSE, pairwise_reverse = TRUE, contrasts_adjust = NULL, emmeans_args = list(), add_estimate_to_reference_rows = TRUE, add_header_rows = FALSE, show_single_row = NULL, add_n = TRUE, intercept = FALSE, include = everything(), keep_model = FALSE, quiet = FALSE, strict = FALSE, ...) { res <- model %>% tidy_and_attach( tidy_fun = tidy_fun, conf.int = conf.int, conf.level = conf.level, exponentiate = exponentiate, ... ) if (disambiguate_terms) { res <- res %>% tidy_disambiguate_terms(sep = disambiguate_sep, quiet = quiet) } res <- res %>% tidy_identify_variables(quiet = quiet) %>% tidy_add_contrasts() if (add_reference_rows) { res <- res %>% tidy_add_reference_rows( no_reference_row = {{ no_reference_row }}, quiet = quiet ) } if (add_pairwise_contrasts) { res <- res %>% tidy_add_pairwise_contrasts( variables = {{ pairwise_variables }}, keep_model_terms = keep_model_terms, pairwise_reverse = pairwise_reverse, contrasts_adjust = contrasts_adjust, emmeans_args = emmeans_args ) } if (add_reference_rows && add_estimate_to_reference_rows) { res <- res %>% tidy_add_estimate_to_reference_rows(exponentiate = exponentiate, quiet = quiet) } res <- res %>% tidy_add_variable_labels( labels = variable_labels, interaction_sep = interaction_sep, quiet = quiet ) %>% tidy_add_term_labels( labels = term_labels, interaction_sep = interaction_sep, categorical_terms_pattern = categorical_terms_pattern, quiet = quiet ) if (add_header_rows) { res <- res %>% tidy_add_header_rows( show_single_row = {{ show_single_row }}, strict = strict, quiet = quiet ) } if (add_n) { res <- res %>% tidy_add_n() } if (!intercept) { res <- res %>% tidy_remove_intercept() } res <- res %>% tidy_select_variables( include = {{ include }}, ) %>% tidy_add_coefficients_type() if (!keep_model) { res <- res %>% tidy_detach_model() } res } broom.helpers/R/model_get_coefficients_type.R0000644000176200001440000001067014457457110021112 0ustar liggesusers#' Get coefficient type #' #' Indicate the type of coefficient among "generic", "logistic", #' "poisson", "relative_risk" or "prop_hazard". #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_coefficients_type() #' #' Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' glm(Survived ~ Class + Age * Sex, data = ., weights = .$n, family = binomial) %>% #' model_get_coefficients_type() model_get_coefficients_type <- function(model) { UseMethod("model_get_coefficients_type") } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.default <- function(model) { "generic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.glm <- function(model) { if (!is.null(model$family)) { if (model$family$family == "binomial" && model$family$link == "logit") { return("logistic") } if (model$family$family == "binomial" && model$family$link == "log") { return("relative_risk") } if (model$family$family == "binomial" && model$family$link == "cloglog") { return("prop_hazard") } if (model$family$family == "poisson" && model$family$link == "log") { return("poisson") } if (model$family$family == "quasibinomial" && model$family$link == "logit") { return("logistic") } if (model$family$family == "quasipoisson" && model$family$link == "log") { return("poisson") } } "generic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.negbin <- function(model) { "poisson" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.geeglm <- model_get_coefficients_type.glm #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.fixest <- model_get_coefficients_type.glm #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.biglm <- model_get_coefficients_type.glm #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.glmerMod <- function(model) { if (model@resp$family$family == "binomial" && model@resp$family$link == "logit") { return("logistic") } if (model@resp$family$family == "binomial" && model@resp$family$link == "log") { return("relative_risk") } if (model@resp$family$family == "binomial" && model@resp$family$link == "cloglog") { return("prop_hazard") } if (model@resp$family$family == "poisson" && model@resp$family$link == "log") { return("poisson") } # "quasi" families cannot be used with in glmer "generic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.clogit <- function(model) { "logistic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.polr <- function(model) { if (model$method == "logistic") { return("logistic") } "generic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.multinom <- function(model) { "logistic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.svyolr <- function(model) { "logistic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.clm <- function(model) { "logistic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.clmm <- function(model) { "logistic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.coxph <- function(model) { "prop_hazard" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.crr <- function(model) { "prop_hazard" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.tidycrr <- function(model) { "prop_hazard" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.model_fit <- function(model) { model_get_coefficients_type(model$fit) } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.LORgee <- function(model) { if (stringr::str_detect( model$link, stringr::regex("logit", ignore_case = TRUE) )) { return("logistic") } if (stringr::str_detect( model$link, stringr::regex("cloglog", ignore_case = TRUE) )) { return("prop_hazard") } "generic" } broom.helpers/R/broom.helpers-package.R0000644000176200001440000000514514464175142017542 0ustar liggesusers## usethis namespace: start #' @importFrom lifecycle deprecate_soft #' @importFrom cli cli_alert_info cli_alert_info cli_alert_danger cli_code cli_ul #' @importFrom rlang .data .env #' @importFrom purrr %||% ## usethis namespace: end NULL # because `where` is not exported by tidyselect # cf. https://github.com/r-lib/tidyselect/issues/201 utils::globalVariables(c(".", "where")) # update named vectors, y values overriding x values if common name .update_vector <- function(x, y) { if (is.null(y)) { return(x) } if (is.null(names(y)) || any(names(y) == "")) { cli::cli_abort("All elements of y should be named.") } for (i in names(y)) { if (utils::hasName(x, i)) { x[i] <- y[i] } else { x <- c(x, y[i]) } } x } # return superscript character .superscript_numbers <- function(x) { if (!is.character(x)) { x <- as.character(x) } x[x == "1"] <- "" # do not show when equal 1 pattern <- c( "0" = "\u2070", "1" = "\u00b9", "2" = "\u00b2", "3" = "\u00b3", "4" = "\u2074", "5" = "\u2075", "6" = "\u2076", "7" = "\u2077", "8" = "\u2078", "9" = "\u2079" ) x %>% stringr::str_replace_all(pattern) } # for consistent column order .order_tidy_columns <- function(x) { x %>% dplyr::select( dplyr::any_of( c( "y.level", "component", "term", "original_term", "variable", "var_label", "var_class", "var_type", "var_nlevels", "header_row", "contrasts", "contrasts_type", "reference_row", "label", "n_obs", "n_event", "exposure" ) ), dplyr::everything() ) } # attributes to be saved between tidy_* functions .save_attributes <- function(x) { .attributes <- attributes(x) .attributes_names <- intersect( names(.attributes), c( "exponentiate", "conf.level", "coefficients_type", "coefficients_label", "variable_labels", "term_labels", "N_obs", "N_event", "Exposure", "force_contr.treatment", "skip_add_reference_rows", "find_missing_interaction_terms", "component" ) ) .attributes[.attributes_names] } #' Sequence generation between min and max #' #' @param x a numeric vector #' @param length.out desired length of the sequence #' @details #' `seq_range(x, length.out)` is a shortcut for #' `seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = length.out)` #' @return #' a numeric vector #' @export #' @examples #' seq_range(iris$Petal.Length) seq_range <- function(x, length.out = 25) { seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = length.out) } broom.helpers/R/model_get_model.R0000644000176200001440000000124714357760764016523 0ustar liggesusers#' Get the model from model objects #' #' Most model objects are proper R model objects. There are, however, some #' model objects that store the proper object internally (e.g. mice models). #' This function extracts that model object in those cases. #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_model() model_get_model <- function(model) { UseMethod("model_get_model") } #' @export #' @rdname model_get_model model_get_model.default <- function(model) model #' @export #' @rdname model_get_model model_get_model.mira <- function(model) model$analyses[[1]] broom.helpers/R/model_get_weights.R0000644000176200001440000000363014463417025017056 0ustar liggesusers#' Get sampling weights used by a model #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' mod <- lm(Sepal.Length ~ Sepal.Width, iris) #' mod %>% model_get_weights() #' #' mod <- lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars, weights = mtcars$gear) #' mod %>% model_get_weights() #' #' mod <- glm( #' response ~ stage * grade + trt, #' gtsummary::trial, #' family = binomial #' ) #' mod %>% model_get_weights() #' #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, #' family = binomial #' ) #' mod %>% model_get_weights() #' #' d <- dplyr::as_tibble(Titanic) %>% #' dplyr::group_by(Class, Sex, Age) %>% #' dplyr::summarise( #' n_survived = sum(n * (Survived == "Yes")), #' n_dead = sum(n * (Survived == "No")) #' ) #' mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial) #' mod %>% model_get_weights() model_get_weights <- function(model) { UseMethod("model_get_weights") } #' @export #' @rdname model_get_weights model_get_weights.default <- function(model) { w <- tryCatch( stats::weights(model), error = function(e) { NULL } ) if (is.null(w) || length(w) == 0) { mf <- model %>% model_get_model_frame() if (!is.null(mf)) { if ("(weights)" %in% names(mf)) { w <- mf %>% purrr::pluck("(weights)") } else { w <- rep_len(1L, mf %>% nrow()) } } } # matrix case => transform to vector if (is.matrix(w)) w <- c(w) w } #' @export #' @rdname model_get_weights model_get_weights.svyglm <- function(model) { stats::weights(model$survey.design) } #' @export #' @rdname model_get_weights model_get_weights.model_fit <- function(model) { model_get_weights(model$fit) } broom.helpers/R/tidy_add_term_labels.R0000644000176200001440000002137114463417025017521 0ustar liggesusers#' Add term labels #' #' Will add term labels in a `label` column, based on: #' 1. labels provided in `labels` argument if provided; #' 2. factor levels for categorical variables coded with #' treatment, SAS or sum contrasts (the label could be #' customized with `categorical_terms_pattern` argument); #' 3. variable labels when there is only one term per variable; #' 4. term name otherwise. #' #' @details #' If the `variable_label` column is not yet available in `x`, #' [tidy_add_variable_labels()] will be automatically applied. #' If the `contrasts` column is not yet available in `x`, #' [tidy_add_contrasts()] will be automatically applied. #' #' It is possible to pass a custom label for any term in `labels`, #' including interaction terms. #' @param x a tidy tibble #' @param labels an optional named list or named vector of #' custom term labels #' @param interaction_sep separator for interaction terms #' @param categorical_terms_pattern a [glue pattern][glue::glue()] for #' labels of categorical terms with treatment or sum contrasts #' (see examples and [model_list_terms_levels()]) #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) %>% #' labelled::set_variable_labels( #' Class = "Passenger's class", #' Sex = "Sex" #' ) #' #' mod <- df %>% #' glm(Survived ~ Class * Age * Sex, data = ., weights = .$n, family = binomial) #' mod %>% #' tidy_and_attach() %>% #' tidy_add_term_labels() #' mod %>% #' tidy_and_attach() %>% #' tidy_add_term_labels( #' interaction_sep = " x ", #' categorical_terms_pattern = "{level} / {reference_level}" #' ) tidy_add_term_labels <- function(x, labels = NULL, interaction_sep = " * ", categorical_terms_pattern = "{level}", model = tidy_get_model(x), quiet = FALSE, strict = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if ("header_row" %in% names(x)) { cli::cli_abort("{.fn tidy_add_term_labels} cannot be applied after {.fn tidy_add_header_rows}.") } .attributes <- .save_attributes(x) if ("label" %in% names(x)) { x <- x %>% dplyr::select(-dplyr::all_of("label")) } if (is.list(labels)) { labels <- unlist(labels) } if (!"var_label" %in% names(x)) { x <- x %>% tidy_add_variable_labels(model = model, quiet = quiet) } if (!"contrasts" %in% names(x)) { x <- x %>% tidy_add_contrasts(model = model) } # specific case for nnet::multinom # keeping only one level for computing term_labels if ("y.level" %in% names(x) && inherits(model, "multinom")) { xx <- x %>% dplyr::filter(.data$y.level == x$y.level[1]) } else { xx <- x } # start with term names term_labels <- unique(stats::na.omit(xx$term)) names(term_labels) <- term_labels # add categorical terms levels sdif_term_level <- "diff" if (.attributes$exponentiate) sdif_term_level <- "ratio" terms_levels <- model %>% model_list_terms_levels( label_pattern = categorical_terms_pattern, variable_labels = .attributes$variable_labels, sdif_term_level = sdif_term_level ) if (!is.null(terms_levels)) { additional_term_labels <- terms_levels$label names(additional_term_labels) <- terms_levels$term term_labels <- term_labels %>% .update_vector(additional_term_labels) # also consider "variablelevel" notation # when not already used (e.g. for sum contrasts) terms_levels2 <- terms_levels %>% dplyr::mutate(term2 = paste0(.data$variable, .data$level)) %>% dplyr::filter(.data$term2 != .data$term) if (nrow(terms_levels2) > 0) { additional_term_labels <- terms_levels2$label names(additional_term_labels) <- terms_levels2$term2 term_labels <- term_labels %>% .update_vector(additional_term_labels) } # also consider "variablelevel_rank" notation # for no intercept model (because type of interaction unknown) terms_levels3 <- terms_levels %>% dplyr::mutate(term3 = paste0(.data$variable, .data$level_rank)) %>% dplyr::filter(.data$term3 != .data$term & .data$contrasts_type == "no.contrast") if (nrow(terms_levels3) > 0) { additional_term_labels <- terms_levels3$label names(additional_term_labels) <- terms_levels3$term3 term_labels <- term_labels %>% .update_vector(additional_term_labels) } } # add variable labels # first variable list (for interaction only terms) # then current variable labels in x variables_list <- model_list_variables(model) if (!is.null(variables_list)) { variables_list <- variables_list %>% dplyr::mutate( label = dplyr::if_else( is.na(.data$label_attr), .data$variable, as.character(.data$label_attr) ), ) additional_term_labels <- variables_list$label names(additional_term_labels) <- variables_list$variable term_labels <- term_labels %>% .update_vector(additional_term_labels) # add version with backtips for variables with non standard names names(additional_term_labels) <- paste0( "`", names(additional_term_labels), "`" ) term_labels <- term_labels %>% .update_vector(additional_term_labels) } x_var_labels <- xx %>% dplyr::mutate( variable = dplyr::if_else( is.na(.data$variable), # for intercept .data$term, .data$variable ) ) %>% dplyr::group_by(.data$variable) %>% dplyr::summarise( var_label = dplyr::first(.data$var_label), .groups = "drop_last" ) additional_term_labels <- x_var_labels$var_label names(additional_term_labels) <- x_var_labels$variable term_labels <- term_labels %>% .update_vector(additional_term_labels) # add version with backtips for variables with non standard names names(additional_term_labels) <- paste0( "`", names(additional_term_labels), "`" ) term_labels <- term_labels %>% .update_vector(additional_term_labels) # check if all elements of labels are in x # show a message otherwise not_found <- setdiff(names(labels), names(term_labels)) if (length(not_found) > 0 && !quiet) { cli_alert_danger("{.code {not_found}} terms have not been found in {.code x}.") } if (length(not_found) > 0 && strict) { cli::cli_abort("Incorrect call with `labels=`. Quitting execution.", call = NULL) } # labels for polynomial terms poly_terms <- xx %>% dplyr::filter( .data$term %>% stringr::str_starts("poly\\(") ) %>% dplyr::mutate( degree = .data$term %>% stringr::str_replace("poly\\(.+\\)([0-9]+)", "\\1"), label = paste0(.data$var_label, .superscript_numbers(.data$degree)) ) poly_labels <- poly_terms$label names(poly_labels) <- poly_terms$term term_labels <- term_labels %>% .update_vector(poly_labels) # labels argument term_labels <- term_labels %>% .update_vector(labels) # save custom labels .attributes$term_labels <- labels # management of interaction terms interaction_terms <- xx$term[!is.na(xx$var_type) & xx$var_type == "interaction"] # do not treat those specified in labels interaction_terms <- setdiff(interaction_terms, names(labels)) names(interaction_terms) <- interaction_terms interaction_terms <- interaction_terms %>% strsplit(":") # in some cases (e.g. marginal predictions) # interaction terms are not prefixed by variable names # => need to identify them from interaction_terms directly if (isTRUE(.attributes$find_missing_interaction_terms)) { it <- unname(unlist(interaction_terms)) missing_terms <- setdiff(it[it != ""], names(term_labels)) if (length(missing_terms) > 0) { names(missing_terms) <- missing_terms term_labels <- term_labels %>% .update_vector(missing_terms) } } interaction_terms <- interaction_terms %>% lapply(function(x) { paste(term_labels[x], collapse = interaction_sep) }) %>% unlist() term_labels <- term_labels %>% .update_vector(interaction_terms) x %>% dplyr::left_join( tibble::tibble( term = names(term_labels), label = term_labels ), by = "term" ) %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_get_response.R0000644000176200001440000000365514457457115017260 0ustar liggesusers#' Get model response #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model a model object #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl) + disp:hp, mtcars) %>% #' model_get_response() #' #' mod <- glm( #' response ~ stage * grade + trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list(stage = contr.sum, grade = contr.treatment(3, 2), trt = "contr.SAS") #' ) #' mod %>% model_get_response() #' #' mod <- glm( #' Survived ~ Class * Age + Sex, #' data = Titanic %>% as.data.frame(), #' weights = Freq, #' family = binomial #' ) #' mod %>% model_get_response() #' #' d <- dplyr::as_tibble(Titanic) %>% #' dplyr::group_by(Class, Sex, Age) %>% #' dplyr::summarise( #' n_survived = sum(n * (Survived == "Yes")), #' n_dead = sum(n * (Survived == "No")) #' ) #' mod <- glm(cbind(n_survived, n_dead) ~ Class * Age + Sex, data = d, family = binomial, y = FALSE) #' mod %>% model_get_response() model_get_response <- function(model) { UseMethod("model_get_response") } #' @export #' @rdname model_get_response model_get_response.default <- function(model) { tryCatch( model %>% model_get_model_frame() %>% stats::model.response(), error = function(e) { NULL } ) } #' @export #' @rdname model_get_response model_get_response.glm <- function(model) { y <- model %>% purrr::pluck("y") if (is.null(y)) { y <- model %>% model_get_model_frame() %>% stats::model.response() } # model defined with cbind if (is.matrix(y) && ncol(y) == 2) { y <- y[, 1] / rowSums(y) y[is.nan(y)] <- 0 } y } #' @export #' @rdname model_get_response model_get_response.glmerMod <- model_get_response.glm #' @export #' @rdname model_get_response model_get_response.model_fit <- function(model) { model_get_response(model$fit) } broom.helpers/R/model_list_terms_levels.R0000644000176200001440000001751414464175037020317 0ustar liggesusers#' List levels of categorical terms #' #' Only for categorical variables with treatment, #' SAS, sum or successive differences contrasts (cf. [MASS::contr.sdif()]), and #' categorical variables with no contrast. #' #' @param model a model object #' @param label_pattern a [glue pattern][glue::glue()] for term labels (see examples) #' @param variable_labels an optional named list or named vector of #' custom variable labels passed to [model_list_variables()] #' @param sdif_term_level for successive differences contrasts, how should term #' levels be named? `"diff"` for `"B - A"` (default), `"ratio"` for `"B / A"` #' @return #' A tibble with ten columns: #' * `variable`: variable #' * `contrasts_type`: type of contrasts ("sum" or "treatment") #' * `term`: term name #' * `level`: term level #' * `level_rank`: rank of the level #' * `reference`: logical indicating which term is the reference level #' * `reference_level`: level of the reference term #' * `var_label`: variable label obtained with [model_list_variables()] #' * `var_nlevels`: number of levels in this variable #' * `dichotomous`: logical indicating if the variable is dichotomous #' * `label`: term label (by default equal to term level) #' The first nine columns can be used in `label_pattern`. #' @export #' @family model_helpers #' @examples #' glm( #' am ~ mpg + factor(cyl), #' data = mtcars, #' family = binomial, #' contrasts = list(`factor(cyl)` = contr.sum) #' ) %>% #' model_list_terms_levels() #' #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' mod <- df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.helmert") #' ) #' mod %>% model_list_terms_levels() #' mod %>% model_list_terms_levels("{level} vs {reference_level}") #' mod %>% model_list_terms_levels("{variable} [{level} - {reference_level}]") #' mod %>% model_list_terms_levels( #' "{ifelse(reference, level, paste(level, '-', reference_level))}" #' ) model_list_terms_levels <- function( model, label_pattern = "{level}", variable_labels = NULL, sdif_term_level = c("diff", "ratio")) { UseMethod("model_list_terms_levels") } #' @export #' @rdname model_list_terms_levels model_list_terms_levels.default <- function( model, label_pattern = "{level}", variable_labels = NULL, sdif_term_level = c("diff", "ratio")) { contrasts_list <- model_list_contrasts(model) if (is.null(contrasts_list)) { return(NULL) } sdif_term_level <- match.arg(sdif_term_level) contrasts_list <- contrasts_list %>% # keep only treatment, SAS and sum contrasts dplyr::filter( .data$contrasts %>% stringr::str_starts("contr.treatment|contr.SAS|contr.sum|no.contrast|contr.sdif") ) xlevels <- model_get_xlevels(model) if (nrow(contrasts_list) == 0 || length(xlevels) == 0) { return(NULL) } model_terms <- model_identify_variables(model) %>% dplyr::filter(!is.na(.data$variable)) if (nrow(model_terms) == 0) { return(NULL) } res <- dplyr::tibble() for (v in contrasts_list$variable) { if (v %in% names(xlevels)) { contrasts_type <- contrasts_list$contrasts_type[contrasts_list$variable == v] terms_levels <- xlevels[[v]] observed_terms <- model_terms$term[model_terms$variable == v] ref <- contrasts_list$reference[contrasts_list$variable == v] # terms could be named according to two approaches # plus variations with backticks s <- seq(1, length(terms_levels)) terms_names1 <- paste0(v, terms_levels) terms_names2 <- paste0(v, s) terms_names1b <- paste0("`", v, "`", terms_levels) terms_names2b <- paste0("`", v, "`", s) # naming approach for contr.sdif terms_names3 <- paste0(v, terms_levels, "-", dplyr::lag(terms_levels)) terms_names3 <- terms_names3[-1] terms_names3b <- paste0("`", v, "`", terms_levels, "-", dplyr::lag(terms_levels)) terms_names3b <- terms_names3b[-1] terms_names4 <- paste0(v, s, "-", dplyr::lag(s)) terms_names4 <- terms_names4[-1] terms_names4b <- paste0("`", v, "`", s, "-", dplyr::lag(s)) terms_names4b <- terms_names4b[-1] # identification of the naming approach approach <- NA if (length(observed_terms) && !is.na(ref)) { approach <- dplyr::case_when( all(observed_terms %in% terms_names1[-ref]) ~ "1", all(observed_terms %in% terms_names2[-ref]) ~ "2", all(observed_terms %in% terms_names3[-ref]) ~ "3", all(observed_terms %in% terms_names4[-ref]) ~ "4", all(observed_terms %in% terms_names1b[-ref]) ~ "1b", all(observed_terms %in% terms_names2b[-ref]) ~ "2b", all(observed_terms %in% terms_names3b[-ref]) ~ "3b", all(observed_terms %in% terms_names4b[-ref]) ~ "4b" ) } if (length(observed_terms) && is.na(ref)) { approach <- dplyr::case_when( all(observed_terms %in% terms_names1) ~ "1", all(observed_terms %in% terms_names2) ~ "2", all(observed_terms %in% terms_names3) ~ "3", all(observed_terms %in% terms_names4) ~ "4", all(observed_terms %in% terms_names1b) ~ "1b", all(observed_terms %in% terms_names2b) ~ "2b", all(observed_terms %in% terms_names3b) ~ "3b", all(observed_terms %in% terms_names4b) ~ "4b" ) } # case of an interaction term only if (is.na(approach)) { n1 <- .count_term(model_terms$term, terms_names1) n2 <- .count_term(model_terms$term, terms_names2) n1b <- .count_term(model_terms$term, terms_names1b) n2b <- .count_term(model_terms$term, terms_names2b) approach <- dplyr::case_when( (n1b + n2b) > (n1 + n2) & n1b >= n2b ~ "1b", (n1b + n2b) > (n1 + n2) & n1b < n2b ~ "2b", n2 > n1 ~ "2", TRUE ~ "1" ) } terms_names <- switch( approach, "1" = terms_names1, "2" = terms_names2, "3" = terms_names3, "4" = terms_names4, "1b" = terms_names1b, "2b" = terms_names2b, "3b" = terms_names3b, "4b" = terms_names4b ) if (approach %in% c("3", "3b", "4", "4b")) { sep <- "-" if (sdif_term_level == "ratio") sep <- "/" tl <- terms_levels terms_levels <- paste(tl, sep, dplyr::lag(tl)) terms_levels <- terms_levels[-1] } res <- dplyr::bind_rows( res, dplyr::tibble( variable = v, contrasts_type = contrasts_type, term = terms_names, level = terms_levels, level_rank = seq(1, length(terms_levels)), reference = seq(1, length(terms_levels)) == ref, reference_level = terms_levels[ref] ) ) } } res %>% dplyr::left_join( model %>% model_list_variables(labels = variable_labels) %>% dplyr::select(all_of(c("variable", "var_label"))), by = "variable" ) %>% dplyr::left_join( model %>% model_get_nlevels() %>% dplyr::select(all_of(c("variable", "var_nlevels"))), by = "variable" ) %>% dplyr::mutate( dichotomous = .data$var_nlevels == 2, label = stringr::str_glue_data(res, label_pattern) ) } # count the total number of times where elements of searched # are found in observed terms .count_term <- function(observed, searched) { total <- 0 for (i in searched) { total <- total + stringr::str_count( observed, paste0("(^|:)", .escape_regex(i), "(:|$)") ) %>% sum() } total } broom.helpers/R/tidy_add_pairwise_contrasts.R0000644000176200001440000001044114464175037021154 0ustar liggesusers#' Add pairwise contrasts for categorical variables #' #' `r lifecycle::badge("experimental")` #' Computes pairwise contrasts with [emmeans::emmeans()] and add them to the #' results tibble. Works only with models supported by `emmeans`, see #' `vignette("models", package = "emmeans")`. #' #' @note #' If the `contrasts` column is not yet available in `x`, #' [tidy_add_contrasts()] will be automatically applied. #' #' `r lifecycle::badge("experimental")` #' For multi-components models, such as zero-inflated Poisson or beta #' regression, support of pairwise contrasts is still experimental. #' #' @param x a tidy tibble #' @param variables a vector indicating the name of variables #' for those pairwise contrasts should be added. #' Accepts [tidyselect][dplyr::select] syntax. Default is [all_categorical()] #' @param keep_model_terms keep terms from the model? #' @param pairwise_reverse determines whether to use `"pairwise"` (if `TRUE`) #' or `"revpairwise"` (if `FALSE`), see [emmeans::contrast()] #' @param contrasts_adjust optional adjustment method when computing contrasts, #' see [emmeans::contrast()] (if `NULL`, use `emmeans` default) #' @param conf.level confidence level, by default use the value indicated #' previously in [tidy_and_attach()] #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' if (.assert_package("emmeans", boolean = TRUE)) { #' mod1 <- lm(Sepal.Length ~ Species, data = iris) #' mod1 %>% #' tidy_and_attach() %>% #' tidy_add_pairwise_contrasts() #' #' mod1 %>% #' tidy_and_attach() %>% #' tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) #' #' mod1 %>% #' tidy_and_attach() %>% #' tidy_add_pairwise_contrasts(keep_model_terms = TRUE) #' #' mod1 %>% #' tidy_and_attach() %>% #' tidy_add_pairwise_contrasts(contrasts_adjust = "none") #' #' if (.assert_package("gtsummary", boolean = TRUE)) { #' mod2 <- glm( #' response ~ age + trt + grade, #' data = gtsummary::trial, #' family = binomial #' ) #' mod2 %>% #' tidy_and_attach(exponentiate = TRUE) %>% #' tidy_add_pairwise_contrasts() #' } #' } tidy_add_pairwise_contrasts <- function( x, variables = all_categorical(), keep_model_terms = FALSE, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = attr(x, "conf.level"), emmeans_args = list(), model = tidy_get_model(x), quiet = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } if (is.null(conf.level) || !is.numeric(conf.level)) { cli::cli_abort("{.arg conf.level} is not provided. You need to pass it explicitely.") } if (!"contrasts" %in% names(x)) { x <- x %>% tidy_add_contrasts(model = model) } .attributes <- .save_attributes(x) if (isTRUE(stringr::str_starts(.attributes$coefficients_type, "marginal"))) { cli::cli_abort("Pairwise contrasts are not compatible with marginal effects / contrasts / means / predictions.") # nolint } if (is.null(conf.level)) { cli::cli_abort("Please specify {.arg conf.level}") } # obtain character vector of selected variables variables <- .select_to_varnames( {{ variables }}, var_info = x, arg_name = "variables" ) if (isTRUE(.attributes$exponentiate) && is.null(emmeans_args$type)) { emmeans_args$type <- "response" } pc <- model_get_pairwise_contrasts( model = model, variables = variables, pairwise_reverse = pairwise_reverse, contrasts_adjust = contrasts_adjust, conf.level = conf.level, emmeans_args = emmeans_args ) x <- dplyr::bind_rows(x, pc) %>% dplyr::mutate(variableF = forcats::fct_inorder(.data$variable)) %>% dplyr::arrange(.data$variableF) %>% tidyr::fill(all_of(c("var_class", "var_type", "var_nlevels"))) %>% dplyr::select(-all_of("variableF")) if (!keep_model_terms) { x <- x %>% dplyr::filter( !(.data$variable %in% variables) | .data$contrasts_type == "pairwise" ) } x %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_get_terms.R0000644000176200001440000000264114464175037016544 0ustar liggesusers#' Get the terms of a model #' #' Return the result of [stats::terms()] applied to the model #' or `NULL` if it is not possible to get terms from `model`. #' #' @param model a model object #' @export #' @family model_helpers #' @seealso [stats::terms()] #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_terms() model_get_terms <- function(model) { UseMethod("model_get_terms") } #' @export #' @rdname model_get_terms model_get_terms.default <- function(model) { tryCatch( stats::terms(model), error = function(e) { NULL } ) } #' @export #' @rdname model_get_terms model_get_terms.brmsfit <- function(model) { model$formula %>% brms::brmsterms(resp_rhs_all = FALSE) %>% purrr::pluck("allvars") %>% stats::terms() } #' @export #' @rdname model_get_terms #' @details #' For models fitted with `glmmTMB::glmmTMB()`, it will return a terms object #' taking into account all components ("cond" and "zi"). For a more #' restricted terms object, please refer to `glmmTMB::terms.glmmTMB()`. model_get_terms.glmmTMB <- function(model) { model$modelInfo$allForm$combForm %>% stats::terms() } #' @export #' @rdname model_get_terms model_get_terms.model_fit <- function(model) { model_get_terms(model$fit) } #' @export #' @rdname model_get_terms model_get_terms.betareg <- function(model) { model_get_terms(model$terms$full) } broom.helpers/R/model_get_model_frame.R0000644000176200001440000000336214357760764017675 0ustar liggesusers#' Get the model frame of a model #' #' The structure of the object returned by [stats::model.frame()] #' could slightly differ for certain types of models. #' `model_get_model_frame()` will always return an object #' with the same data structure or `NULL` if it is not possible #' to compute model frame from `model`. #' #' @param model a model object #' @export #' @family model_helpers #' @seealso [stats::model.frame()] #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) %>% #' model_get_model_frame() %>% #' head() model_get_model_frame <- function(model) { UseMethod("model_get_model_frame") } #' @export #' @rdname model_get_model_frame model_get_model_frame.default <- function(model) { tryCatch( stats::model.frame(model), error = function(e) { NULL } ) } #' @export #' @rdname model_get_model_frame model_get_model_frame.coxph <- function(model) { tryCatch( stats::model.frame.default(model), error = function(e) { NULL } ) } #' @export #' @rdname model_get_model_frame model_get_model_frame.survreg <- function(model) { tryCatch( stats::model.frame.default(model), error = function(e) { NULL # nocov } ) } #' @export #' @rdname model_get_model_frame model_get_model_frame.biglm <- function(model) { stats::model.frame( stats::formula(model), data = stats::model.frame.default(model) ) } #' @export #' @rdname model_get_model_frame model_get_model_frame.model_fit <- function(model) { model_get_model_frame(model$fit) } #' @export #' @rdname model_get_model_frame model_get_model_frame.fixest <- function(model) { stats::model.frame.default(model$fml, data = get(model$call$data, model$call_env)) } broom.helpers/R/model_get_pairwise_contrasts.R0000644000176200001440000000752614464175037021344 0ustar liggesusers#' Get pairwise comparison of the levels of a categorical variable #' #' It is computed with [emmeans::emmeans()]. #' #' @param model a model object #' @param variables names of variables to add pairwise contrasts #' @param pairwise_reverse determines whether to use `"pairwise"` (if `TRUE`) #' or `"revpairwise"` (if `FALSE`), see [emmeans::contrast()] #' @param contrasts_adjust optional adjustment method when computing contrasts, #' see [emmeans::contrast()] (if `NULL`, use `emmeans` default) #' @param conf.level level of confidence for confidence intervals #' @param emmeans_args list of additional parameter to pass to #' [emmeans::emmeans()] when computing pairwise contrasts #' @details #' `r lifecycle::badge("experimental")` #' For `pscl::zeroinfl()` and `pscl::hurdle()` models, pairwise contrasts are #' computed separately for each component, using `mode = "count"` and #' `mode = "zero"` (see documentation of `emmeans`) and a component column #' is added to the results. This support is still experimental. #' @family model_helpers #' @export #' @examplesIf interactive() #' if (.assert_package("emmeans", boolean = TRUE)) { #' mod <- lm(Sepal.Length ~ Species, data = iris) #' mod %>% model_get_pairwise_contrasts(variables = "Species") #' mod %>% #' model_get_pairwise_contrasts( #' variables = "Species", #' contrasts_adjust = "none" #' ) #' } model_get_pairwise_contrasts <- function( model, variables, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = .95, emmeans_args = list()) { UseMethod("model_get_pairwise_contrasts") } #' @export model_get_pairwise_contrasts.default <- function( model, variables, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = .95, emmeans_args = list()) { purrr::map_df( variables, .get_pairwise_contrasts_one_var, model = model, pairwise_reverse = pairwise_reverse, contrasts_adjust = contrasts_adjust, conf.level = conf.level, emmeans_args = emmeans_args ) } .get_pairwise_contrasts_one_var <- function( model, variable, pairwise_reverse = TRUE, contrasts_adjust = NULL, conf.level = .95, emmeans_args = list()) { .assert_package( "emmeans", fn = "broom.helpers::model_get_pairwise_contrasts()" ) emmeans_args$object <- model emmeans_args$specs <- variable e <- do.call(emmeans::emmeans, emmeans_args) if (is.null(contrasts_adjust)) { e <- e %>% graphics::pairs(reverse = pairwise_reverse) } else { e <- e %>% graphics::pairs(reverse = pairwise_reverse, adjust = contrasts_adjust) } r <- e %>% dplyr::as_tibble() if (!is.numeric(r[[2]])) { # if by r <- r %>% tidyr::unite("term", 1:2, sep = " | ") } r <- r[, c(1:3, ncol(r) - 1, ncol(r))] colnames(r) <- c( "term", "estimate", "std.error", "statistic", "p.value" ) ci <- stats::confint(e, level = conf.level) %>% dplyr::as_tibble() if (!is.numeric(ci[[2]])) { # if by ci <- ci %>% tidyr::unite("term", 1:2, sep = " | ") } ci <- ci[, c(1, ncol(ci) - 1, ncol(ci))] colnames(ci) <- c("term", "conf.low", "conf.high") r <- dplyr::left_join(r, ci, by = "term") r$variable <- variable r$contrasts <- ifelse(pairwise_reverse, "pairwise", "revpairwise") r$contrasts_type <- "pairwise" r %>% dplyr::relocate(dplyr::all_of("variable")) } #' @export model_get_pairwise_contrasts.zeroinfl <- function(model, ...) { cli::cli_abort(c( "Pairwise contrasts are not supported for multi-components model.", "Use directly {.fn emmeans::emmeans}." )) } #' @export model_get_pairwise_contrasts.hurdle <- model_get_pairwise_contrasts.zeroinfl #' @export model_get_pairwise_contrasts.betareg <- model_get_pairwise_contrasts.zeroinfl broom.helpers/R/tidy_add_reference_rows.R0000644000176200001440000001713414463417025020242 0ustar liggesusers#' Add references rows for categorical variables #' #' For categorical variables with a treatment contrast #' ([stats::contr.treatment()]), a SAS contrast ([stats::contr.SAS()]) #' a sum contrast ([stats::contr.sum()]), or successive differences contrast #' ([MASS::contr.sdif()]) add a reference row. #' #' The added `reference_row` column will be equal to: #' #' * `TRUE` for a reference row; #' * `FALSE` for a normal row of a variable with a reference row; #' * `NA` for variables without a reference row. #' #' If the `contrasts` column is not yet available in `x`, #' [tidy_add_contrasts()] will be automatically applied. #' #' `tidy_add_reference_rows()` will not populate the label #' of the reference term. It is therefore better to apply #' [tidy_add_term_labels()] after `tidy_add_reference_rows()` #' rather than before. Similarly, it is better to apply #' `tidy_add_reference_rows()` before [tidy_add_n()]. #' @param x a tidy tibble #' @param no_reference_row a vector indicating the name of variables #' for those no reference row should be added. #' Accepts [tidyselect][dplyr::select] syntax. Default is `NULL`. #' See also [all_categorical()] and [all_dichotomous()] #' @param model the corresponding model, if not attached to `x` #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf interactive() #' if (.assert_package("gtsummary", boolean = TRUE)) { #' df <- Titanic %>% #' dplyr::as_tibble() %>% #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' res <- df %>% #' glm( #' Survived ~ Class + Age + Sex, #' data = ., weights = .$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.SAS") #' ) %>% #' tidy_and_attach() #' res %>% tidy_add_reference_rows() #' res %>% tidy_add_reference_rows(no_reference_row = all_dichotomous()) #' res %>% tidy_add_reference_rows(no_reference_row = "Class") #' #' glm( #' response ~ stage + grade * trt, #' gtsummary::trial, #' family = binomial, #' contrasts = list( #' stage = contr.treatment(4, base = 3), #' grade = contr.treatment(3, base = 2), #' trt = contr.treatment(2, base = 2) #' ) #' ) %>% #' tidy_and_attach() %>% #' tidy_add_reference_rows() #' } tidy_add_reference_rows <- function( x, no_reference_row = NULL, model = tidy_get_model(x), quiet = FALSE) { if (is.null(model)) { cli::cli_abort(c( "{.arg model} is not provided.", "You need to pass it or to use {.fn tidy_and_attach}." )) } .attributes <- .save_attributes(x) # adding reference rows is not meaningful for stats::aov if (inherits(model, "aov")) { return(x %>% dplyr::mutate(reference_row = NA)) } # checking cases where adding reference rows is not meaningful if (isTRUE(.attributes$skip_add_reference_rows)) { return(x %>% dplyr::mutate(reference_row = NA)) } if ("header_row" %in% names(x)) { cli::cli_abort(paste( "{.fn tidy_add_reference_rows} cannot be applied", "after {.fn tidy_add_header_rows}." )) } if ("reference_row" %in% names(x)) { if (!quiet) { cli_alert_danger(paste( "{.code tidy_add_reference_rows()} has already been applied.", "x has been returned unchanged." )) } return(x) } if ("label" %in% names(x)) { if (!quiet) { cli_alert_info(paste0( "tidy_add_reference_rows() has been applied after tidy_add_term_labels().\n", "You should consider applying tidy_add_reference_rows() first." )) } } if ("n_obs" %in% names(x)) { if (!quiet) { cli_alert_info(paste0( "{.code tidy_add_reference_rows()} has been applied after {.code tidy_add_n()}.\n", "You should consider applying {.code tidy_add_reference_rows()} first." )) } } if (!"contrasts" %in% names(x)) { x <- x %>% tidy_add_contrasts(model = model) } # obtain character vector of selected variables no_reference_row <- .select_to_varnames( {{ no_reference_row }}, var_info = x, arg_name = "no_reference_row" ) terms_levels <- model_list_terms_levels(model) if (!is.null(terms_levels)) { terms_levels <- terms_levels %>% # keep only terms corresponding to variable in x # (e.g. to exclude interaction only variables) dplyr::filter( .data$variable %in% unique(stats::na.omit(x$variable)) & # and exclude variables in no_reference_row !.data$variable %in% no_reference_row ) } if (is.null(terms_levels) || nrow(terms_levels) == 0) { return( x %>% dplyr::mutate(reference_row = NA) %>% tidy_attach_model(model) ) } terms_levels <- terms_levels %>% dplyr::group_by(.data$variable) %>% dplyr::mutate(rank = seq_len(dplyr::n())) has_var_label <- "var_label" %in% names(x) if (!has_var_label) { x$var_label <- NA_character_ } # temporary populate it x <- x %>% dplyr::mutate( reference_row = dplyr::if_else( .data$variable %in% unique(terms_levels$variable), FALSE, NA ), rank = seq_len(dplyr::n()) # for sorting table at the end ) group <- NULL if ("component" %in% names(x)) { group <- "component" } if ( "y.level" %in% names(x) && # specific case for multinomial models (inherits(model, "multinom") || inherits(model, "LORgee")) ) { group <- "y.level" } if (!is.null(group)) { x$.group_by_var <- x[[group]] } else { x$.group_by_var <- "" } ref_rows <- terms_levels %>% dplyr::filter(.data$reference) %>% dplyr::mutate(reference_row = TRUE) %>% dplyr::select(dplyr::all_of(c("term", "variable", "label", "reference_row", "rank"))) if (!"label" %in% names(x)) { ref_rows <- ref_rows %>% dplyr::select(-all_of("label")) } # populate effect column for mixed models tmp <- x if (!"effect" %in% names(x)) { tmp$effect <- NA_character_ } var_summary <- tmp %>% dplyr::group_by(.data$.group_by_var, .data$variable) %>% dplyr::summarise( var_class = dplyr::first(.data$var_class), var_type = dplyr::first(.data$var_type), var_label = dplyr::first(.data$var_label), var_nlevels = dplyr::first(.data$var_nlevels), effect = dplyr::first(.data$effect), contrasts = dplyr::first(.data$contrasts), contrasts_type = dplyr::first(.data$contrasts_type), var_min_rank = min(.data$rank), var_max_rank = min(.data$rank), .groups = "drop_last" ) ref_rows <- ref_rows %>% dplyr::left_join( var_summary, by = "variable" ) %>% dplyr::mutate( rank = .data$var_min_rank - 1.25 + .data$rank, # if last, reduce by .5 to avoid overlap with next variable rank = dplyr::if_else( .data$rank > .data$var_max_rank, .data$rank - .5, .data$rank ) ) %>% dplyr::select(-dplyr::all_of(c("var_min_rank", "var_max_rank"))) if (!"effect" %in% names(x)) { ref_rows <- ref_rows %>% dplyr::select(-dplyr::all_of("effect")) } x <- x %>% dplyr::bind_rows(ref_rows) if (!is.null(group)) { x[[group]] <- x$.group_by_var } x <- x %>% dplyr::select(-dplyr::all_of(".group_by_var")) if (!has_var_label) { x <- x %>% dplyr::select(-dplyr::all_of("var_label")) } x %>% dplyr::arrange(.data$rank) %>% dplyr::select(-dplyr::all_of("rank")) %>% tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/NEWS.md0000644000176200001440000003157314464203244014143 0ustar liggesusers# broom.helpers 1.14.0 **New features** - support for `MASS::contr.sdif()` contrasts (#230) - support for `pscl::zeroinfl()` and `pscl::hurdle()` models (#232) - support for `betareg::betareg()` models (#234) **Fix** - input of `packageVersion()` should be a character string (#225) # broom.helpers 1.13.0 **New features** - `tidy_add_estimate_to_reference_rows()` now also populate p-values and confidence intervals for sum contrasts (#220) - Marginal tidiers are now compatible with `nnet::multinom()`, `MASS::polr()`, `ordinal::clm()` and `ordinal::clmm()` models, as long as the type of models is supported by the corresponding package, for example, `margins` does not currently support `nnet::multinom()` models (#215) **Improvements** - Marginal predictions vignette has been updated to follow changes in `marginaleffects` version 0.10.0 (#216) # broom.helpers 1.12.0 **New features** - Set of functions to support marginal predictions, contrasts and slopes / effects (#202): - A dedicated article presenting the concepts and the different functions has been added to the package documentation website - Several tidiers are provided to tidy results in a way that it could be used by `broom.helpers` functions. - **Marginal Predictions:** `tidy_marginal_predictions()`, `plot_marginal_predictions()`, `tidy_all_effects()`, and `tidy_ggpredict()` - **Marginal Means:** `tidy_marginal_means()` - **Marginal Contrasts:** `tidy_avg_comparisons()` and `tidy_marginal_contrasts()` - **Marginal Effects:** `tidy_avg_slopes()` and `tidy_margins()` - New method `model_list_higher_order_variables()` to list the highest order combinations of variables (#202) - New method `model_get_response_variable()` to get the name of the response variable (#202) - New helper function `seq_range()` to generate a sequence of values between the minimum and the maximum of a vector (#202) - New argument `contrasts_adjust` in `tidy_plus_plus()`, `tidy_add_pairwise_contrasts()` and `model_get_pairwise_contrasts()` allowing to change the adjustment method used to compute pairwise contrasts (#204) # broom.helpers 1.11.0 **New features** - New functions `tidy_add_pairwise_contrasts()` and `model_get_pairwise_contrasts()` to compute pairwise contrasts of categorical variables with `emmeans`, and corresponding new arguments in `tidy_plus_plus()` (#192) - New tidier `tidy_margins()` to display Average Marginal Effects (#195) - New tidier `tidy_all_effects()` to display Marginal Predictions (#195) - New tidier `tidy_ggpredict()` to display Conditional Predictions (#195) **Bug fixes and improvements** - Better messages when `exponentiate` argument is not appropriate (#197) # broom.helpers 1.10.0 **New features** - `tidy_select_variables()` now sorts the variables according to `include` (#183) **New supported models** - Support for `logitr::logitr()` models (#179) - Experimental support for `multgee::nomLORgee()` and `multgee::ordLORgee()` models (#185) **Bug fixes and improvements** - Improvement of `.get_package_dependencies()` to be more efficient. It now looks only at a single package description file (#178) - New function `.get_all_packages_dependencies()` to list all dependencies of all packages (#178) - Bug fix in `.get_min_version_required()` (#181) # broom.helpers 1.9.0 **New features** - New function `.get_package_dependencies()` listing all dependencies, including minimum version required, of a package. (#171) - Improvement of `.assert_package()` now taking into account the comparison operator (> or >=) when a minimum version is required (#171) **Bug fixes and improvements** - Compatibility with upcoming `tidyselect` v1.2.0 (#173) - Avoid an unwanted warning for some `mgcv::gam()` models (#175) # broom.helpers 1.8.0 **New supported models** - Support for `parsnip::model_fit` objects (#161) - Support for `biglm::bigglm()` and `biglmm::bigglm()` models (#155) - Support for `fixest::feglm()`, `fixest::femlm()`, `fixest::feols()` and `fixest::feNmlm()` (requires R>=4.1) (#167) **New features** - Support for `dplyr::vars()` (also exported by {gtsummary}) as a selector has now been deprecated. Users will be warned that support for `vars()` will eventually be removed from the package (#154) - `.is_selector_scoped()`, an internal function used in generating custom selector functions, is now exported (#163) # broom.helpers 1.7.0 **New features** - The `.assert_package()` now uses `rlang::check_installed()` and `rlang::is_installed()` to check whether needed packages are installed. The `rlang::check_installed()` prompts user to install needed package when run interactively. (#147) - `tidy_add_n()` and `model_get_n()` support for `tidycmprsk::crr()` models (#143) - Listing of supported models is now available in `supported_models` tibble (#145) **Bug fixes** - Avoiding duplicating rows when applying `tidy_add_n()` to a `mgcv::gam()` model with smooth terms (#150) # broom.helpers 1.6.0 **New supported models** - Support for `plm::plm()` models (#140) **New features** - The `.formula_list_to_named_list()` now respects the `select_single=` argument for all inputs types. Previously, named lists were ignored. - Added new argument `.formula_list_to_named_list(null_allowed=)` argument that works in conjunction with `type_check=` asserting the class/type of the RHS of the formula (or the value of the named list) (#137) - Better error message in `.formula_list_to_named_list()` (#136) - Two additional select helpers `all_ran_pars()` and `all_ran_vals()` **Bug fixes** - Fix so `.formula_list_to_named_list(type_check=)` checks RHS of a formula and the value of named list. (#138) # broom.helpers 1.5.0 **New features** - New method `model_get_coefficients_type.tidycrr()` (#128) - Updated error messaging about using `broom.helpers::tidy_parameters()` to include the package prefix. This message sometimes appears while running `gtsummary::tbl_regression()` where some users may not be aware where the `tidy_paramters()` function lives. (#129) - `.formula_list_to_named_list()` improvement: it is now possible to add a type check (#132) - New functions `.assert_package()` and `.get_min_version_required()` to check for a package's installation status and whether the installed version meets the minimum required version from the DESCRIPTION file (#134) **Bug fixes** - Bug fix for identifying the levels of a logical variable (#125) - Bug fix for `nnet::multinom()` models with a binary outcome (#130) # broom.helpers 1.4.0 **New supported models** - Support for `glmmTMB::glmmTMB()` models (#119) **New features** - Function arguments that accept formula-list values now have more flexible inputs. (#121) - The passed list may now be a combination of named lists and lists of formulas, e.g. `list(trt ~ 1, all_continuous() ~ 2)`. - The shortcut `~ ` may be now used to indicate `everything() ~ ` **Bug fixes** - Bug fix for computing n for some binomial models computed with `lme4::glmer()` (#116) - Populating **effect** column when adding reference rows (#117) # broom.helpers 1.3.0 **New supported models** - Support of `rstanarm::stan_glm()` models - Basic support for `VGAM::vglm()` models (#105) **New features** - Custom tieder `tidy_parameters()` based on `parameters::model_parameters()` (#104) - Custom tieder `tidy_with_broom_or_parameters()` (#104) - By default, `tidy_plus_plus()` now uses `tidy_with_broom_or_parameters()` - `model_get_coefficients_type()` now returns "prop_hazard" for cloglog-binomial models (#106) # broom.helpers 1.2.1 **Bug fixes** - Better identification of term labels for interaction terms using sum contrasts (#108) - Now `tidy_add_n()` works with multinomial models when `y` is not coded as a factor (#109) - `glue` added to Suggests # broom.helpers 1.2.0 **New features** - `model_get_coefficients_type()` now returns "relative_risk" for log-binomial models (#101) - New function `tidy_disambiguate_terms()` for disambiguating random-effect terms in mixed models and new options for `tidy_plus_plus()`: `disambiguate_terms` (`TRUE` by default) and `disambiguate_sep` (#98) - For mixed models, `var_type` column is now equal to `"ran_pars"` or `"ran_vals"` for random-effect parameters and values, based of the `effect` column returned by `broom.mixed::tidy()` (#90) - New contrasts type ("no.contrast") returned by `model_list_contrasts`() - New function `tidy_add_n()` to add the number of observations (and for relevant models the number of events and exposure time) (#64) - New option `add_n` in `tidy_plus_plus()` (#64) - New functions `model_get_n()`, `model_get_weights()`, `model_get_offset()`, `model_get_response()` and `model_compute_terms_contributions()` (#64) **New supported models** - Support of `lfe::felm()` models (#79) - Support of `brms::brm()` models (#89) - Basic support of `cmprsk::crr()` models (#91) - Basic support of `stats::nls()` models (#97) - Models with categorical variable and no intercept now supported (#85) - Added support for `mgcv::gam()` models. (#82) **Bug fixes and other changes** - *Minor breaking change:* `strict` argument removed from `tidy_identify_variables()` (#99) - Replaced `usethis::ui_*()` messaging with `cli::cli_*()` (#94) - Bug fix in `tidy_add_term_labels()` for variables with non standard names (#77) - Fix in vignette for old versions of `rmarkdown` (#95) # broom.helpers 1.1.0 * **Minor breaking change:** column `var_type` returned by `tidy_identify_variables()` is now equal to `"dichotomous"` for categorical variables with only 2 levels * **Minor breaking changes:** for intercepts terms, `tidy_identify_variables()` now populates `variable` column by `term` content, instead of `NA` (#66) * **Minor breaking change:** If the variables can't be identified by `tidy_identify_variables()`, the `variable` column is now populated with the content of the `term` column (#63) * Exporting select helper utility functions (#65) - `.generic_selector()`: makes it easy to create selecting functions like `all_continuous()`. - `.select_to_varnames()`: converts selecting syntax into character varnames - `.formula_list_to_named_list()`: takes the formula selecting syntax and converts it to a named list. * New selecting functions `all_continuous()`, `all_categorical()`, `all_dichotomous()`, `all_contrasts()`, `all_intercepts()` and `all_interaction()` for selecting variables from models (#54) * Added support for multiple imputation models from the {mice} package. The model passed must be the un-pooled models, and the pooling step included in `tidy_fun=` (#49 @ddsjoberg) * New function `tidy_select_variables()` to keep/drop selected variables in the output (#45) * New functions `tidy_add_coefficients_type()` and `model_get_coefficients_type` to get the type of coefficients (generic, logistic, Poisson or proportional hazard) used by a model (#46) * `tidy_add_contrasts()` and `model_list_contrasts()` now return an additional column `contrasts_type` * New `no_reference_row` argument for `tidy_add_reference_rows()` (#47) * New method `model_get_nlevels` to get the number of levels of categorical variables * New column `var_nlevels` returned by `tidy_identify_variables()`, `model_identify_variables()` and `tidy_plus_plus()` * Categorical terms can now be customized with a pattern taking into account term level, reference level and/or variable label, see `model_list_terms_levels()` and `categorical_terms_pattern` in `tidy_plus_plus()` and `tidy_add_term_labels` (#61) * `model_list_terms_levels()` now returns additional columns (`level`, `reference_level`, `contrasts_type`, `var_label`, `var_levels` and `dichotomous`) * `model_list_variables()` now returns an additional `var_label` column * The `exponentiate` argument is now passed to the `tidy_*()` functions, as an attribute attached to the tibble, as well as custom labels (`variable_labels` and `term_labels`) * `show_single_row` argument now accepts tidyselect notation (#51 @ddsjoberg) * `tidy_add_estimate_to_reference_rows()` now relies on `emmeans` for sum contrasts, allowing to cover a wider range of models * Tibbles returned by `tidy_*` functions also inherits of `"broom.helpers"` class (#56) * `interaction_sep` argument has been added to `tidy_plus_plus()` * Better management of variables with non standard names (#67) * `.clean_backticks()` and `.escape_regex()` are now exported * Bug fix for non standard variable names containing a character that would have a special meaning in a regular expression (#44) * Bug fix in `tidy_add_header_rows()` for `nnet::multinom` models: label for header rows was missing (#50) * Bug fix: now `tidy_identify_variables()` correctly identify class "integer" for this type of variables (#57) * Bug fix for `tidy_add_header_rows()` for continuous variables with a non standard name (#70) # broom.helpers 1.0.0 * Initial version broom.helpers/MD50000644000176200001440000002222314464210122013336 0ustar liggesusers333b8a8a70cb0a792965bd153687bc15 *DESCRIPTION a311b065522b605dd99b2f74e0d51fcb *NAMESPACE dd0adac2b38e19fb68b14ad7ea8f7000 *NEWS.md 7b5eba2fa2a32973e8f6996f5d8de6db *R/assert_package.R bad0cbea6de33f2f59149b4a382a966b *R/broom.helpers-package.R 3e3e7545b69ba8bea0672d2d9eafea1b *R/custom_tidiers.R 55c01d0cb58801ae0da3678caab51782 *R/data.R ccc9525cddbbc92f28f9357c5ff17f7b *R/helpers.R de35deef1dcbc9ef37715cb848abf932 *R/marginal_tidiers.R e3df20e38250ac138aae66ba44a343cf *R/model_compute_terms_contributions.R 289f040ab75a4a5793b0d674e52c7d9f *R/model_get_assign.R 5d65bbd3df8388af2bc6aaa0f9785a30 *R/model_get_coefficients_type.R ce2894c62ba73bc56d039cffe8147c9d *R/model_get_contrasts.R f105b060e6bcead9148c8b4336c7a730 *R/model_get_model.R c816cbd6c0548e3da94317f25b878c19 *R/model_get_model_frame.R 8c72e753b78a9e8a6b7635dafb320020 *R/model_get_model_matrix.R 1d4f6cd9448c1948871af1ec0a33bad8 *R/model_get_n.R dfdc3e5f345ddceba20136a024bbbd22 *R/model_get_nlevels.R af6bbc2767e3b0e9f9b6acf9c474d2c5 *R/model_get_offset.R 2a7043a7b2e4979018992c82e821cb58 *R/model_get_pairwise_contrasts.R 3bcd600cee98893da3003c5f8de435c0 *R/model_get_response.R 9cc4eb1258ba5be7a9cc654e69ae8a03 *R/model_get_response_variable.R d430c20d51a836b9359573a3d9fa407b *R/model_get_terms.R 0bef6e81fe461707fee13bae23cc02fb *R/model_get_weights.R 7a2a5b94562995a8d77a1d703a9874c7 *R/model_get_xlevels.R 04cd83fafb1e4ba723b28e92f8d32b4e *R/model_identify_variables.R ca0f6f66d3291fd89c4b3268c7f56717 *R/model_list_contrasts.R 411f68112001475b9d48c009987b0cec *R/model_list_higher_order_variables.R bcc0cae080ca3629f45622a6bc26bc1a *R/model_list_terms_levels.R 39b319918eb77a8e9dc77e6237739d40 *R/model_list_variables.R ead9221ff979fb42c6db4642ef3afd2b *R/reexport.R 8397c6a2bf21ba8dfd34f7f2c34f3349 *R/select_helpers.R 20d690f3f37157896cc08586d7c46cec *R/select_utilities.R dd98b1ff35f16ee0def1e0252d8147f0 *R/tidy_add_coefficients_type.R 374e298de182bb953f39154aaed559c7 *R/tidy_add_contrasts.R e20dfec746f2b8bd2ae6d82312a325b2 *R/tidy_add_estimate_to_reference_rows.R 324864e24ddce820b15403d50f0d143b *R/tidy_add_header_rows.R 2b48437c27b810d95741e6aab4300866 *R/tidy_add_n.R 6c6389eb79d88727b85c6a5c4e49e48a *R/tidy_add_pairwise_contrasts.R 2cc730265f4ae3aaf546cec82196aa3c *R/tidy_add_reference_rows.R 2db77fa95989ff6132246a1c851e747c *R/tidy_add_term_labels.R a73400d5b0d3e550e77044da68ba8129 *R/tidy_add_variable_labels.R 613a88fd9b27182891c81853431d7f50 *R/tidy_and_attach.R 3357861c65a9e63854a2c90bb383f808 *R/tidy_disambiguate_terms.R 524bda5ecb80c5ea0910897e1b764cf8 *R/tidy_identify_variables.R cde3ea26dc3b6a139f603ee8d712b50a *R/tidy_plus_plus.R e78b961615a560392ce86192fa637b80 *R/tidy_remove_intercept.R 6c67c70a5ad9f0f53d6b29d374e52067 *R/tidy_select_variables.R 4dd93f1bdff7b0042223da82a812d438 *README.md 3fbadbbf1582480804098a1b10ab07df *build/vignette.rds 519e32a27c005996a22afabc78168f61 *data/supported_models.rda f0fe951ab03584c95b9733d4d3df4111 *inst/WORDLIST bb2852d81752a9ec05ea99dd0147e775 *inst/doc/tidy.R a1c137cfc94518e94c745c1456de1759 *inst/doc/tidy.Rmd bda2444ebdbd704c82a668d992a533b4 *inst/doc/tidy.html cd12fe7759d0fd2b9e4db888db3f947e *man/assert_package.Rd 06372147e996f209fdb065b9cecd77e2 *man/dot-clean_backticks.Rd c0b5e4ac4f4dba1899e2406440e65ead *man/dot-escape_regex.Rd 4942bd0d1be0c504dfa7836520f664b9 *man/dot-formula_list_to_named_list.Rd 562b3d2337d92f32d2538f90bed1e111 *man/dot-generic_selector.Rd 578d6e138ea51cc32d32fabb69b860e6 *man/dot-select_to_varnames.Rd 30e674427c4e49f6c860aeeb51efcf0e *man/figures/broom.helpers.png e408d5625c4dc2036468b549ce3c82e8 *man/figures/broom.helpers.svg cb1e46f469cfbbbde29c8b5113e1d789 *man/figures/lifecycle-archived.svg c0d2e5a54f1fa4ff02bf9533079dd1f7 *man/figures/lifecycle-defunct.svg a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg 952b59dc07b171b97d5d982924244f61 *man/figures/lifecycle-maturing.svg 27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg 6902bbfaf963fbc4ed98b86bda80caa2 *man/figures/lifecycle-soft-deprecated.svg 53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg 1c1fe7a759b86dc6dbcbe7797ab8246c *man/figures/lifecycle-superseded.svg e3a9cf22ccc0e18ae71e53df9afeee35 *man/model_compute_terms_contributions.Rd afdc9a4a31dc1c3ce58e4d9b000ba9a9 *man/model_get_assign.Rd 882133df93fd30895d36614359a4a503 *man/model_get_coefficients_type.Rd 39a6e0c6466b40d073d433cfdcdd210f *man/model_get_contrasts.Rd 1bf5a97841d65647cf347e27812438e8 *man/model_get_model.Rd 9d13289619d2b987bf4c73765dbeeec4 *man/model_get_model_frame.Rd 539481408d3d853bf8f5d9969a88fbe1 *man/model_get_model_matrix.Rd 5d4a916bf664f979bb2a1a5693ffd203 *man/model_get_n.Rd 617291daa00240ae996a13fccd0116a9 *man/model_get_nlevels.Rd 905343bd64de2c14b40d3dde941ec4b4 *man/model_get_offset.Rd 6e6c88413fb89bd8a68b15b3b20e67f2 *man/model_get_pairwise_contrasts.Rd e826919ffa9e03715c545d1c628f6834 *man/model_get_response.Rd 4b67d7fba5e3bfd43149901f2182dd17 *man/model_get_response_variable.Rd 2cf8008e9abd6eab1a28867d099188af *man/model_get_terms.Rd c5333a869514dc238fd04b992e83b4cd *man/model_get_weights.Rd fb9f079200c1b55c3e88e613b62685ff *man/model_get_xlevels.Rd 97c6e6f057d9dedf67f34dcea9f3c027 *man/model_identify_variables.Rd f895805ac319238fdcd2ed4d64114cf2 *man/model_list_contrasts.Rd e75fe08e917df0050727ae71fac9d86d *man/model_list_higher_order_variables.Rd 46917c85cbd9259e6cf4cb06a5996524 *man/model_list_terms_levels.Rd 6c4feb99120c0fff2aefd06050149569 *man/model_list_variables.Rd 292d9eca9d61bcfd1ba9067445e2c463 *man/reexports.Rd 62ddc12f88d8a7ba2f9fd7112b0fe938 *man/select_helpers.Rd 11c5d1ecf30abc5b6c5c055f5033a33d *man/seq_range.Rd 1c05ad3101144846aee15d9f93a492af *man/supported_models.Rd 4b8f05cb09b7d4346a1c839c61125076 *man/tidy_add_coefficients_type.Rd b27d5761799377b09f35866ae76067c6 *man/tidy_add_contrasts.Rd c954d9d4e1e8073232060727be868623 *man/tidy_add_estimate_to_reference_rows.Rd 4f3454bd1cf4202be649c9867e530a10 *man/tidy_add_header_rows.Rd b8c72e31a46bb390c4a54f2ac056a12b *man/tidy_add_n.Rd 97ac63e309a43bd881ccd43becb997b0 *man/tidy_add_pairwise_contrasts.Rd 519a22d0d5c5ca30d4a745d25e556e9d *man/tidy_add_reference_rows.Rd ac088e7f4089c4b29fd5256e0f816714 *man/tidy_add_term_labels.Rd 802f639148d878b1d3a025c03c297dd1 *man/tidy_add_variable_labels.Rd 95ca65d0d9e1160ab898a9b2001daf82 *man/tidy_all_effects.Rd 63f85e2c1c6f56b5dbf39a4f5cf5383d *man/tidy_attach_model.Rd 68e62a85310b0b020f3246760cd4c8be *man/tidy_avg_comparisons.Rd 17636852c2d2acd190e53da6d343939f *man/tidy_avg_slopes.Rd 8e1d552c00b10206dfc7681cd09a7d84 *man/tidy_broom.Rd 78171d3c2167b609b8e1d7df9c573ac6 *man/tidy_disambiguate_terms.Rd dbb80d2e69a64877a7b8bb8af6a0a25d *man/tidy_ggpredict.Rd c35a1aab2229b9f194d34b27e1057370 *man/tidy_identify_variables.Rd 8b951625f9036a384b246d842084ca29 *man/tidy_marginal_contrasts.Rd 532a8060ad7988ae33a32090f818011f *man/tidy_marginal_means.Rd 67a84c508cc80496e33c21497c4dd0aa *man/tidy_marginal_predictions.Rd 43e60f71b97e0c2053a61657ee4e3ace *man/tidy_margins.Rd f85c3fa5a275bbd52f588ac03a2131f1 *man/tidy_multgee.Rd e72c0f77e88a319b56779833db5f318a *man/tidy_parameters.Rd bf425408944832a0825acd1f098d26d8 *man/tidy_plus_plus.Rd 8a742e5aaba934f1d0ce847a18f13b4e *man/tidy_remove_intercept.Rd 28300794cc2c4683217a0806834d8fa5 *man/tidy_select_variables.Rd 37003f47d96eff694e41870639d29c49 *man/tidy_with_broom_or_parameters.Rd 8f067ffb1fae820c5a8d5b901717c917 *man/tidy_zeroinfl.Rd dbd9bab057163c01c320d0b9d3bb9620 *tests/spelling.R 317e945de64265e47d44552f7ca94095 *tests/testthat.R a57ee1bd31fa1249aacfd48722ad39f2 *tests/testthat/test-add_coefficients_type.R 7f761b3a669fb12ae370db12c153c445 *tests/testthat/test-add_contrasts.R dbc2b58cd1727cd6044962815832e1b7 *tests/testthat/test-add_estimate_to_reference_rows.R aacee99f48b7f0fdf1a83d26114b9bf3 *tests/testthat/test-add_header_rows.R f51dabeb8a4909f5c6ba49c163478d05 *tests/testthat/test-add_n.R ccf970868e4d4a9dc68f2a2f013cefb5 *tests/testthat/test-add_pairwise_contrasts.R a54a0211c1082f52ee671a0613643ece *tests/testthat/test-add_reference_rows.R e040fedc18c12ca0eff31955be1ea149 *tests/testthat/test-add_term_labels.R eec8b31cc4ce7f0cd379f334b61f2e3e *tests/testthat/test-add_variable_labels.R e74a8402ab64b07c4331019576b6ead3 *tests/testthat/test-assert_package.R de2b6db544a0b0455c2d86bbb19c6994 *tests/testthat/test-attach_and_detach.R b1a7ece71d39d3310597ef830bbc3c0d *tests/testthat/test-disambiguate_terms.R d767557c9352c17d9d224674e58d4952 *tests/testthat/test-get_response_variable.R 1de83f7f3a90fddc84a81d3e1ca2c731 *tests/testthat/test-helpers.R 78cff78d4d4cbf27162e6a28ce2d4f97 *tests/testthat/test-identify_variables.R 6dcf916f812ed123a61b65eb8bada35e *tests/testthat/test-list_higher_order_variables.R ee9121b0aa7cf90f6c8cff932d9beb38 *tests/testthat/test-marginal_tidiers.R 0b8f4e4258417a7bbecaf119d9c52987 *tests/testthat/test-model_get_n.R 96a704b313e855c784c88e02dc0ccd5f *tests/testthat/test-remove_intercept.R 72d870cf3586fdfa70bf2983b5c2696b *tests/testthat/test-select_helpers.R 281aa4c0d3aa8b77c8b3771e0c70386b *tests/testthat/test-select_variables.R 3fb6914aae29aba0be300c722694231c *tests/testthat/test-tidy_parameters.R f79346e95ecf413d9e374118f86c4f0c *tests/testthat/test-tidy_plus_plus.R a1c137cfc94518e94c745c1456de1759 *vignettes/tidy.Rmd broom.helpers/inst/0000755000176200001440000000000014464203464014015 5ustar liggesusersbroom.helpers/inst/doc/0000755000176200001440000000000014464203464014562 5ustar liggesusersbroom.helpers/inst/doc/tidy.R0000644000176200001440000002612314464203462015660 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>", rows.print = 25 ) # one of the functions below needs emmeans, so dont evaluate code check in vignette # on old R versions where emmeans is not available if (!rlang::is_installed("emmeans")) { knitr::opts_chunk$set(eval = FALSE) } ## ----setup, warning=FALSE, message=FALSE-------------------------------------- library(broom.helpers) library(gtsummary) library(ggplot2) library(dplyr) # paged_table() was introduced only in rmarkdwon v1.2 print_table <- function(tab) { if (packageVersion("rmarkdown") >= "1.2") { rmarkdown::paged_table(tab) } else { knitr::kable(tab) } } ## ----------------------------------------------------------------------------- model_logit <- glm(response ~ trt + grade, trial, family = binomial) broom::tidy(model_logit) ## ----------------------------------------------------------------------------- tidy_forest <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding a reference value to appear in plot tidy_add_estimate_to_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # removing intercept estimate from model tidy_remove_intercept() tidy_forest ## ---- warning=FALSE----------------------------------------------------------- tidy_forest %>% mutate( plot_label = paste(var_label, label, sep = ":") %>% forcats::fct_inorder() %>% forcats::fct_rev() ) %>% ggplot(aes(x = plot_label, y = estimate, ymin = conf.low, ymax = conf.high, color = variable)) + geom_hline(yintercept = 1, linetype = 2) + geom_pointrange() + coord_flip() + theme(legend.position = "none") + labs( y = "Odds Ratio", x = " ", title = "Forest Plot using broom.helpers" ) ## ----------------------------------------------------------------------------- tidy_table <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # add header row tidy_add_header_rows() %>% # removing intercept estimate from model tidy_remove_intercept() # print summary table options(knitr.kable.NA = "") tidy_table %>% # format model estimates select(label, estimate, conf.low, conf.high, p.value) %>% mutate(across(all_of(c("estimate", "conf.low", "conf.high")), style_ratio)) %>% mutate(across(p.value, style_pvalue)) %>% print_table() ## ----------------------------------------------------------------------------- model_logit %>% tidy_plus_plus(exponentiate = TRUE) ## ----------------------------------------------------------------------------- model_logit %>% tidy_plus_plus(exponentiate = TRUE) %>% print_table() ## ----------------------------------------------------------------------------- model_poly <- glm(response ~ poly(age, 3) + ttdeath, na.omit(trial), family = binomial) model_poly %>% tidy_plus_plus( exponentiate = TRUE, add_header_rows = TRUE, variable_labels = c(age = "Age in years") ) %>% print_table() ## ----------------------------------------------------------------------------- model_1 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial ) model_1 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ## ----------------------------------------------------------------------------- model_2 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) model_2 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ## ----------------------------------------------------------------------------- model_3 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sum, grade = contr.sum, trt = contr.sum ) ) model_3 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ## ----------------------------------------------------------------------------- model_4 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.poly, grade = contr.helmert, trt = contr.poly ) ) model_4 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ## ----------------------------------------------------------------------------- model_logit <- glm(response ~ age + trt + grade, trial, family = binomial) model_logit %>% tidy_and_attach() %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(keep_model_terms = TRUE) %>% print_table() ## ---- echo=FALSE-------------------------------------------------------------- # nolint start tibble::tribble( ~Column, ~Function, ~Description, "original_term", "`tidy_disambiguate_terms()`, `tidy_multgee()` or `tidy_zeroinfl()`", "Original term before disambiguation. This columns is added only when disambiguation is needed (i.e. for mixed models). Also used for \"multgee\", \"zeroinfl\" and \"hurdle\" models.", "variable", "`tidy_identify_variables()`", "String of variable names from the model. For categorical variables and polynomial terms defined with `stats::poly()`, terms belonging to the variable are identified.", "var_class", "`tidy_identify_variables()`", "Class of the variable.", "var_type", "`tidy_identify_variables()`", "One of \"intercept\", \"continuous\", \"dichotomous\", \"categorical\", \"interaction\", \"ran_pars\" or \"ran_vals\"", "var_nlevels", "`tidy_identify_variables()`", "Number of original levels for categorical variables", "contrasts", "`tidy_add_contrasts()`", "Contrasts used for categorical variables.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "contrasts_type", "`tidy_add_contrasts()`", "Type of contrasts (\"treatment\", \"sum\", \"poly\", \"helmert\", \"sdif\", \"other\" or \"no.contrast\"). \"pairwise\ is used for pairwise contrasts computed with `tidy_add_pairwise_contrasts()`.", "reference_row", "`tidy_add_reference_rows()`", "Logical indicating if a row is a reference row for categorical variables using a treatment or a sum contrast. Is equal to `NA` for variables who do not have a reference row.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
`tidy_add_reference_rows()` will not populate the label of the reference term. It is therefore better to apply `tidy_add_term_labels()` after `tidy_add_reference_rows()` rather than before.
", "var_label", "`tidy_add_variable_labels()`", "String of variable labels from the model. Columns labelled with the `labelled` package are retained. It is possible to pass a custom label for an interaction term with the `labels` argument.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "label", "`tidy_add_term_labels()`", "String of term labels based on (1) labels provided in `labels` argument if provided; (2) factor levels for categorical variables coded with treatment, SAS or sum contrasts; (3) variable labels when there is only one term per variable; and (4) term name otherwise.
Require \"variable_label\" column. If needed, will automatically apply `tidy_add_variable_labels()`.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
", "header_row", "`tidy_add_header_rows()`", "Logical indicating if a row is a header row for variables with several terms. Is equal to `NA` for variables who do not have an header row.
Require \"label\" column. If needed, will automatically apply `tidy_add_term_labels()`.
It is better to apply `tidy_add_header_rows()` after other `tidy_*` functions
", "n_obs", "`tidy_add_n()`", "Number of observations", "n_event", "`tidy_add_n()`", "Number of events (for binomial and multinomial logistic models, Poisson and Cox models)", "exposure", "`tidy_add_n()`", "Exposure time (for Poisson and Cox models)" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options( column_labels.font.weight = "bold" ) %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) # nolint end ## ---- echo=FALSE-------------------------------------------------------------- tibble::tribble( ~Attribute, ~Function, ~Description, "exponentiate", "`tidy_and_attach()`", "Indicates if estimates were exponentiated", "conf.level", "`tidy_and_attach()`", "Level of confidence used for confidence intervals", "coefficients_type", "`tidy_add_coefficients_type()`", "Type of coefficients", "coefficients_label", "`tidy_add_coefficients_type()`", "Coefficients label", "variable_labels", "`tidy_add_variable_labels()`", "Custom variable labels passed to `tidy_add_variable_labels()`", "term_labels", "`tidy_add_term_labels()`", "Custom term labels passed to `tidy_add_term_labels()`", "N_obs", "`tidy_add_n()`", "Total number of observations", "N_event", "`tidy_add_n()`", "Total number of events", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) ## ---- echo=FALSE-------------------------------------------------------------- supported_models %>% dplyr::rename_with(stringr::str_to_title) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) broom.helpers/inst/doc/tidy.html0000644000176200001440000053401214464203464016426 0ustar liggesusers Getting Started with broom.helpers

Getting Started with broom.helpers

The broom.helpers package offers a suite of functions that make easy to interact, add information, and manipulate tibbles created with broom::tidy() (and friends).

The suite includes functions to group regression model terms by variable, insert reference and header rows for categorical variables, add variable labels, and more.

As a motivating example, let’s summarize a logistic regression model with a forest plot and in a table.

To begin, let’s load our packages.

library(broom.helpers)
library(gtsummary)
library(ggplot2)
library(dplyr)

# paged_table() was introduced only in rmarkdwon v1.2
print_table <- function(tab) {
  if (packageVersion("rmarkdown") >= "1.2") {
    rmarkdown::paged_table(tab)
  } else {
    knitr::kable(tab)
  }
}

Our model predicts tumor response using chemotherapy treatment and tumor grade. The data set we’re utilizing has already labelled the columns using the labelled package. The column labels will be carried through to our figure and table.

model_logit <- glm(response ~ trt + grade, trial, family = binomial)
broom::tidy(model_logit)
#> # A tibble: 4 × 5
#>   term        estimate std.error statistic p.value
#>   <chr>          <dbl>     <dbl>     <dbl>   <dbl>
#> 1 (Intercept)  -0.879      0.305    -2.88  0.00400
#> 2 trtDrug B     0.194      0.311     0.625 0.532  
#> 3 gradeII      -0.0647     0.381    -0.170 0.865  
#> 4 gradeIII      0.0822     0.376     0.219 0.827

Forest Plot

To create the figure, we’ll need to add some information to the tidy tibble, i.e. we’ll need to group the terms that belong to the same variable, add the reference row, etc. Parsing this information can be difficult, but the broom.helper package has made it simple.

tidy_forest <-
  model_logit %>%
  # perform initial tidying of the model
  tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>%
  # adding in the reference row for categorical variables
  tidy_add_reference_rows() %>%
  # adding a reference value to appear in plot
  tidy_add_estimate_to_reference_rows() %>%
  # adding the variable labels
  tidy_add_term_labels() %>%
  # removing intercept estimate from model
  tidy_remove_intercept()
tidy_forest
#> # A tibble: 5 × 16
#>   term      variable var_label          var_class var_type var_nlevels contrasts
#>   <chr>     <chr>    <chr>              <chr>     <chr>          <int> <chr>    
#> 1 trtDrug A trt      Chemotherapy Trea… character dichoto…           2 contr.tr…
#> 2 trtDrug B trt      Chemotherapy Trea… character dichoto…           2 contr.tr…
#> 3 gradeI    grade    Grade              factor    categor…           3 contr.tr…
#> 4 gradeII   grade    Grade              factor    categor…           3 contr.tr…
#> 5 gradeIII  grade    Grade              factor    categor…           3 contr.tr…
#> # ℹ 9 more variables: contrasts_type <chr>, reference_row <lgl>, label <chr>,
#> #   estimate <dbl>, std.error <dbl>, statistic <dbl>, p.value <dbl>,
#> #   conf.low <dbl>, conf.high <dbl>

Note: we used tidy_and_attach() instead of broom::tidy(). broom.helpers functions needs a copy of the original model. To avoid passing the model at each step, the easier way is to attach the model as an attribute of the tibble with tidy_attach_model(). tidy_and_attach() is simply a shortcut of model %>% broom::tidy() %>% tidy_and_attach(model).

We now have a tibble with every piece of information we need to create our forest plot using ggplot2.

tidy_forest %>%
  mutate(
    plot_label = paste(var_label, label, sep = ":") %>%
      forcats::fct_inorder() %>%
      forcats::fct_rev()
  ) %>%
  ggplot(aes(x = plot_label, y = estimate, ymin = conf.low, ymax = conf.high, color = variable)) +
  geom_hline(yintercept = 1, linetype = 2) +
  geom_pointrange() +
  coord_flip() +
  theme(legend.position = "none") +
  labs(
    y = "Odds Ratio",
    x = " ",
    title = "Forest Plot using broom.helpers"
  )

Note:: for more advanced and nicely formatted plots of model coefficients, look at ggstats::ggcoef_model() and its dedicated vignette. ggstats::ggcoef_model() internally uses broom.helpers.

Table Summary

In addition to aiding in figure creation, the broom.helpers package can help summarize a model in a table. In the example below, we add header and reference rows, and utilize existing variable labels. Let’s change the labels shown in our summary table as well.

tidy_table <-
  model_logit %>%
  # perform initial tidying of the model
  tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>%
  # adding in the reference row for categorical variables
  tidy_add_reference_rows() %>%
  # adding the variable labels
  tidy_add_term_labels() %>%
  # add header row
  tidy_add_header_rows() %>%
  # removing intercept estimate from model
  tidy_remove_intercept()

# print summary table
options(knitr.kable.NA = "")
tidy_table %>%
  # format model estimates
  select(label, estimate, conf.low, conf.high, p.value) %>%
  mutate(across(all_of(c("estimate", "conf.low", "conf.high")), style_ratio)) %>%
  mutate(across(p.value, style_pvalue)) %>%
  print_table()

Note:: for more advanced and nicely formatted tables of model coefficients, look at gtsummary::tbl_regression() and its dedicated vignette. gtsummary::tbl_regression() internally uses broom.helpers.

All-in-one function

There is also a handy wrapper, called tidy_plus_plus(), for the most commonly used tidy_*() functions, and they can be executed with a single line of code:

model_logit %>%
  tidy_plus_plus(exponentiate = TRUE)
#> # A tibble: 5 × 18
#>   term      variable var_label          var_class var_type var_nlevels contrasts
#>   <chr>     <chr>    <chr>              <chr>     <chr>          <int> <chr>    
#> 1 trtDrug A trt      Chemotherapy Trea… character dichoto…           2 contr.tr…
#> 2 trtDrug B trt      Chemotherapy Trea… character dichoto…           2 contr.tr…
#> 3 gradeI    grade    Grade              factor    categor…           3 contr.tr…
#> 4 gradeII   grade    Grade              factor    categor…           3 contr.tr…
#> 5 gradeIII  grade    Grade              factor    categor…           3 contr.tr…
#> # ℹ 11 more variables: contrasts_type <chr>, reference_row <lgl>, label <chr>,
#> #   n_obs <dbl>, n_event <dbl>, estimate <dbl>, std.error <dbl>,
#> #   statistic <dbl>, p.value <dbl>, conf.low <dbl>, conf.high <dbl>
model_logit %>%
  tidy_plus_plus(exponentiate = TRUE) %>%
  print_table()

See the documentation of tidy_plus_plus() for the full list of available options.

Advanced examples

broom.helpers can also handle different contrasts for categorical variables and the use of polynomial terms for continuous variables.

Polynomial terms

When polynomial terms of a continuous variable are defined with stats::poly(), broom.helpers will be able to identify the corresponding variable, create appropriate labels and add header rows.

model_poly <- glm(response ~ poly(age, 3) + ttdeath, na.omit(trial), family = binomial)

model_poly %>%
  tidy_plus_plus(
    exponentiate = TRUE,
    add_header_rows = TRUE,
    variable_labels = c(age = "Age in years")
  ) %>%
  print_table()

Different type of contrasts

By default, categorical variables are coded with a treatment contrasts (see stats::contr.treatment()). With such contrasts, model coefficients correspond to the effect of a modality compared with the reference modality (by default, the first one). tidy_add_reference_rows() allows to add a row for this reference modality and tidy_add_estimate_to_reference_rows() will populate the estimate value of these references rows by 0 (or 1 if exponentiate = TRUE). tidy_add_term_labels() is able to retrieve the label of the factor level associated with a specific model term.

model_1 <- glm(
  response ~ stage + grade * trt,
  gtsummary::trial,
  family = binomial
)

model_1 %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_reference_rows() %>%
  tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>%
  tidy_add_term_labels() %>%
  print_table()

Using stats::contr.treatment(), it is possible to defined alternative reference rows. It will be properly managed by broom.helpers.

model_2 <- glm(
  response ~ stage + grade * trt,
  gtsummary::trial,
  family = binomial,
  contrasts = list(
    stage = contr.treatment(4, base = 3),
    grade = contr.treatment(3, base = 2),
    trt = contr.treatment(2, base = 2)
  )
)

model_2 %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_reference_rows() %>%
  tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>%
  tidy_add_term_labels() %>%
  print_table()

You can also use sum contrasts (cf. stats::contr.sum()). In that case, each model coefficient corresponds to the difference of that modality with the grand mean. A variable with 4 modalities will be coded with 3 terms. However, a value could be computed (using emmeans::emmeans()) for the last modality, corresponding to the difference of that modality with the grand mean and equal to sum of all other coefficients multiplied by -1. broom.helpers will identify categorical variables coded with sum contrasts and could retrieve an estimate value for the reference term.

model_3 <- glm(
  response ~ stage + grade * trt,
  gtsummary::trial,
  family = binomial,
  contrasts = list(
    stage = contr.sum,
    grade = contr.sum,
    trt = contr.sum
  )
)

model_3 %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_reference_rows() %>%
  tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>%
  tidy_add_term_labels() %>%
  print_table()

Other types of contrasts exist, like Helmert (contr.helmert()) or polynomial (contr.poly()). They are more complex as a modality will be coded with a combination of terms. Therefore, for such contrasts, it will not be possible to associate a specific model term with a level of the original factor. broom.helpers will not add a reference term in such case.

model_4 <- glm(
  response ~ stage + grade * trt,
  gtsummary::trial,
  family = binomial,
  contrasts = list(
    stage = contr.poly,
    grade = contr.helmert,
    trt = contr.poly
  )
)

model_4 %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_reference_rows() %>%
  tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>%
  tidy_add_term_labels() %>%
  print_table()

Pairwise contrasts of categorical variable

Pairwise contrasts of categorical variables could be computed with tidy_add_pairwise_contrasts().

model_logit <- glm(response ~ age + trt + grade, trial, family = binomial)

model_logit %>%
  tidy_and_attach() %>%
  tidy_add_pairwise_contrasts() %>%
  print_table()

model_logit %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_pairwise_contrasts() %>%
  print_table()

model_logit %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) %>%
  print_table()

model_logit %>%
  tidy_and_attach(exponentiate = TRUE) %>%
  tidy_add_pairwise_contrasts(keep_model_terms = TRUE) %>%
  print_table()

Column Details

Below is a summary of the additional columns that may be added by a broom.helpers function. The table includes the column name, the function that adds the column, and a short description of the information in the column.

Column Function Description

original_term

tidy_disambiguate_terms(), tidy_multgee() or tidy_zeroinfl()

Original term before disambiguation. This columns is added only when disambiguation is needed (i.e. for mixed models). Also used for “multgee”, “zeroinfl” and “hurdle” models.

variable

tidy_identify_variables()

String of variable names from the model. For categorical variables and polynomial terms defined with stats::poly(), terms belonging to the variable are identified.

var_class

tidy_identify_variables()

Class of the variable.

var_type

tidy_identify_variables()

One of “intercept”, “continuous”, “dichotomous”, “categorical”, “interaction”, “ran_pars” or “ran_vals”

var_nlevels

tidy_identify_variables()

Number of original levels for categorical variables

contrasts

tidy_add_contrasts()

Contrasts used for categorical variables.
Require “variable” column. If needed, will automatically apply tidy_identify_variables().

contrasts_type

tidy_add_contrasts()

Type of contrasts (“treatment”, “sum”, “poly”, “helmert”, “sdif”, “other” or “no.contrast”). “pairwise is used for pairwise contrasts computed with tidy_add_pairwise_contrasts().

reference_row

tidy_add_reference_rows()

Logical indicating if a row is a reference row for categorical variables using a treatment or a sum contrast. Is equal to NA for variables who do not have a reference row.
Require “contrasts” column. If needed, will automatically apply tidy_add_contrasts().
tidy_add_reference_rows() will not populate the label of the reference term. It is therefore better to apply tidy_add_term_labels() after tidy_add_reference_rows() rather than before.

var_label

tidy_add_variable_labels()

String of variable labels from the model. Columns labelled with the labelled package are retained. It is possible to pass a custom label for an interaction term with the labels argument.
Require “variable” column. If needed, will automatically apply tidy_identify_variables().

label

tidy_add_term_labels()

String of term labels based on (1) labels provided in labels argument if provided; (2) factor levels for categorical variables coded with treatment, SAS or sum contrasts; (3) variable labels when there is only one term per variable; and (4) term name otherwise.
Require “variable_label” column. If needed, will automatically apply tidy_add_variable_labels().
Require “contrasts” column. If needed, will automatically apply tidy_add_contrasts().

header_row

tidy_add_header_rows()

Logical indicating if a row is a header row for variables with several terms. Is equal to NA for variables who do not have an header row.
Require “label” column. If needed, will automatically apply tidy_add_term_labels().
It is better to apply tidy_add_header_rows() after other tidy_* functions

n_obs

tidy_add_n()

Number of observations

n_event

tidy_add_n()

Number of events (for binomial and multinomial logistic models, Poisson and Cox models)

exposure

tidy_add_n()

Exposure time (for Poisson and Cox models)

Note: tidy_add_estimate_to_reference_rows() does not create an additional column; rather, it populates the ‘estimate’ column for reference rows.

Additional attributes

Below is a list of additional attributes that broom.helpers may attached to the results. The table includes the attribute name, the function that adds the attribute, and a short description.

Attribute Function Description

exponentiate

tidy_and_attach()

Indicates if estimates were exponentiated

conf.level

tidy_and_attach()

Level of confidence used for confidence intervals

coefficients_type

tidy_add_coefficients_type()

Type of coefficients

coefficients_label

tidy_add_coefficients_type()

Coefficients label

variable_labels

tidy_add_variable_labels()

Custom variable labels passed to tidy_add_variable_labels()

term_labels

tidy_add_term_labels()

Custom term labels passed to tidy_add_term_labels()

N_obs

tidy_add_n()

Total number of observations

N_event

tidy_add_n()

Total number of events

Exposure

tidy_add_n()

Total of exposure time

component

tidy_zeroinfl()

component argument passed to tidy_zeroinfl()

Supported models

Model Notes

betareg::betareg()

Use tidy_parameters() as tidy_fun with component argument to control with coefficients to return. broom::tidy() does not support the exponentiateargument for betareg models, usetidy_parameters() instead.`

biglm::bigglm()

biglmm::bigglm()

brms::brm()

broom.mixed package required

cmprsk::crr()

Limited support. It is recommended to use tidycmprsk::crr() instead.

fixest::feglm()

May fail with R <= 4.0.

fixest::femlm()

May fail with R <= 4.0.

fixest::feNmlm()

May fail with R <= 4.0.

fixest::feols()

May fail with R <= 4.0.

gam::gam()

geepack::geeglm()

glmmTMB::glmmTMB()

broom.mixed package required

lavaan::lavaan()

Limited support for categorical variables

lfe::felm()

lme4::glmer.nb()

broom.mixed package required

lme4::glmer()

broom.mixed package required

lme4::lmer()

broom.mixed package required

logitr::logitr()

Requires logitr >= 0.8.0

MASS::glm.nb()

MASS::polr()

mgcv::gam()

Use default tidier broom::tidy() for smooth terms only, or gtsummary::tidy_gam() to include parametric terms

mice::mira

Limited support. If mod is a mira object, use tidy_plus_plus(mod, tidy_fun = function(x, ...) mice::pool(x) %>% mice::tidy(...))

multgee::nomLORgee()

Experimental support. Use tidy_multgee() as tidy_fun.

multgee::ordLORgee()

Experimental support. Use tidy_multgee() as tidy_fun.

nnet::multinom()

ordinal::clm()

Limited support for models with nominal predictors.

ordinal::clmm()

Limited support for models with nominal predictors.

parsnip::model_fit

Supported as long as the type of model and the engine is supported.

plm::plm()

pscl::hurdle()

Use tidy_zeroinfl() as tidy_fun.

pscl::zeroinfl()

Use tidy_zeroinfl() as tidy_fun.

rstanarm::stan_glm()

broom.mixed package required

stats::aov()

Reference rows are not relevant for such models.

stats::glm()

stats::lm()

stats::nls()

Limited support

survey::svycoxph()

survey::svyglm()

survey::svyolr()

survival::clogit()

survival::coxph()

survival::survreg()

tidycmprsk::crr()

VGAM::vglm()

Limited support. It is recommended to use tidy_parameters() as tidy_fun.

Note: this list of models has been tested. broom.helpers may or may not work properly or partially with other types of models. Do not hesitate to provide feedback on GitHub.

broom.helpers/inst/doc/tidy.Rmd0000644000176200001440000003777314464175037016224 0ustar liggesusers--- title: "Getting Started with broom.helpers" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Getting Started with broom.helpers} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>", rows.print = 25 ) # one of the functions below needs emmeans, so dont evaluate code check in vignette # on old R versions where emmeans is not available if (!rlang::is_installed("emmeans")) { knitr::opts_chunk$set(eval = FALSE) } ``` The `broom.helpers` package offers a suite of functions that make easy to interact, add information, and manipulate tibbles created with `broom::tidy()` (and friends). The suite includes functions to group regression model terms by variable, insert reference and header rows for categorical variables, add variable labels, and more. As a motivating example, let's summarize a logistic regression model with a forest plot and in a table. To begin, let's load our packages. ```{r setup, warning=FALSE, message=FALSE} library(broom.helpers) library(gtsummary) library(ggplot2) library(dplyr) # paged_table() was introduced only in rmarkdwon v1.2 print_table <- function(tab) { if (packageVersion("rmarkdown") >= "1.2") { rmarkdown::paged_table(tab) } else { knitr::kable(tab) } } ``` Our model predicts tumor response using chemotherapy treatment and tumor grade. The data set we're utilizing has already labelled the columns using the [labelled package](https://larmarange.github.io/labelled/). The column labels will be carried through to our figure and table. ```{r} model_logit <- glm(response ~ trt + grade, trial, family = binomial) broom::tidy(model_logit) ``` ## Forest Plot To create the figure, we'll need to add some information to the tidy tibble, i.e. we'll need to group the terms that belong to the same variable, add the reference row, etc. Parsing this information can be difficult, but the `broom.helper` package has made it simple. ```{r} tidy_forest <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding a reference value to appear in plot tidy_add_estimate_to_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # removing intercept estimate from model tidy_remove_intercept() tidy_forest ``` **Note:** we used `tidy_and_attach()` instead of `broom::tidy()`. `broom.helpers` functions needs a copy of the original model. To avoid passing the model at each step, the easier way is to attach the model as an attribute of the tibble with `tidy_attach_model()`. `tidy_and_attach()` is simply a shortcut of `model %>% broom::tidy() %>% tidy_and_attach(model)`. We now have a tibble with every piece of information we need to create our forest plot using `ggplot2`. ```{r, warning=FALSE} tidy_forest %>% mutate( plot_label = paste(var_label, label, sep = ":") %>% forcats::fct_inorder() %>% forcats::fct_rev() ) %>% ggplot(aes(x = plot_label, y = estimate, ymin = conf.low, ymax = conf.high, color = variable)) + geom_hline(yintercept = 1, linetype = 2) + geom_pointrange() + coord_flip() + theme(legend.position = "none") + labs( y = "Odds Ratio", x = " ", title = "Forest Plot using broom.helpers" ) ``` **Note::** for more advanced and nicely formatted plots of model coefficients, look at `ggstats::ggcoef_model()` and its [dedicated vignette](https://larmarange.github.io/ggstats/articles/ggcoef_model.html). `ggstats::ggcoef_model()` internally uses `broom.helpers`. ## Table Summary In addition to aiding in figure creation, the broom.helpers package can help summarize a model in a table. In the example below, we add header and reference rows, and utilize existing variable labels. Let's change the labels shown in our summary table as well. ```{r} tidy_table <- model_logit %>% # perform initial tidying of the model tidy_and_attach(exponentiate = TRUE, conf.int = TRUE) %>% # adding in the reference row for categorical variables tidy_add_reference_rows() %>% # adding the variable labels tidy_add_term_labels() %>% # add header row tidy_add_header_rows() %>% # removing intercept estimate from model tidy_remove_intercept() # print summary table options(knitr.kable.NA = "") tidy_table %>% # format model estimates select(label, estimate, conf.low, conf.high, p.value) %>% mutate(across(all_of(c("estimate", "conf.low", "conf.high")), style_ratio)) %>% mutate(across(p.value, style_pvalue)) %>% print_table() ``` **Note::** for more advanced and nicely formatted tables of model coefficients, look at `gtsummary::tbl_regression()` and its [dedicated vignette](https://www.danieldsjoberg.com/gtsummary/articles/tbl_regression.html). `gtsummary::tbl_regression()` internally uses `broom.helpers`. ## All-in-one function There is also a handy wrapper, called `tidy_plus_plus()`, for the most commonly used `tidy_*()` functions, and they can be executed with a single line of code: ```{r} model_logit %>% tidy_plus_plus(exponentiate = TRUE) ``` ```{r} model_logit %>% tidy_plus_plus(exponentiate = TRUE) %>% print_table() ``` See the documentation of `tidy_plus_plus()` for the full list of available options. ## Advanced examples `broom.helpers` can also handle different contrasts for categorical variables and the use of polynomial terms for continuous variables. ### Polynomial terms When polynomial terms of a continuous variable are defined with `stats::poly()`, `broom.helpers` will be able to identify the corresponding variable, create appropriate labels and add header rows. ```{r} model_poly <- glm(response ~ poly(age, 3) + ttdeath, na.omit(trial), family = binomial) model_poly %>% tidy_plus_plus( exponentiate = TRUE, add_header_rows = TRUE, variable_labels = c(age = "Age in years") ) %>% print_table() ``` ### Different type of contrasts By default, categorical variables are coded with a treatment contrasts (see `stats::contr.treatment()`). With such contrasts, model coefficients correspond to the effect of a modality compared with the reference modality (by default, the first one). `tidy_add_reference_rows()` allows to add a row for this reference modality and `tidy_add_estimate_to_reference_rows()` will populate the estimate value of these references rows by 0 (or 1 if `exponentiate = TRUE`). `tidy_add_term_labels()` is able to retrieve the label of the factor level associated with a specific model term. ```{r} model_1 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial ) model_1 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` Using `stats::contr.treatment()`, it is possible to defined alternative reference rows. It will be properly managed by `broom.helpers`. ```{r} model_2 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.treatment(4, base = 3), grade = contr.treatment(3, base = 2), trt = contr.treatment(2, base = 2) ) ) model_2 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` You can also use sum contrasts (cf. `stats::contr.sum()`). In that case, each model coefficient corresponds to the difference of that modality with the grand mean. A variable with 4 modalities will be coded with 3 terms. However, a value could be computed (using `emmeans::emmeans()`) for the last modality, corresponding to the difference of that modality with the grand mean and equal to sum of all other coefficients multiplied by -1. `broom.helpers` will identify categorical variables coded with sum contrasts and could retrieve an estimate value for the reference term. ```{r} model_3 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.sum, grade = contr.sum, trt = contr.sum ) ) model_3 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` Other types of contrasts exist, like Helmert (`contr.helmert()`) or polynomial (`contr.poly()`). They are more complex as a modality will be coded with a combination of terms. Therefore, for such contrasts, it will not be possible to associate a specific model term with a level of the original factor. `broom.helpers` will not add a reference term in such case. ```{r} model_4 <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list( stage = contr.poly, grade = contr.helmert, trt = contr.poly ) ) model_4 %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_reference_rows() %>% tidy_add_estimate_to_reference_rows(exponentiate = TRUE) %>% tidy_add_term_labels() %>% print_table() ``` ### Pairwise contrasts of categorical variable Pairwise contrasts of categorical variables could be computed with `tidy_add_pairwise_contrasts()`. ```{r} model_logit <- glm(response ~ age + trt + grade, trial, family = binomial) model_logit %>% tidy_and_attach() %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts() %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(pairwise_reverse = FALSE) %>% print_table() model_logit %>% tidy_and_attach(exponentiate = TRUE) %>% tidy_add_pairwise_contrasts(keep_model_terms = TRUE) %>% print_table() ``` ## Column Details Below is a summary of the additional columns that may be added by a `broom.helpers` function. The table includes the column name, the function that adds the column, and a short description of the information in the column. ```{r, echo=FALSE} # nolint start tibble::tribble( ~Column, ~Function, ~Description, "original_term", "`tidy_disambiguate_terms()`, `tidy_multgee()` or `tidy_zeroinfl()`", "Original term before disambiguation. This columns is added only when disambiguation is needed (i.e. for mixed models). Also used for \"multgee\", \"zeroinfl\" and \"hurdle\" models.", "variable", "`tidy_identify_variables()`", "String of variable names from the model. For categorical variables and polynomial terms defined with `stats::poly()`, terms belonging to the variable are identified.", "var_class", "`tidy_identify_variables()`", "Class of the variable.", "var_type", "`tidy_identify_variables()`", "One of \"intercept\", \"continuous\", \"dichotomous\", \"categorical\", \"interaction\", \"ran_pars\" or \"ran_vals\"", "var_nlevels", "`tidy_identify_variables()`", "Number of original levels for categorical variables", "contrasts", "`tidy_add_contrasts()`", "Contrasts used for categorical variables.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "contrasts_type", "`tidy_add_contrasts()`", "Type of contrasts (\"treatment\", \"sum\", \"poly\", \"helmert\", \"sdif\", \"other\" or \"no.contrast\"). \"pairwise\ is used for pairwise contrasts computed with `tidy_add_pairwise_contrasts()`.", "reference_row", "`tidy_add_reference_rows()`", "Logical indicating if a row is a reference row for categorical variables using a treatment or a sum contrast. Is equal to `NA` for variables who do not have a reference row.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
`tidy_add_reference_rows()` will not populate the label of the reference term. It is therefore better to apply `tidy_add_term_labels()` after `tidy_add_reference_rows()` rather than before.
", "var_label", "`tidy_add_variable_labels()`", "String of variable labels from the model. Columns labelled with the `labelled` package are retained. It is possible to pass a custom label for an interaction term with the `labels` argument.
Require \"variable\" column. If needed, will automatically apply `tidy_identify_variables()`.", "label", "`tidy_add_term_labels()`", "String of term labels based on (1) labels provided in `labels` argument if provided; (2) factor levels for categorical variables coded with treatment, SAS or sum contrasts; (3) variable labels when there is only one term per variable; and (4) term name otherwise.
Require \"variable_label\" column. If needed, will automatically apply `tidy_add_variable_labels()`.
Require \"contrasts\" column. If needed, will automatically apply `tidy_add_contrasts()`.
", "header_row", "`tidy_add_header_rows()`", "Logical indicating if a row is a header row for variables with several terms. Is equal to `NA` for variables who do not have an header row.
Require \"label\" column. If needed, will automatically apply `tidy_add_term_labels()`.
It is better to apply `tidy_add_header_rows()` after other `tidy_*` functions
", "n_obs", "`tidy_add_n()`", "Number of observations", "n_event", "`tidy_add_n()`", "Number of events (for binomial and multinomial logistic models, Poisson and Cox models)", "exposure", "`tidy_add_n()`", "Exposure time (for Poisson and Cox models)" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options( column_labels.font.weight = "bold" ) %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) # nolint end ``` Note: `tidy_add_estimate_to_reference_rows()` does not create an additional column; rather, it populates the 'estimate' column for reference rows. ## Additional attributes Below is a list of additional attributes that `broom.helpers` may attached to the results. The table includes the attribute name, the function that adds the attribute, and a short description. ```{r, echo=FALSE} tibble::tribble( ~Attribute, ~Function, ~Description, "exponentiate", "`tidy_and_attach()`", "Indicates if estimates were exponentiated", "conf.level", "`tidy_and_attach()`", "Level of confidence used for confidence intervals", "coefficients_type", "`tidy_add_coefficients_type()`", "Type of coefficients", "coefficients_label", "`tidy_add_coefficients_type()`", "Coefficients label", "variable_labels", "`tidy_add_variable_labels()`", "Custom variable labels passed to `tidy_add_variable_labels()`", "term_labels", "`tidy_add_term_labels()`", "Custom term labels passed to `tidy_add_term_labels()`", "N_obs", "`tidy_add_n()`", "Total number of observations", "N_event", "`tidy_add_n()`", "Total number of events", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) ``` ## Supported models ```{r, echo=FALSE} supported_models %>% dplyr::rename_with(stringr::str_to_title) %>% gt::gt() %>% gt::fmt_markdown(columns = everything()) %>% gt::tab_options(column_labels.font.weight = "bold") %>% gt::opt_row_striping() %>% gt::tab_style("vertical-align:top; font-size: 12px;", gt::cells_body()) ``` Note: this list of models has been tested. `broom.helpers` may or may not work properly or partially with other types of models. Do not hesitate to provide feedback on [GitHub](https://github.com/larmarange/broom.helpers/issues). broom.helpers/inst/WORDLIST0000644000176200001440000000052514464175276015222 0ustar liggesusersAME Arel Bundock CMD Codecov DOI Heiss Helmert Lifecycle Lüdecke MEM Stata Tibbles cloglog cond disambiguated disambiguating disp emmeans exponentiate gtsummary helmert labelled logitr poisson quartile quartiles sdiff tibble tibbles tidiers tidyselect tieder tieders un unselected varnames xlevels zi