broom.helpers/0000755000176200001440000000000014762300062013031 5ustar liggesusersbroom.helpers/tests/0000755000176200001440000000000014737437002014202 5ustar liggesusersbroom.helpers/tests/testthat/0000755000176200001440000000000014762300062016033 5ustar liggesusersbroom.helpers/tests/testthat/test-add_n.R0000644000176200001440000002163714746151337020224 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_equal( res$n_obs, c(193, 52, 40, 49, 63, 63, 98), ignore_attr = TRUE ) expect_equal( res$n_event, c(61, 13, 15, 15, 19, 21, 33), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 193) expect_equal(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_equal( res$n_obs, c(193, 52, 52, 40, 63, 63, 95), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 193) expect_equal(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_equal( res$n_obs, c(193, 193, 193, 193, 63, 63, 98), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 193) expect_equal(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_equal( res$n_obs, c(193, 52, 52, 49, 67, 63, 95, 107), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 193) expect_equal(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_equal( res$n_obs, c(193, 52, 52, 40, 63, 63, 95), ignore_attr = TRUE ) mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) res <- mod |> tidy_and_attach() |> tidy_add_n() expect_equal( res$n_obs, c(183, 183, 58, 60, 94, 29, 33), ignore_attr = TRUE ) expect_equal( res$n_event, c(58, 58, 17, 20, 31, 10, 8), ignore_attr = TRUE ) expect_equal( res$exposure, c(183, 183, 58, 60, 94, 29, 33), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 183) expect_equal(attr(res, "N_event"), 58) expect_equal(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_equal( res$n_obs, c(292, 151, 94, 92, 49, 49), ignore_attr = TRUE ) expect_equal( res$n_event, c(96, 53, 28, 31, 19, 12), ignore_attr = TRUE ) expect_equal( res$exposure, c(5819.07, 2913.6, 1826.26, 1765.52, 887.22, 915.56), ignore_attr = TRUE ) expect_equal(attr(res, "N_obs"), 292) expect_equal(attr(res, "N_event"), 96) expect_equal(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_no_error( mod |> tidy_and_attach() |> tidy_add_n() |> tidy_add_n() ) }) 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_equal( res$n_obs, c(193, 52, 40, 49, 63, 63, 98), ignore_attr = TRUE ) }) 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_n()) }) 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_n()) }) test_that("tidy_add_n() works with survival::coxph", { skip_on_cran() skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error(res <- mod |> tidy_and_attach() |> tidy_add_n()) expect_equal(res$n_ind, c(227, 227, 90), ignore_attr = TRUE) expect_equal(attr(res, "N_ind"), 227) }) test_that("tidy_add_n() works with survival::survreg", { skip_on_cran() skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_n()) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_n()) res <- mod |> tidy_and_attach() |> tidy_add_n() expect_equal( res$n_obs, c(179, 47, 52, 37, 179, 179, 179, 47, 52, 37, 179, 179), ignore_attr = TRUE ) expect_equal( res$n_event, c(57, 21, 16, 8, 57, 57, 58, 12, 18, 12, 58, 58), ignore_attr = TRUE ) # when y is not coded as a factor mod <- nnet::multinom(race ~ age + lwt + bwt, data = MASS::birthwt, trace = FALSE) expect_no_error( mod |> tidy_and_attach() |> tidy_add_n() ) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) test_that("tidy_add_n() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) test_that("tidy_add_n() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) test_that("tidy_add_n() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_n()) }) 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_no_error(res <- mod |> tidy_and_attach() |> tidy_add_n()) expect_true(all(is.na(res$n))) }) test_that("model_compute_terms_contributions() with subset", { mod <- glm(mpg ~ gear, data = mtcars, subset = mpg < 30) expect_no_warning( res <- mod |> model_compute_terms_contributions() ) expect_equal( nrow(res), nrow(mtcars[mtcars$mpg < 30, ]) ) }) broom.helpers/tests/testthat/test-add_reference_rows.R0000644000176200001440000001631314737437002022766 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_equal( res$term, c( "(Intercept)", "stage1", "stage2", "stage3", "stage4", "grade1", "grade2", "grade3", "trt1", "trt2", "grade1:trt1", "grade2:trt1" ) ) } else { expect_equal( res$term, c( "(Intercept)", "stageT1", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "gradeIII", "trt1", "trt2", "gradeI:trt1", "gradeII:trt1" ) ) } expect_equal( res$reference_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE, NA, NA ) ) expect_equal( res$var_class, c( NA, "factor", "factor", "factor", "factor", "factor", "factor", "factor", "character", "character", NA, NA ), ignore_attr = TRUE ) expect_equal( res$var_type, c( "intercept", "categorical", "categorical", "categorical", "categorical", "categorical", "categorical", "categorical", "dichotomous", "dichotomous", "interaction", "interaction" ) ) expect_equal( res$var_nlevels, c(NA, 4L, 4L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, NA, NA), ignore_attr = TRUE ) # 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_equal( 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_equal( res$term, c( "(Intercept)", "stage2", "stage3", "stage4", "grade1", "grade2", "trt1", "trt2", "grade1:trt1", "grade2:trt1" ) ) } else { expect_equal( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "trt1", "trt2", "gradeI:trt1", "gradeII:trt1" ) ) } expect_equal( 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_equal( res$term, c( "(Intercept)", "stage1", "stage2", "stage3", "stage4", "grade1", "grade2", "grade3", "trt1", "trt2", "grade1:trt1", "grade3:trt1" ) ) } else { expect_equal( res$term, c( "(Intercept)", "stageT1", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "gradeIII", "trt1", "trt2", "gradeI:trt1", "gradeIII:trt1" ) ) } expect_equal( 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_equal( 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" ), ignore_attr = TRUE ) }) 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_equal( 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") suppressWarnings( mod <- glmmTMB::glmmTMB( count ~ mined + spp, ziformula = ~mined, family = poisson, data = glmmTMB::Salamanders ) ) res <- mod |> tidy_and_attach() |> tidy_add_reference_rows() expect_equal( res$reference_row, c( NA, TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, NA, TRUE, FALSE ) ) }) broom.helpers/tests/testthat/test-add_header_rows.R0000644000176200001440000001506714737437002022265 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_equal( 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" ), ignore_attr = TRUE ) expect_equal( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE ) ) expect_equal( res$var_nlevels, c(NA, 4L, 4L, 4L, 4L, 3L, 3L, 3L, 2L, 2L, NA, NA, NA), ignore_attr = TRUE ) # 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_equal( res$label, c( "(Intercept)", "T Stage", "T2", "T3", "T4", "Grade", "I", "II", "Chemotherapy Treatment", "Grade * Chemotherapy Treatment", "I * Drug A", "II * Drug A" ), ignore_attr = TRUE ) expect_equal( 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_equal( 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" ), ignore_attr = TRUE ) expect_equal( 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_no_warning( mod |> tidy_and_attach() |> tidy_add_header_rows() ) # 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_equal( 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_equal( 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_equal( res$header_row, c(NA, TRUE, FALSE, FALSE, NA, NA) ) expect_equal( res$var_label, c( "(Intercept)", "factor(response)", "factor(response)", "factor(response)", "Marker Level (ng/mL)", "factor(response) * Marker Level (ng/mL)" ), ignore_attr = TRUE ) # 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_equal( 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_equal( 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_equal( 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_equal( 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" ), ignore_attr = TRUE ) res <- mod |> tidy_and_attach() |> tidy_add_reference_rows() |> tidy_add_header_rows(show_single_row = everything(), quiet = TRUE) expect_equal( res$header_row, c( NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, NA, NA, TRUE, FALSE, FALSE, FALSE, FALSE, NA, NA, NA ) ) expect_equal( 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" ), ignore_attr = TRUE ) }) 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-tidy_parameters.R0000644000176200001440000000216714737437002022344 0ustar liggesuserstest_that("tidy_parameters() works for basic models", { skip_if_not_installed("parameters") mod <- lm(Petal.Length ~ Petal.Width, iris) expect_no_error( mod |> tidy_parameters() ) expect_no_error( mod |> tidy_plus_plus(tidy_fun = tidy_parameters) ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) expect_no_error( mod |> tidy_parameters() ) expect_no_error( res1 <- mod |> tidy_plus_plus(tidy_fun = tidy_parameters) ) expect_no_error( res2 <- mod |> tidy_plus_plus(tidy_fun = tidy_parameters, conf.level = .80) ) expect_false(identical(res1$conf.low, res2$conf.low)) expect_no_error( res <- mod |> tidy_plus_plus(tidy_fun = tidy_parameters, conf.int = FALSE) ) 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_no_error( mod |> tidy_with_broom_or_parameters() ) expect_error( suppressWarnings("not a model" |> tidy_with_broom_or_parameters()) ) }) broom.helpers/tests/testthat/test-model_get_n.R0000644000176200001440000003274314746151705021432 0ustar liggesuserstest_that("model_get_n() works for basic models", { mod <- lm(Sepal.Length ~ ., iris) res <- mod |> model_get_n() expect_equal( res$n_obs, c(150, 150, 150, 150, 50, 50, 50), ignore_attr = TRUE ) mod <- lm( Sepal.Length ~ log(Sepal.Width) + Petal.Length^2, iris ) res <- mod |> model_get_n() expect_equal( res$n_obs, c(150, 150, 150), ignore_attr = TRUE ) # logistic model mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) res <- mod |> model_get_n() expect_equal( res$n_obs, c(193, 52, 40, 49, 63, 63, 98, 52, 67, 95), ignore_attr = TRUE ) expect_equal( res$n_event, c(61, 13, 15, 15, 19, 21, 33, 18, 21, 28), ignore_attr = TRUE ) mod <- glm( Survived ~ Class * Age + Sex, data = Titanic |> as.data.frame(), weights = Freq, family = binomial ) res <- mod |> model_get_n() expect_equal( res$n_obs, c(2201, 285, 706, 885, 2092, 470, 261, 627, 885, 325, 109, 1731), ignore_attr = TRUE ) expect_equal( res$n_event, c(711, 118, 178, 212, 654, 344, 94, 151, 212, 203, 57, 367), ignore_attr = TRUE ) # 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_no_error(res <- mod |> model_get_n()) expect_equal( res$n_obs, c(2201, 285, 706, 885, 109, 1731, 24, 79, 0, 325, 2092, 470), ignore_attr = TRUE ) expect_equal( res$n_event, c(711, 118, 178, 212, 57, 367, 24, 27, 0, 203, 654, 344), ignore_attr = TRUE ) # Poisson without offset mod <- glm(response ~ age + grade * trt, gtsummary::trial, family = poisson) res <- mod |> model_get_n() expect_equal( res$n_obs, c(183, 183, 58, 60, 94, 29, 33, 65, 89), ignore_attr = TRUE ) expect_equal( res$n_event, c(58, 58, 17, 20, 31, 10, 8, 21, 27), ignore_attr = TRUE ) expect_equal( res$exposure, c(183, 183, 58, 60, 94, 29, 33, 65, 89), ignore_attr = TRUE ) # 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_equal( res$n_obs, c(292, 151, 94, 92, 49, 49, 141, 106), ignore_attr = TRUE ) expect_equal( res$n_event, c(96, 53, 28, 31, 19, 12, 43, 37), ignore_attr = TRUE ) expect_equal( res$exposure |> round(), c(5819, 2914, 1826, 1766, 887, 916, 2905, 2227), ignore_attr = TRUE ) # interaction only terms mod <- glm( Survived ~ Class:Age, data = Titanic |> as.data.frame(), weights = Freq, family = binomial ) res <- mod |> model_get_n() expect_equal( res$n_obs, c(2201, 6, 24, 79, 0, 319, 261, 627, 885), ignore_attr = TRUE ) expect_equal( res$n_event, c(711, 6, 24, 27, 0, 197, 94, 151, 212), ignore_attr = TRUE ) }) 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_no_error( res <- mod |> model_get_n() ) }) 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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs", "n_event")) if ("stage2" %in% names(coef(mod))) { expect_equal( res$term, c( "(Intercept)", "stage2", "stage3", "stage4", "grade1", "grade2", "trt1", "grade1:trt1", "grade2:trt1", "stage1", "grade3", "trt2" ) ) } else { expect_equal( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "gradeI", "gradeII", "trtDrug A", "gradeI:trtDrug A", "gradeII:trtDrug A", "stageT1", "gradeIII", "trtDrug B" ) ) } expect_equal( res$n_obs, c(193, 52, 40, 49, 67, 63, 95, 35, 30, 52, 63, 98), ignore_attr = TRUE ) mod <- glm( response ~ stage + grade * trt, gtsummary::trial, family = binomial, contrasts = list(stage = contr.poly, grade = contr.helmert, trt = contr.sum) ) expect_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs", "n_event")) expect_equal( res$term, c( "(Intercept)", "stage.L", "stage.Q", "stage.C", "grade1", "grade2", "trt1", "grade1:trt1", "grade2:trt1", "trt2" ) ) expect_equal( res$n_obs, c(193, 193, 193, 193, 63, 63, 95, 62, 95, 98), ignore_attr = TRUE ) }) 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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs")) expect_equal( 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_equal( res$n_obs, c(150, 150, 150, 150, 150, 150), ignore_attr = TRUE ) }) 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_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs", "n_event")) }) test_that("model_get_n() works with survival::coxph", { skip_on_cran() skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph( survival::Surv(time, status) ~ ph.ecog + age + sex, data = df ) expect_no_error(res <- mod |> model_get_n()) expect_equal( names(res), c("term", "n_obs", "n_ind", "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_no_error(res <- mod |> model_get_n()) expect_equal( names(res), c("term", "n_obs", "n_ind", "n_event", "exposure") ) expect_equal(res$n_obs, c(10, 10), ignore_attr = TRUE) expect_equal(res$n_ind, c(10, 10), ignore_attr = TRUE) expect_equal(res$n_event, c(7, 7), ignore_attr = TRUE) expect_equal(res$exposure, c(43, 43), ignore_attr = TRUE) # specific case when missing values in the `id` # should not result in a warning mod <- survival::coxph( survival::Surv(ttdeath, death) ~ age + grade, id = response, data = gtsummary::trial ) expect_no_warning(mod |> model_get_n()) }) test_that("model_get_n() works with survival::survreg", { skip_on_cran() skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_no_error(res <- mod |> model_get_n()) expect_equal( names(res), c("term", "n_obs", "n_ind", "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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("y.level", "term", "n_obs", "n_event")) expect_equal( res$y.level, c( "II", "II", "II", "II", "II", "II", "II", "III", "III", "III", "III", "III", "III", "III" ) ) expect_equal( res$n_obs, c(179, 52, 37, 43, 179, 179, 47, 179, 52, 37, 43, 179, 179, 47), ignore_attr = TRUE ) expect_equal( res$n_event, c(57, 16, 8, 12, 57, 57, 21, 58, 18, 12, 16, 58, 58, 12), ignore_attr = TRUE ) # 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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs", "n_event")) mod <- survey::svyglm(response ~ age + grade + offset(log(ttdeath)), df, family = quasipoisson) expect_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs", "n_event")) expect_equal( res$n_obs, c(2201, 285, 706, 885, 2092, 470, 425, 325, 109, 1731), ignore_attr = TRUE ) }) test_that("model_get_n() works with ordinal::clm", { skip_on_cran() mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(names(res), c("term", "n_obs")) suppressWarnings( mod <- geepack::geeglm(mf, data = df, id = Pig, family = poisson(), corstr = "ar1") ) expect_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) expect_equal(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_no_error(res <- mod |> model_get_n()) 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") skip_if_not_installed("survival") mod <- tidycmprsk::crr( survival::Surv(ttdeath, death_cr) ~ age + grade, tidycmprsk::trial ) res <- mod |> tidy_plus_plus() expect_equal( res$n_event, c(52, 16, 15, 21), ignore_attr = TRUE ) }) 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-add_contrasts.R0000644000176200001440000002330114746151341021770 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_equal( res$contrasts, c( NA, "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment", "contr.treatment" ) ) expect_equal( 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_equal( res$contrasts, c( NA, "contr.sum", "contr.sum", "contr.sum", "contr.helmert", "contr.helmert", "contr.SAS" ) ) expect_equal( 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_equal( res$contrasts, c( NA, "contr.poly", "contr.poly", "contr.poly", "contr.treatment", "contr.treatment", "custom" ) ) expect_equal( 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_equal( 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_equal( 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_equal( res$contrasts, c( NA, "contr.sum", "contr.sum", "contr.sum", "contr.helmert", "contr.helmert", "contr.SAS" ) ) expect_equal( 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_equal( res$contrasts, c(NA, "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif", "contr.sdif") ) expect_equal( 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_equal( 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_equal( 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_equal( 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_contrasts()) }) 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_contrasts()) }) test_that("tidy_add_contrasts() works with survival::coxph", { skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) test_that("tidy_add_contrasts() works with survival::survreg", { skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE, contrasts = list(stage = contr.sum) ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) res <- mod |> tidy_and_attach() |> tidy_add_contrasts() expect_equal( 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_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) test_that("tidy_add_contrasts() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) test_that("tidy_add_contrasts() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) test_that("tidy_add_contrasts() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_contrasts()) }) 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-disambiguate_terms.R0000644000176200001440000000406514737437002023017 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_equal(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_equal( 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_equal( 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_no_error( mod |> tidy_and_attach() |> tidy_disambiguate_terms() |> tidy_disambiguate_terms() ) expect_message( mod |> tidy_and_attach(tidy_fun = broom::tidy) |> tidy_disambiguate_terms() |> tidy_disambiguate_terms() ) expect_no_message( mod |> tidy_and_attach(tidy_fun = broom::tidy) |> tidy_disambiguate_terms() |> tidy_disambiguate_terms(quiet = TRUE) ) }) broom.helpers/tests/testthat/test-add_coefficients_type.R0000644000176200001440000002530614746151343023463 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_equal(attr(res, "coefficients_type"), "generic") expect_equal(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_equal(attr(res, "coefficients_type"), "generic") expect_equal(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_equal(attr(res, "coefficients_type"), "logistic") expect_equal(attr(res, "coefficients_label"), "log(OR)") res <- mod |> tidy_and_attach(exponentiate = TRUE) |> tidy_add_coefficients_type() expect_equal(attr(res, "coefficients_type"), "logistic") expect_equal(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_equal(attr(res, "coefficients_type"), "generic") expect_equal(attr(res, "coefficients_label"), "Beta") res <- mod |> tidy_and_attach(exponentiate = TRUE) |> tidy_add_coefficients_type() expect_equal(attr(res, "coefficients_type"), "generic") expect_equal(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_equal(attr(res, "coefficients_type"), "relative_risk") expect_equal(attr(res, "coefficients_label"), "log(RR)") res <- mod |> tidy_and_attach(exponentiate = TRUE) |> tidy_add_coefficients_type() expect_equal(attr(res, "coefficients_type"), "relative_risk") expect_equal(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_equal(attr(res, "coefficients_type"), "prop_hazard") expect_equal(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_equal(attr(res, "coefficients_type"), "poisson") expect_equal(attr(res, "coefficients_label"), "log(IRR)") res <- mod |> tidy_and_attach(exponentiate = TRUE) |> tidy_add_coefficients_type() expect_equal(attr(res, "coefficients_type"), "poisson") expect_equal(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_equal(attr(res, "coefficients_type"), "generic") expect_equal(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_equal(attr(res, "coefficients_type"), "poisson") expect_equal(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_equal(attr(res, "coefficients_type"), "logistic") expect_equal(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_no_error( mod |> tidy_and_attach() |> tidy_add_coefficients_type() |> tidy_add_coefficients_type() ) }) 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_equal(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_equal(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_equal(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_equal(res, "relative_risk") mod <- lme4::glmer(response ~ trt + (1 | grade), gtsummary::trial, family = poisson) res <- mod |> model_get_coefficients_type() expect_equal(res, "poisson") }) test_that("model_get_coefficients_type() works with survival::coxph", { skip_if_not_installed("survival") 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_equal(res, "prop_hazard") }) test_that("model_get_coefficients_type() works with survival::survreg", { skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) res <- mod |> model_get_coefficients_type() expect_equal(res, "generic") }) test_that("model_get_coefficients_type() works with survival::clogit", { skip_if_not_installed("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) res <- mod |> model_get_coefficients_type() expect_equal(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_equal(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_equal(res, "logistic") }) test_that("model_get_coefficients_type() works with survey::svycoxph", { skip_if_not_installed("survey") skip_if_not_installed("survival") 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_equal(res, "prop_hazard") }) test_that("tidy_plus_plus() works with survey::svyolr", { skip_if_not_installed("survey") skip_if_not_installed("survival") 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_equal(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_equal(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_equal(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_equal(res, "logistic") mod <- MASS::polr( Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing, method = "probit" ) res <- mod |> model_get_coefficients_type() expect_equal(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_equal(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_equal(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_equal(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_equal(res, "generic") }) broom.helpers/tests/testthat/test-tidy_plus_plus.R0000644000176200001440000006376414760117574022246 0ustar liggesuserstest_that("tidy_plus_plus() works for basic models", { mod <- lm(Petal.Length ~ Petal.Width, iris) expect_no_error( mod |> tidy_plus_plus() ) mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) expect_no_error( mod |> tidy_plus_plus(add_header_rows = TRUE, include = c(stage, grade)) ) # 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_equal( 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" ), ignore_attr = TRUE ) # 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_no_error( res <- mod |> tidy_plus_plus() ) expect_equal( res$variable, c("stage", "stage", "stage", "stage", "grade", "grade", "grade") ) expect_equal( res$label, c("T1", "T2", "T3", "T4", "I", "II", "III"), ignore_attr = TRUE ) expect_equal( 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_no_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) ) ) ) # for coxph, identification of variables will not work # will display a message # but a result should be returned skip_if_not_installed("survival") 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_no_error( tidy_plus_plus( mod, exponentiate = FALSE, tidy_fun = function(x, ...) mice::pool(x) |> mice::tidy(...) ) ) }) test_that("tidy_plus_plus() with tidyselect", { skip_on_cran() # build regression model mod <- lm(age ~ trt + marker + grade, gtsummary::trial) expect_no_error( tidy_plus_plus( mod, add_header_rows = TRUE, show_single_row = trt, no_reference_row = grade ) ) 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_no_error( res <- tidy_plus_plus(mod) ) expect_equal( 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_no_error( res <- mod |> tidy_plus_plus() ) expect_no_error( res <- mod |> tidy_plus_plus(tidy_fun = tidy_parameters) ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) mod <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 | herd), family = binomial("probit"), data = lme4::cbpp ) expect_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) test_that("tidy_plus_plus() works with survival::coxph", { skip_on_cran() skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error( res <- mod |> tidy_plus_plus() ) }) test_that("tidy_plus_plus() works with survival::survreg", { skip_on_cran() skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_no_error( res <- mod |> tidy_plus_plus() ) }) test_that("tidy_plus_plus() works with survival::clogit", { skip_on_cran() skip_if_not_installed("survival") 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) expect_equal( res$y.level, c( "II", "II", "II", "II", "II", "II", "III", "III", "III", "III", "III", "III" ) ) expect_equal( 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) df_rep <- survey::as.svrepdesign(df) mod_rep <- survey::svyglm( response ~ age + grade * trt, df_rep, family = quasibinomial ) expect_no_error( res <- mod_rep |> tidy_plus_plus() ) }) test_that("tidy_plus_plus() works with survey::svycoxph", { skip_on_cran() skip_if_not_installed("survey") skip_if_not_installed("labelled") skip_if_not_installed("survival") d <- survival::pbc labelled::var_label(d$albumin) <- "Custom label" dpbc <- survey::svydesign(id = ~1, prob = ~1, strata = ~edema, data = d) mod <- survey::svycoxph( Surv(time, status > 0) ~ log(bili) + protime + albumin, design = dpbc ) expect_no_error( res <- mod |> tidy_plus_plus() ) expect_equal( res[res$term == "albumin", "var_label"][[1]][1], "Custom label", ignore_attr = TRUE ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( suppressWarnings(res <- mod |> tidy_plus_plus()) ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus(tidy_fun = broom.mixed::tidy) ) }) 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_no_error( res <- mod |> tidy_plus_plus(quiet = TRUE) ) }) 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_no_error( res <- mod |> tidy_plus_plus(quiet = TRUE) ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error(tbl_gam_logistic <- gam_logistic |> tidy_plus_plus(tidy_fun = tidy_gam)) expect_no_error(gam_logistic |> tidy_plus_plus()) expect_no_error(tbl_gam_linear <- gam_linear |> tidy_plus_plus(tidy_fun = tidy_gam)) expect_no_error(gam_linear |> tidy_plus_plus()) expect_no_error(tbl_gam_smooth_only <- gam_smooth_only |> tidy_plus_plus(tidy_fun = tidy_gam)) expect_no_error(gam_smooth_only |> tidy_plus_plus()) expect_no_error(tbl_gam_param_only <- gam_param_only |> tidy_plus_plus(tidy_fun = tidy_gam)) # 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") library(VGAM) 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_no_error( res <- mod |> tidy_plus_plus() ) # multinomial mod <- vglm(stage ~ grade + age, multinomial, data = gtsummary::trial) expect_no_error( res <- mod |> tidy_plus_plus(exponentiate = TRUE) ) expect_true("y.level" %in% colnames(res)) mod <- vglm( stage ~ grade + age, multinomial(parallel = TRUE), data = gtsummary::trial ) expect_no_error( res <- mod |> tidy_plus_plus(exponentiate = TRUE) ) d <- gtsummary::trial d$grade <- ordered(d$grade) mod <- vglm( grade ~ stage + age, cumulative(), data = d ) expect_no_error( res <- mod |> tidy_plus_plus(exponentiate = TRUE) ) expect_true("component" %in% colnames(res)) }) 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_no_error( res <- mod |> tidy_plus_plus() ) }) 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_no_error( res <- mod |> tidy_plus_plus() ) # 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_no_error( res2 <- mod2 |> tidy_plus_plus(exponentiate = TRUE) ) expect_equal(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_no_error( res <- mod |> tidy_plus_plus() ) mod <- fixest::feglm(Sepal.Length ~ Sepal.Width + Petal.Length | Species, iris, "poisson") expect_no_error( res <- mod |> tidy_plus_plus() ) mod <- fixest::feols(mpg ~ disp | cyl | wt ~ qsec, data = mtcars) expect_no_error( res <- mod |> tidy_plus_plus() ) expect_equal(nrow(res), 2L) expect_true(res$instrumental[res$term == "wt"]) res <- mod |> tidy_plus_plus(instrumental_suffix = NULL) expect_equal(res$var_label[res$term == "wt"], "wt", ignore_attr = TRUE) res <- mod |> tidy_plus_plus(instrumental_suffix = " (IV)") expect_equal(res$var_label[res$term == "wt"], "wt (IV)", ignore_attr = TRUE) mod <- fixest::feols(mpg ~ disp | 1 | factor(cyl) ~ qsec, data = mtcars) expect_no_error( res <- mod |> tidy_plus_plus() ) expect_equal(nrow(res[res$instrumental, ]), 3L) }) 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_no_error( res <- mod |> tidy_plus_plus() ) 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) h <- housing h$status <- factor( h$y, labels = c("street", "community", "independant") ) mod <- multgee::nomLORgee( status ~ factor(time) * sec, data = h, id = id, repeated = time, ) expect_no_error( res <- mod |> tidy_plus_plus() ) expect_equal( res$y.level, c( "street", "street", "street", "street", "street", "street", "street", "street", "community", "community", "community", "community", "community", "community", "community", "community" ) ) expect_equal( 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_no_error( res <- mod2 |> tidy_plus_plus() ) }) 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_no_error( res <- m1 |> tidy_plus_plus(exponentiate = TRUE, tidy_fun = tidy_zeroinfl) ) expect_equal(nrow(res), 10) expect_no_error( res <- m1 |> tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl) ) expect_equal(nrow(res), 12) expect_no_error( res <- m2 |> tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl) ) expect_equal(nrow(res), 7) expect_no_error( res <- m3 |> tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl) ) expect_equal(nrow(res), 9) expect_no_error( res <- m4 |> tidy_plus_plus(intercept = TRUE, tidy_fun = tidy_zeroinfl) ) 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_no_error( res <- m1 |> tidy_plus_plus(intercept = TRUE) ) expect_equal(nrow(res), 13) expect_no_error( res <- m1 |> tidy_plus_plus(exponentiate = TRUE) ) expect_equal(nrow(res), 11) expect_no_error( res <- m1 |> tidy_plus_plus(add_header_rows = TRUE) ) expect_equal(nrow(res), 12) expect_no_error( res <- m2 |> tidy_plus_plus(intercept = TRUE) ) expect_equal(nrow(res), 15) expect_no_error( res <- m2 |> tidy_plus_plus(exponentiate = TRUE) ) expect_equal(nrow(res), 13) expect_no_error( res <- m2 |> tidy_plus_plus(component = "conditional") ) expect_equal(nrow(res), 11) expect_no_error( res <- m2 |> tidy_plus_plus(add_header_rows = TRUE) ) expect_equal(nrow(res), 14) expect_no_error( res <- m3 |> tidy_plus_plus(intercept = TRUE) ) expect_equal(nrow(res), 14) expect_no_error( res <- m3 |> tidy_plus_plus(exponentiate = TRUE) ) expect_equal(nrow(res), 12) expect_no_error( res <- m3 |> tidy_plus_plus(component = "mean") ) expect_equal(nrow(res), 1) expect_error( m3 |> tidy_plus_plus(add_pairwise_contrasts = TRUE) ) expect_no_error( res <- m4 |> tidy_plus_plus(add_header_rows = TRUE) ) expect_equal(nrow(res), 24) }) test_that("tidy_plus_plus() works with mmrm::mmrm() models", { skip_on_cran() skip_if_not_installed("mmrm") m1 <- mmrm::mmrm(FEV1 ~ SEX + ARMCD + AVISIT + us(AVISIT | USUBJID), data = mmrm::fev_data) m2 <- mmrm::mmrm(FEV1 ~ SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), data = mmrm::fev_data) expect_no_error( res <- m1 |> tidy_plus_plus(intercept = TRUE) ) expect_equal(nrow(res), 9) expect_no_error( res <- m1 |> tidy_plus_plus(add_header_rows = TRUE) ) expect_equal(nrow(res), 11) expect_no_error( res <- m2 |> tidy_plus_plus(intercept = TRUE) ) expect_equal(nrow(res), 12) expect_no_error( res <- m2 |> tidy_plus_plus(add_header_rows = TRUE) ) expect_equal(nrow(res), 15) }) test_that("tidy_post_fun argument of `tidy_plus_plus()`", { mod <- lm(Petal.Length ~ Petal.Width + Species, iris) add_titi <- function(x) { x$titi <- "titi" x } expect_no_error( res <- tidy_plus_plus(mod, tidy_post_fun = add_titi) ) expect_true("titi" %in% names(res)) expect_true(res$titi[1] == "titi") keep_2_rows <- function(res) { head(res, n = 2) } expect_no_error( res <- tidy_plus_plus(mod, tidy_post_fun = keep_2_rows) ) expect_equal(nrow(res), 2L) }) # test for survival::cch() not working, model.frame() not working # in the test_that environment for this type of model test_that("tidy_plus_plus() works with glmtoolbox::glmgee() models", { skip_on_cran() skip_if_not_installed("glmtoolbox") data("spruces", package = "glmtoolbox") mod <- glmtoolbox::glmgee( size ~ poly(days, 4) + treat, id = tree, family = Gamma(log), corstr = "AR-M-dependent(1)", data = spruces ) expect_no_error( res <- mod |> tidy_plus_plus() ) expect_equal(nrow(res), 6) }) broom.helpers/tests/testthat/test-helpers.R0000644000176200001440000000055414737437002020610 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_no_error( .superscript_numbers(1:4) ) }) broom.helpers/tests/testthat/test-select_variables.R0000644000176200001440000000462514737437002022460 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_equal(res, res2) # include res2 <- res |> tidy_select_variables(include = "stage") expect_equal( res2$variable, c("(Intercept)", "stage", "stage", "stage") ) res2 <- res |> tidy_select_variables(include = c("grade", "trt")) expect_equal( res2$variable, c("(Intercept)", "grade", "grade", "trt") ) res2 <- res |> tidy_select_variables(include = c("trt", "grade")) expect_equal( res2$variable, c("(Intercept)", "trt", "grade", "grade") ) res2 <- res |> tidy_select_variables(include = c(trt, grade, dplyr::everything())) expect_equal( res2$variable, c("(Intercept)", "trt", "grade", "grade", "stage", "stage", "stage") ) # select and de-select expect_equal( res |> tidy_select_variables(include = stage), res |> tidy_select_variables(include = -c(grade, trt)) ) # tidyselect fns expect_equal( res |> tidy_select_variables(include = contains("tage")), res |> tidy_select_variables(include = stage) ) # no error when none selected expect_no_error( res |> tidy_select_variables(include = starts_with("zzzzzzz")) ) expect_no_error( res |> tidy_select_variables(include = -everything()) ) expect_no_error( res |> tidy_select_variables(include = where(is.character)) ) # 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_equal( 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_no_error( mod |> tidy_and_attach() |> tidy_select_variables() |> tidy_select_variables() ) }) broom.helpers/tests/testthat/test-get_response_variable.R0000644000176200001440000000110014657100641023471 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_estimate_to_reference_rows.R0000644000176200001440000003164514746151320025364 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_no_error( res <- mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows() ) expect_no_error( res2 <- mod |> tidy_and_attach(conf.level = .8) |> tidy_add_estimate_to_reference_rows() ) expect_no_error( res3 <- mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows(conf.level = .8) ) 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( 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_no_message( res <- mod |> tidy_and_attach(tidy_fun = broom::tidy) |> tidy_add_estimate_to_reference_rows() ) expect_equal( 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_equal(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_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_estimate_to_reference_rows() ) }) 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_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_estimate_to_reference_rows() ) }) test_that("tidy_add_estimate_to_reference_rows() works with survival::coxph", { skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) test_that("tidy_add_estimate_to_reference_rows() works with survival::survreg", { skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ factor(ecog.ps) + rx, survival::ovarian, dist = "exponential" ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) # 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) test_that("tidy_add_estimate_to_reference_rows() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) test_that("tidy_add_estimate_to_reference_rows() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_estimate_to_reference_rows()) }) broom.helpers/tests/testthat/test-assert_package.R0000644000176200001440000000232014737437002022113 0ustar liggesuserstest_that(".assert_package() works", { # broom will always be installed with broom.helpers expect_no_error( .assert_package("broom") ) 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_no_error( df_deps <- .get_package_dependencies() ) expect_true( df_deps |> inherits("data.frame") ) expect_equal( names(df_deps), c("pkg_search", "pkg_search_version", "dependency_type", "pkg", "version", "compare") ) expect_no_error( deps <- .get_all_packages_dependencies() ) 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-marginal_tidiers.R0000644000176200001440000002746414746125043022473 0ustar liggesuserstest_that("tidy_margins()", { skip_on_cran() skip_if_not_installed("margins") mod <- lm(Petal.Length ~ Petal.Width + Species, data = iris) expect_no_error( suppressWarnings(t <- tidy_margins(mod)) ) expect_error( tidy_margins(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_margins) ) 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_no_error( t <- tidy_all_effects(mod) ) expect_error( tidy_all_effects(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_all_effects) ) 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_no_error( t <- tidy_ggpredict(mod) ) expect_error( tidy_ggpredict(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_ggpredict) ) 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") iris <- iris |> dplyr::arrange(dplyr::desc(Species)) mod <- lm(Petal.Length ~ Petal.Width + Species + Sepal.Length, data = iris) expect_no_error( t <- tidy_marginal_predictions(mod) ) expect_equal(t[t$variable == "Species", "term"], levels(iris$Species)) mod <- lm(Petal.Length ~ Petal.Width * Species + Sepal.Length, data = iris) expect_no_error( t <- tidy_marginal_predictions(mod) ) expect_error( tidy_marginal_predictions(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_marginal_predictions) ) 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_no_error( t <- tidy_marginal_predictions(mod, "no_interaction") ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, variables_list = "no_interaction" ) ) expect_equal( nrow(res), nrow(t) ) expect_false(any(res$var_type == "interaction")) expect_no_error( t <- tidy_marginal_predictions(mod, newdata = "mean") ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, newdata = "mean" ) ) expect_equal( attr(res, "coefficients_label"), "Marginal Predictions at the Mean" ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_predictions, newdata = "balanced" ) ) 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_no_error( t <- tidy_avg_slopes(mod) ) expect_error( tidy_avg_slopes(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_avg_slopes) ) 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_no_error( t <- tidy_avg_slopes(mod, newdata = "mean") ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_slopes, newdata = "mean" ) ) expect_equal( attr(res, "coefficients_label"), "Marginal Effects at the Mean" ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_slopes, newdata = "balanced" ) ) 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_no_error( t <- tidy_marginal_contrasts(mod) ) expect_error( tidy_marginal_contrasts(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_marginal_contrasts) ) 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_no_error( t <- tidy_marginal_contrasts(mod, "no_interaction") ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, variables_list = "no_interaction" ) ) expect_equal( nrow(res), nrow(t) ) expect_false(any(res$var_type == "interaction")) expect_no_error( t <- tidy_marginal_contrasts(mod, newdata = "mean") ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, newdata = "mean" ) ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at the Mean" ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_marginal_contrasts, newdata = "balanced" ) ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at Marginal Means" ) }) 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_no_error( t <- tidy_avg_comparisons(mod) ) expect_error( tidy_avg_comparisons(mod, exponentiate = TRUE) ) expect_no_error( res <- tidy_plus_plus(mod, tidy_fun = tidy_avg_comparisons) ) 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_no_error( t <- tidy_avg_comparisons(mod, newdata = "mean"), ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_comparisons, newdata = "mean" ) ) expect_equal( attr(res, "coefficients_label"), "Marginal Contrasts at the Mean" ) expect_no_error( res <- tidy_plus_plus( mod, tidy_fun = tidy_avg_comparisons, newdata = "balanced" ) ) 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_no_error( res <- tidy_all_effects(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_ggpredict(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_avg_slopes(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_avg_comparisons(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_marginal_predictions(mod) ) expect_true("y.level" %in% names(res)) expect_type( p <- plot_marginal_predictions(mod), "list" ) expect_length(p, 3) expect_no_error( res <- tidy_marginal_contrasts(mod) ) 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_no_error( suppressMessages(res <- tidy_margins(mod)) ) # for margins, no result per y.level expect_no_error( suppressMessages(res <- tidy_all_effects(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_ggpredict(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_avg_slopes(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_avg_comparisons(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_marginal_predictions(mod)) ) expect_true("y.level" %in% names(res)) expect_type( suppressMessages(p <- plot_marginal_predictions(mod)), "list" ) expect_length(p, 3) expect_no_error( suppressMessages(res <- tidy_marginal_contrasts(mod)) ) 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_no_error( res <- tidy_all_effects(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( suppressMessages(res <- tidy_ggpredict(mod)) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_avg_slopes(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_avg_comparisons(mod) ) expect_true("y.level" %in% names(res)) expect_no_error( res <- tidy_marginal_predictions(mod) ) expect_true("y.level" %in% names(res)) expect_type( p <- plot_marginal_predictions(mod), "list" ) expect_length(p, 1) expect_no_error( res <- tidy_marginal_contrasts(mod) ) expect_true("y.level" %in% names(res)) }) broom.helpers/tests/testthat/test-attach_and_detach.R0000644000176200001440000000211514737437002022537 0ustar liggesuserstest_that("Attach and Detach models works", { mod <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris) expect_identical( mod, mod |> tidy_and_attach(model_matrix_attr = FALSE) |> tidy_get_model() ) tb <- broom::tidy(mod) expect_equal( tb, tb |> tidy_attach_model(mod) |> tidy_detach_model(), ignore_attr = TRUE ) # 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_no_error(mod |> tidy_and_attach()) }) broom.helpers/tests/testthat/test-remove_intercept.R0000644000176200001440000000131014737437002022507 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_no_error( mod |> tidy_and_attach() |> tidy_remove_intercept() |> tidy_remove_intercept() ) }) broom.helpers/tests/testthat/test-identify_variables.R0000644000176200001440000004404014746151432023007 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_equal( res$variable, c("response", "age", "grade", "trt", "death", "grade:trt") ) expect_equal( res$variable, mod |> model_list_variables(only_variable = TRUE) ) expect_equal( 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_equal( res$var_class, c("numeric", "logical"), ignore_attr = TRUE ) expect_equal( res$var_label, c("MARKER", "RESPONSE"), ignore_attr = TRUE ) 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_equal( res$variable, c("(Intercept)", "age", "grade", "grade", "trt", "death", "grade:trt", "grade:trt") ) expect_equal( res$var_class, c(NA, "numeric", "factor", "factor", "character", "integer", NA, NA), ignore_attr = TRUE ) expect_equal( res$var_type, c( "intercept", "continuous", "categorical", "categorical", "dichotomous", "continuous", "interaction", "interaction" ) ) expect_equal( res$var_nlevels, c(NA, NA, 3L, 3L, 2L, NA, NA, NA), ignore_attr = TRUE ) }) 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_no_error( mod |> tidy_and_attach() |> tidy_identify_variables() |> tidy_identify_variables() ) 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_equal( res |> dplyr::filter(variable == "response") |> purrr::pluck("var_type"), "dichotomous" ) expect_equal( res |> dplyr::filter(variable == "response") |> purrr::pluck("var_nlevels"), 2, ignore_attr = TRUE ) expect_equal( 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_equal( res$variable, c( NA, "stage", "stage", "stage", "grade", "grade", "trt", "grade:trt", "grade:trt" ) ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) 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_equal( res$variable, c(NA, "stage", "stage", "stage", "grade", "grade", "trt", "grade:trt", "grade:trt") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( res$variable, c( NA, "Sepal.Width", "Sepal.Width", "Sepal.Width", "Petal.Length", "Petal.Length" ) ) expect_no_error(tb <- mod |> tidy_and_attach() |> tidy_identify_variables()) expect_equal( 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_equal( res$variable, c( "(Intercept)", "marker", "grade of kids", "grade of kids", "marker:grade of kids", "marker:grade of kids" ) ) expect_equal( res$var_class, c(NA, "numeric", "factor", "factor", NA, NA), ignore_attr = TRUE ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) # interaction only term mod <- lm(age ~ marker:`grade of kids`, df) expect_equal( mod |> model_list_variables(only_variable = TRUE), c("age", "marker", "grade of kids", "marker:grade of kids") ) expect_equal( 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_equal( 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_equal( res$variable, c( "treatment +name", "disease stage", "disease stage", "disease stage" ) ) expect_equal( 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_equal( 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_equal( res$variable, c(NA, "Days") ) expect_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_identify_variables() ) 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_equal( res$variable, c(NA, "period", "period", "period") ) expect_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_identify_variables() ) }) test_that("model_identify_variables() works with survival::coxph", { skip_if_not_installed("survival") 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_equal( res$variable, c("ph.ecog", "age", "sex") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) test_that("model_identify_variables() works with survival::survreg", { skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) res <- mod |> model_identify_variables() expect_equal( res$variable, c(NA, "ecog.ps", "rx") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( res$variable, c(NA, "stage", "stage", "stage", "marker", "age") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) res <- mod |> tidy_and_attach() |> tidy_identify_variables() expect_equal( 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_equal( 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_equal( 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_equal( 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_equal( res$variable, c(NA, "age", "grade", "grade", "trt", "grade:trt", "grade:trt") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( 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_equal( 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_equal( 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_equal( 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_equal( # 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_equal( 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_equal( res$variable, c(NA, "Infl", "Infl", "Type", "Type", "Type", "Cont") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( res$variable, c(NA, "Cu", "Cu", "Time", "Cu:Time", "Cu:Time") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( res$variable, c(NA, "gam::s(Age, 4)", "Number") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) 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_equal( res$variable, c(NA, "gam::lo(Solar.R)", "gam::lo(Wind, Temp)", "gam::lo(Wind, Temp)") ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) }) 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_equal( res$variable, mod@ParTable$lhs ) expect_no_error(mod |> tidy_and_attach() |> tidy_identify_variables()) expect_vector( mod |> model_list_variables(only_variable = TRUE) ) }) test_that("model_identify_variables() message when failure", { skip_if_not_installed("survival") trial <- gtsummary::trial 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, family = poisson, data = glmmTMB::Salamanders ) ) res <- mod |> model_identify_variables() expect_equal( res$variable, c( NA, "mined", "spp", "spp", "spp", "spp", "spp", "spp" ) ) expect_no_error( mod |> tidy_and_attach() |> tidy_identify_variables() ) }) 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_equal( mod |> model_get_model_matrix() |> colnames(), c("(Intercept)", "value", "capital") ) expect_equal( res$term, c("(Intercept)", "value", "capital") ) expect_equal( res$variable, c(NA, "value", "capital") ) }) broom.helpers/tests/testthat/test-add_pairwise_contrasts.R0000644000176200001440000000364014737437002023700 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_equal( 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_equal( res$term, c( "(Intercept)", "T2 / T1", "T3 / T1", "T3 / T2", "T4 / T1", "T4 / T2", "T4 / T3", "Drug B / Drug A" ) ) expect_equal( round(res$estimate, digits = 2), c(0.48, 0.62, 1.12, 1.82, 0.82, 1.33, 0.73, 1.24) ) expect_equal( 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_equal( res$term, c( "(Intercept)", "stageT2", "stageT3", "stageT4", "T1 / T2", "T1 / T3", "T1 / T4", "T2 / T3", "T2 / T4", "T3 / T4", "trtDrug B" ) ) expect_equal( 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_equal( 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_term_labels.R0000644000176200001440000003032214746151360022243 0ustar liggesuserstest_that("tidy_add_term_labels() works for basic models", { mod <- lm(Petal.Length ~ Petal.Width, iris) expect_no_error( mod |> tidy_and_attach() |> tidy_add_term_labels() ) df <- gtsummary::trial mod <- glm(response ~ age + grade + trt, df, family = binomial) res <- mod |> tidy_and_attach() |> tidy_add_term_labels() expect_equal( res$label, c("(Intercept)", "Age", "II", "III", "Drug B"), ignore_attr = TRUE ) 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_equal( res$label, c("(Intercept)", "Age", "I", "II", "III", "Drug A", "Drug B"), ignore_attr = TRUE ) # 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_equal( res$label, c( "the intercept", "Age", "I", "II", "third grade", "the reference term", "Drug B" ), ignore_attr = TRUE ) # no error if providing labels not corresponding to an existing variable # but display a message expect_no_error( mod |> tidy_and_attach() |> tidy_add_term_labels( labels = list(aaa = "aaa", bbb = "bbb", ccc = 44) ) ) 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_equal( res$label, c("(Intercept)", "0 * Marker Level (ng/mL)", "1 * Marker Level (ng/mL)"), ignore_attr = TRUE ) }) 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_no_error( mod |> tidy_and_attach() |> tidy_add_term_labels() |> tidy_add_term_labels() ) # 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_equal( 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" ), ignore_attr = TRUE ) # 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_equal( 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" ), ignore_attr = TRUE ) # 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_equal( 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" ), ignore_attr = TRUE ) # 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_equal( res$label, c( "setosa", "versicolor", "virginica", "Petal.Width", "setosa * Petal.Width", "versicolor * Petal.Width" ), ignore_attr = TRUE ) }) 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_no_error( mod |> tidy_and_attach() |> tidy_add_term_labels() ) }) 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_no_error( res <- mod |> tidy_and_attach() |> tidy_add_term_labels() ) expect_equal( 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" ), ignore_attr = TRUE ) # should not produce an error expect_no_error( res <- mod |> tidy_and_attach(exponentiate = TRUE) |> tidy_add_term_labels() ) expect_equal( 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" ), ignore_attr = TRUE ) }) 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_equal( res$label, c( "(Intercept)", "Marker Level (ng/mL)", "I", "II", "III", "0", "1", "Marker Level (ng/mL) * II", "Marker Level (ng/mL) * III" ), ignore_attr = TRUE ) expect_equal( 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 <- lm( response ~ `age at dx` + `drug type`, data = gtsummary::trial |> dplyr::select(response, `age at dx` = age, `drug type` = trt) ) |> tidy_and_attach() |> tidy_add_variable_labels(list(`age at dx` = "AGGGGGGGE")) |> tidy_add_term_labels() expect_equal( res$label, c("(Intercept)", "AGGGGGGGE", "Drug B"), ignore_attr = TRUE ) }) 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_equal( res$label, c( "(Intercept)", "Sepal.Width", "Sepal.Width²", "Sepal.Width³", "Petal.Length", "Petal.Length²" ), ignore_attr = TRUE ) }) 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_term_labels()) }) test_that("tidy_add_term_labels() works with survival::coxph", { skip_on_cran() skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) test_that("tidy_add_term_labels() works with survival::survreg", { skip_on_cran() skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) test_that("tidy_add_term_labels() works with ordinal::clm", { skip_on_cran() mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) expect_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_term_labels()) }) broom.helpers/tests/testthat/test-select_helpers.R0000644000176200001440000001523214737437002022146 0ustar liggesuserstest_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_no_error( tidy_add_variable_labels(mod_tidy, labels = where(is.numeric) ~ "NUMERIC") ) 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 are consistent with gtsummary", { skip_on_cran() skip_if_not_installed("gtsummary") mod <- glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) x <- mod |> tidy_and_attach() |> tidy_identify_variables() |> tidy_add_contrasts() |> scope_tidy() expect_equal( x |> dplyr::select(broom.helpers::all_categorical()) |> colnames(), x |> dplyr::select(gtsummary::all_categorical()) |> colnames() ) expect_equal( x |> dplyr::select(broom.helpers::all_continuous()) |> colnames(), x |> dplyr::select(gtsummary::all_continuous()) |> colnames() ) expect_equal( x |> dplyr::select(broom.helpers::all_contrasts("treatment")) |> colnames(), x |> dplyr::select(gtsummary::all_contrasts("treatment")) |> colnames() ) expect_equal( x |> dplyr::select(broom.helpers::all_dichotomous()) |> colnames(), x |> dplyr::select(gtsummary::all_dichotomous()) |> colnames() ) expect_equal( x |> dplyr::select(broom.helpers::all_interaction()) |> colnames(), x |> dplyr::select(gtsummary::all_interaction()) |> colnames() ) expect_equal( x |> dplyr::select(broom.helpers::all_intercepts()) |> colnames(), x |> dplyr::select(gtsummary::all_intercepts()) |> colnames() ) }) broom.helpers/tests/testthat/test-group_by.R0000644000176200001440000000402514760117574020776 0ustar liggesuserstest_that("tidy_group_by() works for basic models", { mod <- glm(response ~ stage + grade + trt, gtsummary::trial, family = binomial) expect_no_error( res <- mod |> tidy_and_attach() |> tidy_group_by() ) expect_false("group_by" %in% colnames(res)) expect_no_error( res <- mod |> tidy_and_attach() |> tidy_identify_variables() |> tidy_group_by(group_by = var_type) ) expect_true("group_by" %in% colnames(res)) expect_true(is.factor(res$group_by)) expect_equal(as.character(res$group_by), res$var_type) }) test_that("tidy_group_by() works with nnet::multinom", { skip_if_not_installed("nnet") skip_if_not_installed("gtsummary") mod <- nnet::multinom( grade ~ stage + marker + age, data = gtsummary::trial, trace = FALSE ) expect_no_error( res <- mod |> tidy_and_attach() |> tidy_group_by() ) expect_true("group_by" %in% colnames(res)) expect_equal( levels(res$group_by), c("II", "III") ) expect_message( res <- mod |> tidy_and_attach() |> tidy_group_by(group_labels = c(IV = "not found")) ) expect_no_error( res <- mod |> tidy_and_attach() |> tidy_group_by(group_labels = c(III = "group 3")) ) expect_error( res <- mod |> tidy_and_attach() |> tidy_group_by(group_labels = c("group 3")) ) expect_equal( levels(res$group_by), c("II", "group 3") ) expect_no_error( res <- mod |> tidy_and_attach() |> tidy_identify_variables() |> tidy_group_by(group_by = c(var_type, y.level)) ) expect_equal( length(levels(res$group_by)), 6 ) x <- mod |> tidy_and_attach() |> tidy_identify_variables() # by default, keep any pre-existing group_by expect_equal( x |> tidy_group_by(group_by = "var_type"), x |> tidy_group_by(group_by = "var_type") |> tidy_group_by() ) # NULL to remove any pre-existing group_by expect_equal( x, x |> tidy_group_by() |> tidy_group_by(group_by = NULL) ) }) broom.helpers/tests/testthat/test-list_higher_order_variables.R0000644000176200001440000000126014657100641024662 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_variable_labels.R0000644000176200001440000002422414746151400023060 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_equal( res$var_label, c("(Intercept)", "age", "grade", "grade", "trt"), ignore_attr = TRUE ) # 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_equal( res$var_label, c("(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment"), ignore_attr = TRUE ) # 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_equal( res$var_label, c( "custom intercept", "Age", "custom label", "custom label", "Chemotherapy Treatment" ), ignore_attr = TRUE ) # 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_equal( res$var_label, c( "custom intercept", "Age", "custom label", "custom label", "Chemotherapy Treatment" ), ignore_attr = 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_equal( res$var_label, c( "(Intercept)", "factor(response) * Marker Level (ng/mL)", "factor(response) * Marker Level (ng/mL)" ), ignore_attr = TRUE ) # 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_equal( res$var_label, c( "(Intercept)", "Age", "Grade", "Grade", "Chemotherapy Treatment", "custom label", "custom label" ), ignore_attr = TRUE ) }) 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_no_error( mod |> tidy_and_attach() |> tidy_add_variable_labels() |> tidy_add_variable_labels() ) # 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_equal( 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" ), ignore_attr = TRUE ) # 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_equal( 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" ), ignore_attr = TRUE ) }) 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_equal( res$var_label, c( "(Intercept)", "Marker Level (ng/mL)", "Grade", "Grade", "Marker Level (ng/mL) * Grade", "Marker Level (ng/mL) * Grade" ), ignore_attr = TRUE ) }) 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_equal( res$var_label, c( "(Intercept)", "Width of sepal", "Width of sepal", "Width of sepal", "Petal.Length", "Petal.Length" ), ignore_attr = TRUE ) }) 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_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_variable_labels() ) }) 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_no_error( mod |> tidy_and_attach(tidy_fun = broom.mixed::tidy) |> tidy_add_variable_labels() ) }) test_that("tidy_add_variable_labels() works with survival::coxph", { skip_if_not_installed("survival") df <- survival::lung |> dplyr::mutate(sex = factor(sex)) mod <- survival::coxph(survival::Surv(time, status) ~ ph.ecog + age + sex, data = df) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) # 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_equal( res$var_label, c("Grade", "Grade", "Grade"), ignore_attr = TRUE ) }) test_that("tidy_add_variable_labels() works with survival::survreg", { skip_if_not_installed("survival") mod <- survival::survreg( survival::Surv(futime, fustat) ~ ecog.ps + rx, survival::ovarian, dist = "exponential" ) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) # 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_equal( res$var_label, c("(Intercept)", "Grade", "Grade", "Grade", "Log(scale)"), ignore_attr = TRUE ) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) test_that("tidy_add_variable_labels() works with ordinal::clm", { mod <- ordinal::clm(rating ~ temp * contact, data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) test_that("tidy_add_variable_labels() works with ordinal::clmm", { mod <- ordinal::clmm(rating ~ temp * contact + (1 | judge), data = ordinal::wine) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) test_that("tidy_add_variable_labels() works with MASS::polr", { mod <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = MASS::housing) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) mod <- suppressWarnings(gam::gam( Ozone^(1 / 3) ~ gam::lo(Solar.R) + gam::lo(Wind, Temp), data = datasets::airquality, na = gam::na.gam.replace )) expect_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) 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_no_error(mod |> tidy_and_attach() |> tidy_add_variable_labels()) }) broom.helpers/tests/testthat.R0000644000176200001440000000064214737437002016167 0ustar liggesusers# This file is part of the standard setup for testthat. # It is recommended that you do not modify it. # # Where should you do additional test configuration? # Learn more about the roles of various files in: # * https://r-pkgs.org/testing-design.html#sec-tests-files-overview # * https://testthat.r-lib.org/articles/special-files.html library(testthat) library(broom.helpers) test_check("broom.helpers") broom.helpers/tests/spelling.R0000644000176200001440000000023314457457144016150 0ustar liggesusersif (requireNamespace("spelling", quietly = TRUE)) { spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) } broom.helpers/MD50000644000176200001440000002277314762300062013354 0ustar liggesusers929c6aa8f26ae9d7e69360d3f3af9123 *DESCRIPTION 9fe8d55beb95908924c175dba98f8e8d *NAMESPACE 9ada1a0496318b288b3078a100c2eef5 *NEWS.md c0c2b1483fe244a0247c532c2f1bcdb9 *R/assert_package.R 40f53f93a5a3a373f00885dd877524a2 *R/broom.helpers-package.R d0885edab7700fd041c7ba2deac303f6 *R/custom_tidiers.R 55c01d0cb58801ae0da3678caab51782 *R/data.R 59c7df87ce1acd7ba9c4f7aad7c4239f *R/helpers.R 4898b975e8837649f56dc6888fe20ed1 *R/marginal_tidiers.R e47a12b18778cd7c9d8ef26b137c38c9 *R/model_compute_terms_contributions.R 153ef55b5f1caf9b9513518affff1d64 *R/model_get_assign.R 2dae3ac14d4c53a1dec2eda1d0308fe5 *R/model_get_coefficients_type.R 4e68b1f45c450393dbaa2684807737c4 *R/model_get_contrasts.R 2c2e345609771004544112c0d1aacb5f *R/model_get_model.R 7273a1c9a79b13692418751505aa012a *R/model_get_model_frame.R 125804f480c24b9247e907476868d228 *R/model_get_model_matrix.R 184df543bf96e92acec12e4ee2f09667 *R/model_get_n.R 6661dcb9969a63f0f5500b4c5e4c814b *R/model_get_nlevels.R d3a14c9624976cb8394dcd863c90270f *R/model_get_offset.R 1b51387e589461772bf258145fbb98db *R/model_get_pairwise_contrasts.R 981f00c549e20d79a39cd837189370c7 *R/model_get_response.R 41699c4bbbb22ad1b8ddc977a8d707d3 *R/model_get_response_variable.R e013106266738a81b0d8c8aa1ada0bf0 *R/model_get_terms.R 5efd335abe9f7ed01519ef30cc545e42 *R/model_get_weights.R 6dd3f5857311ee989f245e3fb16bf4d7 *R/model_get_xlevels.R f70a9b7adc76d6cb5dd5c9fed055ef77 *R/model_identify_variables.R e4b73e9e5a5b6c0aad59d5c9e72a5ece *R/model_list_contrasts.R 0126e872921ecfb2e8f0118e1642aef0 *R/model_list_higher_order_variables.R da1349b2ab8d4eefafad6a7dedeff678 *R/model_list_terms_levels.R 1f8a8ca147281bcc28d51735db4078b3 *R/model_list_variables.R 4f7183ad35cc4ccb38ba3f3bd8e55f90 *R/reexport.R 6a5bffbf22b5df7edf44cbe3bfd787a9 *R/scope_tidy.R dc309a500295f12df76568c1dfc63d75 *R/select_helpers.R 73fee68a4b1ff32a6ee6b80f52191554 *R/select_utilities.R 29b12bd6276a04e2f1e68b525139b8ef *R/tidy_add_coefficients_type.R 0991b975cdc22c7c63e612d06e5a4417 *R/tidy_add_contrasts.R d09b9d8e9296fca90d5fcd7fc1490b7e *R/tidy_add_estimate_to_reference_rows.R 4ea186803d2c70a776a6e29770821dc6 *R/tidy_add_header_rows.R d1ce74e5da7cefcc737b8e67e146f363 *R/tidy_add_n.R 03338b55a3cbb94fc4ea1a8d64ef2b59 *R/tidy_add_pairwise_contrasts.R f0e1c7246c030af82c80647ea17f3265 *R/tidy_add_reference_rows.R 9ddcf804cd69dee52ef07d5aefd19a32 *R/tidy_add_term_labels.R 8d29f43752a8a165867246182e4c04a8 *R/tidy_add_variable_labels.R 6973990fd0f016ac15212ec80cad0f93 *R/tidy_and_attach.R 968602708b80575b20d606fb017605fb *R/tidy_disambiguate_terms.R 7d80eeb809df09194bee4cb2ee56a178 *R/tidy_group_by.R 7e992a1e1cc7075654ebe70ab8cc8112 *R/tidy_identify_variables.R 3a044d5c364535270fbcc0bd397d51fd *R/tidy_plus_plus.R 2c50b62ae7a47d4292a306692e8f0d5b *R/tidy_remove_intercept.R 035d05f01564f8004d0597512dd1fbd2 *R/tidy_select_variables.R 09fb518a30134ddf8731c8851968659e *README.md 1ed1e11d74ad735fcfa214aa2bba7380 *build/vignette.rds 03d82d43d6bbef6bfc487007711178ee *data/supported_models.rda ed6939e84ab6650aea8ec1b985fbf74f *inst/WORDLIST a9d6f4ca4bcb27388fd1ae1477c6aa91 *inst/doc/broom-helpers.R 2f3082870468cf8eb0d73a3fec2da17d *inst/doc/broom-helpers.Rmd 04f13cea6ac91e185539e46e5ab726f2 *inst/doc/broom-helpers.html a21cffa18f02b81b15bfeee342b658d7 *man/assert_package.Rd 6681ea547286b75364f990db9e6e2f05 *man/dot-clean_backticks.Rd 2db273b6845e020c0cf3d1615ed6c412 *man/dot-escape_regex.Rd abe218b0239b70cd55bbe523342d8681 *man/dot-formula_list_to_named_list.Rd 26a6f7c3c79c52613f883b746d6baae0 *man/dot-generic_selector.Rd 364f1c7cdf54ead222018dee2d4cbd9b *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 6495fbbedc102387d4e590ac98badcd6 *man/model_compute_terms_contributions.Rd 7cf7f450f9baa79bc89188fbef8fbd35 *man/model_get_assign.Rd d87839485e44a3df16f1964a5e0291c6 *man/model_get_coefficients_type.Rd 5455b0999d6682695d327ae1e8ba0a51 *man/model_get_contrasts.Rd ee11c0322a8a83fd58c283c79ba4a25d *man/model_get_model.Rd b97fa7b2b24144a6f33aacaa5efc2af1 *man/model_get_model_frame.Rd 9bbceee4b36bd9d7797ed4995d62529e *man/model_get_model_matrix.Rd 6971fa9f16acd808db40f798d78db791 *man/model_get_n.Rd 5d60ada9bf6e6909abb1d2a0904a1767 *man/model_get_nlevels.Rd 9b194fbdf0d1c5336f6668d8aaf4e6ce *man/model_get_offset.Rd 142bebfe4d7a8cf6b1b0b94b83cc98e6 *man/model_get_pairwise_contrasts.Rd 4314fd41b27617c07db5e737ed6ad93b *man/model_get_response.Rd 9297d54dd9b81d3c1e6b2e4fd78b1e67 *man/model_get_response_variable.Rd 2760369d4eae1453f21a62ec45c90138 *man/model_get_terms.Rd 0e26db144da4670d95148eea5217beb0 *man/model_get_weights.Rd 5f62fb0e739dc5e464e2d61f02f90012 *man/model_get_xlevels.Rd 38f6e17db9fc1b8402ef85a5b8298ddf *man/model_identify_variables.Rd 7c1e39a8cff634158fe1c43d994dc70a *man/model_list_contrasts.Rd 183315fa89e8eaf32e9c85e96d61c873 *man/model_list_higher_order_variables.Rd 884fd9b2dc295873305ee004be9b524e *man/model_list_terms_levels.Rd 20c4e61c70a2ca7ae79b2abe21f8e75e *man/model_list_variables.Rd 449cdc1eb57a0ea7bc9cd001b8e9912e *man/reexports.Rd 9a8c30eac37032901a932097149c60bd *man/scope_tidy.Rd 612623970da6cb32eeedb428b77cf085 *man/select_helpers.Rd e6c8e7af99782dc71b155bf0d1fe6bb2 *man/seq_range.Rd c128ba182f917df9442714e4ceee09f1 *man/supported_models.Rd aacae87348744f8fae3fbc01a0f5844c *man/tidy_add_coefficients_type.Rd 14a129f2cf311372a96a5766f26390ef *man/tidy_add_contrasts.Rd 2ab3fcd5099dddc9b1c743c523a97160 *man/tidy_add_estimate_to_reference_rows.Rd 84ed1d2b172c5dd5630ae31487638006 *man/tidy_add_header_rows.Rd edc25fadab6359ea5e654569fec0b6a7 *man/tidy_add_n.Rd d564f2e3938989889488b287c12d67db *man/tidy_add_pairwise_contrasts.Rd f8fb0ec584ba472d978ce648af372816 *man/tidy_add_reference_rows.Rd eb00a3a419f9152e8f7e14dd650fe95c *man/tidy_add_term_labels.Rd 2f2d02c5593d6763fd90eb0e8254b94c *man/tidy_add_variable_labels.Rd 8c58d6b2542b37aef19d3a8dd9bd1f52 *man/tidy_all_effects.Rd dbe3adfc11c3b052dab6b507c33da780 *man/tidy_attach_model.Rd 4c40f31c7572ec52ffb87676e3b03464 *man/tidy_avg_comparisons.Rd 0896b2db8779badec07a4f9d000eb51f *man/tidy_avg_slopes.Rd f9c6ca9f30b371eff61c968931ffc5ac *man/tidy_broom.Rd 940320d5c314f4dc2986b55ff7ee9a14 *man/tidy_disambiguate_terms.Rd b23791fd608427f84644b1fe31c8617e *man/tidy_ggpredict.Rd 38ee878ecae4ff21c1608f56307a9d1f *man/tidy_group_by.Rd a63a0094867295222f16c4d5e907493f *man/tidy_identify_variables.Rd 98f2ceb284889b8cda426c5a07cfa06b *man/tidy_marginal_contrasts.Rd 733742b5d78f2fabf2c52da35da37f2f *man/tidy_marginal_means.Rd e9f2c2ecb962917e22710c6c380d12af *man/tidy_marginal_predictions.Rd 5466d4ab1edc7b8df59dd7a909f024a8 *man/tidy_margins.Rd 88a3602b5c0f3802b91b41a40bccc1b6 *man/tidy_multgee.Rd 3ff800ac045d743c1ae60b6d32679499 *man/tidy_parameters.Rd df8e44ec54c74b83c003494a219fa04f *man/tidy_plus_plus.Rd 7be8752d4a79fb428b707784e1193a25 *man/tidy_remove_intercept.Rd 0b2069d1a01f6322938296e1f7e519e7 *man/tidy_select_variables.Rd 8318791235fae36b8185750ac4e24890 *man/tidy_vgam.Rd 162a1bcd27a8573143d4cf76d1436153 *man/tidy_with_broom_or_parameters.Rd 022baf9ceff9b7a50659b38d39315b19 *man/tidy_zeroinfl.Rd dbd9bab057163c01c320d0b9d3bb9620 *tests/spelling.R 1dd85cf8fd0cc5201521d49efa4a8c39 *tests/testthat.R 15e605b87b7967eb112378f404cc50db *tests/testthat/test-add_coefficients_type.R 2eab4a92637551c9df12a1b7294034a6 *tests/testthat/test-add_contrasts.R 8c7c80069cfded4641236743283e7dd2 *tests/testthat/test-add_estimate_to_reference_rows.R dd8b1566fdb90eef81fbd18d807859b9 *tests/testthat/test-add_header_rows.R 1030d972fb9a3d4134981e1b52bd3853 *tests/testthat/test-add_n.R a73c64c33c9f122bc11eca37a24d42a7 *tests/testthat/test-add_pairwise_contrasts.R 0e6bc04febfed7b1b055f611cd960700 *tests/testthat/test-add_reference_rows.R 285bdc1ab8b381584dae1252746e380c *tests/testthat/test-add_term_labels.R 64938e7398558893c700323af7f0bbe1 *tests/testthat/test-add_variable_labels.R 85e55546ea237b80bb78499ef11b37d9 *tests/testthat/test-assert_package.R 2ef36e372c59e1223ec4f915edbc4f4b *tests/testthat/test-attach_and_detach.R 1fff0599fb3e66d72b4dc4520377d5f9 *tests/testthat/test-disambiguate_terms.R c404a048d8f29e7bf3ee8c75e6138c27 *tests/testthat/test-get_response_variable.R b5e6a9381fa34a0b22b5da36c1ed43db *tests/testthat/test-group_by.R f4731c67e076c417df8d311184787540 *tests/testthat/test-helpers.R 838d068bac1135541a1dec02baf3350e *tests/testthat/test-identify_variables.R a5a85d2e76c25c3120244350c8f5f72c *tests/testthat/test-list_higher_order_variables.R b4ec904d0042ac197b8baf770755c72f *tests/testthat/test-marginal_tidiers.R fe98cc4f237c1c331a6bfedb4d5870f4 *tests/testthat/test-model_get_n.R e4904e7fb88e62fb86eca53b3c248faa *tests/testthat/test-remove_intercept.R e173166dba02fe44a3a256b9dde0a1ff *tests/testthat/test-select_helpers.R cc09f90079b9e5502f3c9d658f9f05b9 *tests/testthat/test-select_variables.R 8852ffaa6f14cab1bcff7081bfff1148 *tests/testthat/test-tidy_parameters.R 0b5ff6aee8ad8c9436d65e4c9bbeb223 *tests/testthat/test-tidy_plus_plus.R 2f3082870468cf8eb0d73a3fec2da17d *vignettes/broom-helpers.Rmd broom.helpers/R/0000755000176200001440000000000014760322364013241 5ustar liggesusersbroom.helpers/R/tidy_disambiguate_terms.R0000644000176200001440000000450014760117574020271 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param sep (`string`)\cr #' Separator added between group name and term. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examples #' \donttest{ #' 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") && !inherits(model, "vgam") && # vgam models !inherits(model, "vglm") ) { 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( original_term = .data$term, term = dplyr::if_else( is.na(.data$group) | .data$group == "", .data$term, paste(.data$group, .data$term, sep = sep) ) ) } x |> tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/model_get_n.R0000644000176200001440000001502414662130321015631 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, #' exposure time and the number of individuals. #' #' 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 individuals (`N_ind`), 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, e.g. `glm`)\cr #' 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) mf <- stats::model.frame(model) # using stats::model.frame() to get (id) if (!"(id)" %in% names(mf)) mf[["(id)"]] <- seq_len(nrow(mf)) n_obs_per_ind <- mf |> dplyr::add_count(dplyr::pick("(id)")) |> dplyr::pull("n") n$n_ind <- colSums(tcm * w / n_obs_per_ind) attr(n, "N_ind") <- sum(w / n_obs_per_ind) 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/custom_tidiers.R0000644000176200001440000004175714762100307016430 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @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 .assert_package("parameters", boolean = TRUE) #' \donttest{ #' 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 (is.null(args$pretty_names)) args$pretty_names <- FALSE 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @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, ...) { exponentiate_later <- FALSE # 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, ...)) } if (inherits(x, "vglm")) { cli::cli_alert_info("{.cls vglm} model detected.") cli::cli_alert_success("{.fn tidy_vgam} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_vgam} to quiet these messages." ) return(tidy_vgam(x, conf.int = conf.int, conf.level = conf.level, ...)) } if (inherits(x, "vgam")) { cli::cli_alert_info("{.cls vgam} model detected.") cli::cli_alert_success("{.fn tidy_vgam} used instead.") cli::cli_alert_info( "Add {.code tidy_fun = broom.helpers::tidy_vgam} to quiet these messages." ) return(tidy_vgam(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.") } } # specific case for cch models # exponentiate and conf.int not supported by broom::tidy() if (inherits(x, "cch")) { if (isTRUE(tidy_args$exponentiate)) { exponentiate_later <- TRUE } tidy_args$exponentiate <- NULL tidy_args$conf.int <- NULL } # 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." ) } } # cleaning in conf.int = FALSE if (isFALSE(conf.int)) { res <- res |> dplyr::select(-dplyr::any_of(c("conf.low", "conf.high"))) } if (exponentiate_later) { res <- .exponentiate(res) } res } #' Tidy with `broom::tidy()` and checks that all arguments are used #' #' @param x (a model object, e.g. `glm`)\cr #' A model to be tidied. #' @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 #' #' 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 (`LORgee`)\cr #' A `multgee::nomLORgee()` or a `multgee::ordLORgee()` model. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to `parameters::model_parameters()`. #' @details #' To be noted, for `multgee::nomLORgee()`, the baseline `y` category is the #' latest modality of `y`. #' #' @export #' @family custom_tieders #' @examplesIf .assert_package("multgee", boolean = TRUE) #' \donttest{ #' library(multgee) #' #' h <- housing #' h$status <- factor( #' h$y, #' labels = c("street", "community", "independant") #' ) #' #' mod <- multgee::nomLORgee( #' status ~ factor(time) * sec, #' data = h, #' 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]])[-length(levels(mf[[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 #' #' 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 (`zeroinfl` or `hurdle`)\cr #' A `pscl::zeroinfl()` or a `pscl::hurdle()` model. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param component (`string`)\cr #' `NULL` or one of `"all"`, `"conditional"`, `"zi"`, or `"zero_inflated"`. #' @param ... Additional parameters passed to `parameters::model_parameters()`. #' @export #' @family custom_tieders #' @examplesIf .assert_package("pscl", boolean = TRUE) #' \donttest{ #' 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 } #' Tidy a `vglm` or a `vgam` model #' #' `r lifecycle::badge("experimental")` #' A tidier for models generated with `VGAM::vglm()` or `VGAM::vgam()`. #' Term names will be updated to be consistent with generic models. The original #' term names are preserved in an `"original_term"` column. Depending on the #' model, additional column `"group"`, `"component"` and/or `"y.level"` may be #' added to the results. #' @param x (`vglm` or `vgam`)\cr #' A `VGAM::vglm()` or a `VGAM::vgam()` model. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to `parameters::model_parameters()`. #' @export #' @family custom_tieders #' @examplesIf .assert_package("VGAM", boolean = TRUE) #' \donttest{ #' library(VGAM) #' mod <- vglm( #' Species ~ Sepal.Length + Sepal.Width, #' family = multinomial(), #' data = iris #' ) #' mod |> tidy_vgam(exponentiate = TRUE) #' mod <- vglm( #' Species ~ Sepal.Length + Sepal.Width, #' family = multinomial(parallel = TRUE), #' data = iris #' ) #' mod |> tidy_vgam(exponentiate = TRUE) #' } tidy_vgam <- function( x, conf.int = TRUE, conf.level = .95, ...) { if (!inherits(x, "vgam") && !inherits(x, "vglm")) { cli::cli_abort("{.arg x} should be of class {.cls vglm} or {.cls vgam}") } # nolint res <- tidy_parameters( x, conf.int = conf.int, conf.level = conf.level, ... ) res <- res |> dplyr::rename(original_term = .data$term) # identify groups res <- res |> dplyr::left_join( .vgam_identify_groups(x) |> dplyr::select(dplyr::all_of(c("original_term", "term", "group"))), by = "original_term" ) |> dplyr::relocate( dplyr::all_of(c("term", "group")), .after = dplyr::all_of("original_term") ) # component names if (!is.null(x@misc$predictors.names)) { res$component <- x@misc$predictors.names[as.integer(res$group)] if (!is.null(x@misc$parallel) && !isFALSE(x@misc$parallel)) { res$component <- res$component |> tidyr::replace_na("parallel") } else { res$component <- res$component |> tidyr::replace_na("") } } # identification of y.level (multinomial models) if ( !is.null(x@misc$refLevel) && length(x@misc$predictors.names) == length(x@misc$ynames) - 1 ) { ylevels <- x@misc$ynames[-x@misc$refLevel] res$y.level <- ylevels[as.integer(res$group)] res$y.level[res$component == "parallel"] <- "parallel" } # remove component if all empty if (all(res$component == "")) res <- res |> dplyr::select(-.data$component, -.data$group) res } # exploring assign and vassign from model.matrix to identify potential groups .vgam_identify_groups <- function(x) { # exploring assign and vassign from model.matrix to identify potential groups mm <- stats::model.matrix(x) a <- attr(mm, "assign") a <- dplyr::tibble(variable = names(a), pos = a) |> tidyr::unnest("pos") va <- attr(mm, "vassign") va <- dplyr::tibble(vvariable = names(va), pos = va) |> tidyr::unnest("pos") t <- mm |> colnames() t <- dplyr::tibble(original_term = t, pos = seq_along(t)) t <- t |> dplyr::full_join(a, by = "pos") |> dplyr::full_join(va, by = "pos") t$group <- t$vvariable |> stringr::str_sub(start = stringr::str_length(t$variable) + 2) t$term <- t$original_term |> stringr::str_sub( end = dplyr::if_else( stringr::str_length(t$group) == 0, -1L, -1 * stringr::str_length(t$group) - 2 ) ) t } broom.helpers/R/tidy_add_estimate_to_reference_rows.R0000644000176200001440000001543614762101413022633 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param exponentiate (`logical`)\cr #' Whether or not to exponentiate the coefficient estimates. It should be #' consistent with the original call to [broom::tidy()] #' @param conf.level (`numeric`)\cr #' Confidence level, by default use the value indicated #' previously in [tidy_and_attach()], used only for sum contrasts. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf require("gtsummary") && require("emmeans") #' \donttest{ #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(dplyr::across(where(is.character), factor)) #' #' glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$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_add_contrasts.R0000644000176200001440000000400614662130321017234 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @param quiet (`logical`)\cr #' 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"))) #' #' glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$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_and_attach.R0000644000176200001440000001154614662130321016501 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. #' @inheritParams tidy_plus_plus #' @param x (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param model_matrix_attr (`logical`)\cr #' Whether model frame and model matrix should be added as attributes of #' `model` (respectively named `"model_frame"` and `"model_matrix"`) and #' passed through #' @param .attributes (`list`)\cr #' 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, model_matrix_attr = TRUE, ...) { # 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 if (model_matrix_attr) { attr(model, "model_frame") <- model |> model_get_model_frame() attr(model, "model_matrix") <- model |> model_get_model_matrix() } 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_terms.R0000644000176200001440000000433414733566032016543 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, e.g. `glm`)\cr #' 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) } #' @export #' @rdname model_get_terms model_get_terms.betareg <- function(model) { model_get_terms(model$terms$full) } #' @export #' @rdname model_get_terms model_get_terms.cch <- function(model) { stats::terms.formula( model$call$formula |> stats::formula(), data = model |> model_get_model_frame() ) } #' @export #' @rdname model_get_terms #' @details #' For `fixest` models, return a term object combining main variables and #' instrumental variables. #' model_get_terms.fixest <- function(model) { fml <- model$fml fiv <- model$iv_endo_fml if (is.null(fiv)) { f <- fml } else { f <- paste( deparse(fml), "+", deparse(fiv[[3]]) ) |> stats::as.formula() } stats::terms(f) } broom.helpers/R/model_get_contrasts.R0000644000176200001440000000370414662130321017416 0ustar liggesusers#' Get contrasts used in the model #' #' @param model (a model object, e.g. `glm`)\cr #' 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/select_helpers.R0000644000176200001440000000707214762100662016370 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`)\cr #' Whether to include dichotomous variables, default is `TRUE`. #' @param contrasts_type (`string`)\cr #' 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", "sdif", "other")`. #' @param continuous2 (`logical`)\cr #' Whether to include continuous2 variables, default is `TRUE`. #' For compatibility with `{gtsummary}`), see [`gtsummary::all_continuous2()`]. #' #' @return A character vector of column names selected. #' @seealso [scope_tidy()] #' @examples #' \donttest{ #' glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) |> #' tidy_plus_plus(exponentiate = TRUE, include = all_categorical()) #' } #' @examplesIf .assert_package("emmeans", boolean = TRUE) #' \donttest{ #' 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(continuous2 = TRUE) { types <- if (continuous2) c("continuous", "continuous2") else "continuous" where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% types)) } #' @rdname select_helpers #' @export all_categorical <- function(dichotomous = TRUE) { types <- if (dichotomous) c("categorical", "dichotomous") else "categorical" where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% types)) } #' @rdname select_helpers #' @export all_dichotomous <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "dichotomous")) } #' @rdname select_helpers #' @export all_interaction <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "interaction")) } #' @rdname select_helpers #' @export all_ran_pars <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "ran_pars")) } #' @rdname select_helpers #' @export all_ran_vals <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "ran_vals")) } #' @rdname select_helpers #' @export all_intercepts <- function() { where(function(x) isTRUE(attr(x, "gtsummary.var_type") %in% "intercept")) } #' @rdname select_helpers #' @export all_contrasts <- function(contrasts_type = c("treatment", "sum", "poly", "helmert", "sdif", "other")) { # nolint contrasts_type <- rlang::arg_match(contrasts_type, multiple = TRUE) where(function(x) isTRUE(attr(x, "gtsummary.contrasts_type") %in% contrasts_type)) } broom.helpers/R/model_get_coefficients_type.R0000644000176200001440000001256714760117573021124 0ustar liggesusers#' Get coefficient type #' #' Indicate the type of coefficient among "generic", "logistic", #' "poisson", "relative_risk" or "prop_hazard". #' #' @param model (a model object, e.g. `glm`)\cr #' A model object. #' @export #' @family model_helpers #' @examples #' lm(hp ~ mpg + factor(cyl), mtcars) |> #' model_get_coefficients_type() #' #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' glm(Survived ~ Class + Age * Sex, data = df, weights = df$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.cch <- 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" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.vglm <- function(model) { if (model@family@vfamily[1] == "binomialff" && model@misc$link[1] == "logitlink") return("logistic") if (model@family@vfamily[1] == "poissonff" && model@misc$link[1] == "loglink") return("poisson") if (model@family@vfamily[1] == "negbinomial" && model@misc$link[1] == "loglink") return("poisson") if (model@family@vfamily[1] == "multinomial" && model@misc$link[1] == "multilogitlink") return("logistic") if (model@family@vfamily[1] == "cumulative" && model@misc$link[1] == "logitlink") return("logistic") "generic" } #' @export #' @rdname model_get_coefficients_type model_get_coefficients_type.vgam <- model_get_coefficients_type.vglm broom.helpers/R/model_list_terms_levels.R0000644000176200001440000001764414662130321020306 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, e.g. `glm`)\cr #' A model object. #' @param label_pattern ([`glue pattern`][glue::glue()])\cr #' A [glue pattern][glue::glue()] for term labels (see examples). #' @param variable_labels (`list` or `string`)\cr #' An optional named list or named vector of #' custom variable labels passed to [model_list_variables()] #' @param sdif_term_level (`string`)\cr #' 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 <- glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$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_n.R0000644000176200001440000001402114760117574015465 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 `n_ind`. `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 individuals #' (`N_ind`), of events (`N_event`) and of exposure time (`Exposure`) are #' stored as attributes of the returned tibble. #' #' @param x (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @export #' @family tidy_helpers #' @examples #' \donttest{ #' 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"))) #' #' glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$n, family = binomial, #' contrasts = list(Age = contr.sum, Class = "contr.helmert") #' ) |> #' tidy_and_attach() |> #' tidy_add_n() #' #' glm( #' Survived ~ Class * (Age:Sex), #' data = df, weights = df$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_ind"))) { .attributes$N_ind <- attr(n, "N_ind") } 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/model_identify_variables.R0000644000176200001440000001443414733566032020417 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, e.g. `glm`)\cr #' 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 #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' glm( #' Survived ~ Class + Age * Sex, #' data = df, weights = df$n, #' family = binomial #' ) |> #' model_identify_variables() #' #' lm( #' Sepal.Length ~ poly(Sepal.Width, 2) + Species, #' data = iris, #' 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/helpers.R0000644000176200001440000000347214662130321015023 0ustar liggesusers#' Escapes any characters that would have special #' meaning in a regular expression #' #' This functions has been adapted from `Hmisc::escapeRegex()` #' @param string (`string`)\cr #' A character vector. #' @export #' @family other_helpers .escape_regex <- function(string) { gsub( "([.|()\\^{}+$*?]|\\[|\\])", "\\\\\\1", string ) } #' Remove backticks around variable names #' #' @param x (`string`)\cr #' A character vector to be cleaned. #' @param variable_names (`string`)\cr #' Optional vector 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 } # copied from broom .exponentiate <- function(data, col = "estimate") { data <- data |> dplyr::mutate( dplyr::across(dplyr::all_of(col), exp) ) if ("conf.low" %in% colnames(data)) { data <- data |> dplyr::mutate( dplyr::across(dplyr::any_of(c("conf.low", "conf.high")), exp) ) } data } broom.helpers/R/tidy_remove_intercept.R0000644000176200001440000000226014662130321017756 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @export #' @family tidy_helpers #' @examples #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived)) #' glm(Survived ~ Class + Age + Sex, data = df, weights = df$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_coefficients_type.R0000644000176200001440000001050614662130321020720 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param exponentiate (`logical`)\cr #' Whether or not to exponentiate the coefficient estimates. It should be #' consistent with the original call to [broom::tidy()]. #' @param model (a model object, e.g. `glm`)\cr #' 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") #' #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' ex2 <- glm( #' Survived ~ Class + Age * Sex, #' data = df, #' weights = df$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_list_higher_order_variables.R0000644000176200001440000000310314662130321022254 0ustar liggesusers#' List higher order variables of a model #' #' @param model (a model object, e.g. `glm`)\cr #' 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_pairwise_contrasts.R0000644000176200001440000001047514762100776021162 0ustar liggesusers#' Add pairwise contrasts for categorical variables #' #' 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. #' #' For multi-components models, such as zero-inflated Poisson or beta #' regression, support of pairwise contrasts is still experimental. #' #' @param x (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param variables include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables for those pairwise contrasts should be added. #' Default is [all_categorical()]. #' @param keep_model_terms (`logical`)\cr #' Keep terms from the model? #' @param pairwise_reverse (`logical`)\cr #' Determines whether to use `"pairwise"` (if `TRUE`) #' or `"revpairwise"` (if `FALSE`), see [emmeans::contrast()]. #' @param contrasts_adjust (`string`)\cr #' Optional adjustment method when computing contrasts, #' see [emmeans::contrast()] (if `NULL`, use `emmeans` default). #' @param conf.level (`numeric`)\cr #' Confidence level, by default use the value indicated #' previously in [tidy_and_attach()]. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf .assert_package("emmeans", boolean = TRUE) #' \donttest{ #' 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 cards::process_selectors( data = scope_tidy(x), variables = {{ 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_weights.R0000644000176200001440000000435314662130321017051 0ustar liggesusers#' Get sampling weights used by a model #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model (a model object, e.g. `glm`)\cr #' A model object. #' @note #' For class `svrepglm` objects (GLM on a survey object with replicate weights), #' it will return the original sampling weights of the data, not the replicate #' weights. #' @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.svrepglm <- function(model) { model$survey.design$pweights } #' @export #' @rdname model_get_weights model_get_weights.model_fit <- function(model) { model_get_weights(model$fit) } broom.helpers/R/model_get_response.R0000644000176200001440000000370614662130321017236 0ustar liggesusers#' Get model response #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model (a model object, e.g. `glm`)\cr #' 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_get_model_frame.R0000644000176200001440000000452114733566032017661 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, e.g. `glm`)\cr #' 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) { if (!is.null(attr(model, "model_frame"))) return(attr(model, "model_frame")) 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) { # variable labels not available, but accessible through model.frame.default() # however, model.frame.default() does not return (id) and the correct number # of lines res <- tryCatch( stats::model.frame(model), error = function(e) { NULL } ) if (!is.null(res)) { res <- res |> labelled::copy_labels_from( stats::model.frame.default(model), .strict = FALSE ) } res } #' @export #' @rdname model_get_model_frame model_get_model_frame.svycoxph <- model_get_model_frame.default #' @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_get_terms(model), data = get(model$call$data, model$call_env) ) } broom.helpers/R/tidy_plus_plus.R0000644000176200001440000002407014762101325016440 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_group_by()] #' * [tidy_add_coefficients_type()] #' * [tidy_detach_model()] #' #' @param model (a model object, e.g. `glm`)\cr #' A model to be attached/tidied. #' @param tidy_fun (`function`)\cr #' Option to specify a custom tidier function. #' @param conf.int (`logical`)\cr #' Should confidence intervals be computed? (see [broom::tidy()]) #' @param conf.level (`numeric`)\cr #' Level of confidence for confidence intervals (default: 95%). #' @param exponentiate (`logical`)\cr #' 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 model_matrix_attr (`logical`)\cr #' Whether model frame and model matrix should be added as attributes of `model` #' (respectively named `"model_frame"` and `"model_matrix"`) and passed through. #' @param variable_labels ([`formula-list-selector`][gtsummary::syntax])\cr #' A named list or a named vector of custom variable labels. #' @param instrumental_suffix (`string`)\cr #' Suffix added to variable labels for instrumental variables (`fixest` models). #' `NULL` to add nothing. #' @param term_labels (`list` or `vector`)\cr #' A named list or a named vector of custom term labels. #' @param interaction_sep (`string`)\cr #' Separator for interaction terms. #' @param categorical_terms_pattern ([`glue pattern`][glue::glue()])\cr #' A [glue pattern][glue::glue()] for labels of categorical terms with treatment #' or sum contrasts (see [model_list_terms_levels()]). #' @param disambiguate_terms (`logical`)\cr #' Should terms be disambiguated with #' [tidy_disambiguate_terms()]? (default `TRUE`) #' @param disambiguate_sep (`string`)\cr #' Separator for [tidy_disambiguate_terms()]. #' @param add_reference_rows (`logical`)\cr #' Should reference rows be added? #' @param no_reference_row ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables for those no reference row should be added, #' when `add_reference_rows = TRUE`. #' @param add_pairwise_contrasts (`logical`)\cr #' Apply [tidy_add_pairwise_contrasts()]? #' @param pairwise_variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables to add pairwise contrasts. #' @param keep_model_terms (`logical`)\cr #' Keep original model terms for variables where #' pairwise contrasts are added? (default is `FALSE`) #' @param pairwise_reverse (`logical`)\cr #' Determines whether to use `"pairwise"` (if `TRUE`) #' or `"revpairwise"` (if `FALSE`), see [emmeans::contrast()]. #' @param contrasts_adjust (`string`)\cr #' Optional adjustment method when computing contrasts, #' see [emmeans::contrast()] (if `NULL`, use `emmeans` default). #' @param emmeans_args (`list`)\cr #' List of additional parameter to pass to #' [emmeans::emmeans()] when computing pairwise contrasts. #' @param add_estimate_to_reference_rows (`logical`)\cr #' Should an estimate value be added to reference rows? #' @param add_header_rows (`logical`)\cr #' Should header rows be added? #' @param show_single_row ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables that should be displayed on a single row, #' when `add_header_rows` is `TRUE`. #' @param add_n (`logical`)\cr #' Should the number of observations be added? #' @param intercept (`logical`)\cr #' Should the intercept(s) be included? #' @inheritParams tidy_select_variables #' @inheritParams tidy_group_by #' @param keep_model (`logical`)\cr #' Should the model be kept as an attribute of the final result? #' @param tidy_post_fun (`function`)\cr #' Custom function applied to the results at the end of #' `tidy_plus_plus()` (see note) #' @param quiet (`logical`)\cr #' Whether `broom.helpers` should not return a message when requested output #' cannot be generated. Default is `FALSE`. #' @param strict (`logical`)\cr #' Whether `broom.helpers` should return an error #' when requested output cannot be generated. Default is `FALSE`. #' @param ... other arguments passed to `tidy_fun()` #' @note #' `tidy_post_fun` is applied to the result at the end of `tidy_plus_plus()` #' and receive only one argument (the result of `tidy_plus_plus()`). However, #' if needed, the model is still attached to the tibble as an attribute, even #' if `keep_model = FALSE`. Therefore, it is possible to use [tidy_get_model()] #' within `tidy_fun` if, for any reason, you need to access the source model. #' @family tidy_helpers #' @examples #' \donttest{ #' 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 #' } #' @examplesIf require("gtsummary") && require("emmeans") #' \donttest{ #' 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, model_matrix_attr = TRUE, variable_labels = NULL, instrumental_suffix = " (instrumental)", 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(), group_by = auto_group_by(), group_labels = NULL, keep_model = FALSE, tidy_post_fun = NULL, quiet = FALSE, strict = FALSE, ...) { res <- model |> tidy_and_attach( tidy_fun = tidy_fun, conf.int = conf.int, conf.level = conf.level, exponentiate = exponentiate, model_matrix_attr = model_matrix_attr, ... ) 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, instrumental_suffix = instrumental_suffix ) |> 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_group_by( group_by = {{ group_by }}, group_labels = group_labels ) |> tidy_add_coefficients_type() if (!is.null(tidy_post_fun)) res <- res |> tidy_post_fun() if (!keep_model) { res <- res |> tidy_detach_model() } res } broom.helpers/R/tidy_add_reference_rows.R0000644000176200001440000001740514762101026020234 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param no_reference_row ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables for those no reference row should be added. #' See also [all_categorical()] and [all_dichotomous()]. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf .assert_package("gtsummary", boolean = TRUE) #' \donttest{ #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' res <- #' glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$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 cards::process_selectors( data = scope_tidy(x), no_reference_row = {{ 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 has_instrumental <- "instrumental" %in% names(x) if (!has_instrumental) { x$instrumental <- NA } # 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)) { 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), instrumental = dplyr::first(.data$instrumental), 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")) } if (!has_instrumental) { x <- x |> dplyr::select(-dplyr::all_of("instrumental")) } x |> dplyr::arrange(.data$rank) |> dplyr::select(-dplyr::all_of("rank")) |> tidy_attach_model(model = model, .attributes = .attributes) } broom.helpers/R/broom.helpers-package.R0000644000176200001440000000523414760117573017544 0ustar liggesusers## usethis namespace: start #' @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(".")) # 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( "group_by", "y.level", "component", "term", "original_term", "variable", "instrumental", "var_label", "var_class", "var_type", "var_nlevels", "header_row", "contrasts", "contrasts_type", "reference_row", "label", "n_obs", "n_ind", "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_ind", "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 (`numeric`)\cr #' A numeric vector. #' @param length.out (`integer`)\cr #' Desired length of the sequence (a positive integer). #' @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_compute_terms_contributions.R0000644000176200001440000001113314760117573022417 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, e.g. `glm`)\cr #' A model object. #' @export #' @family model_helpers #' @examples #' \donttest{ #' 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) && length(contr) > 0) { 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 |> 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/tidy_group_by.R0000644000176200001440000000650614762071336016254 0ustar liggesusers#' Group results by selected columns #' #' Indicates that results should be grouped. By default #' (`group_by = auto_group_by()`), results will be grouped according to the #' `y.level` column (for multinomial models) or the `component` column #' (multi-components models) if any. #' @param x (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param group_by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' One or several variables to group by. Default is `auto_group_by()`. #' Use `NULL` to force ungrouping. #' @param group_labels (`string`)\cr #' An optional named vector of custom term labels. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @return #' The `x` tibble with, if relevant, an additional `group_by` column. #' @export #' @examplesIf require("nnet") #' mod <- multinom(Species ~ Petal.Width + Petal.Length, data = iris) #' mod |> tidy_and_attach() |> tidy_group_by() #' #' mod |> #' tidy_and_attach() |> #' tidy_group_by(group_labels = c(versicolor = "harlequin blueflag")) #' #' mod |> tidy_and_attach() |> tidy_group_by(group_by = NULL) #' #' mod |> #' tidy_and_attach() |> #' tidy_identify_variables() |> #' tidy_group_by(group_by = variable) #' @family tidy_helpers tidy_group_by <- function( x, group_by = auto_group_by(), group_labels = NULL, 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) # obtain character vector of selected variables group_vars <- x |> dplyr::select({{ group_by }}) |> colnames() # compute groups if (length(group_vars) > 0) { x <- x |> tidyr::unite(col = "group_by", dplyr::all_of(group_vars), remove = FALSE) groups <- unique(x$group_by) x$group_by <- factor(x$group_by, levels = groups) x <- x |> dplyr::arrange(group_by) # group labels if (!is.null(group_labels)) { if (is.null(names(group_labels)) || any(names(group_labels) == "")) cli::cli_abort("All elements of {.arg group_labels} should be named.") keep <- names(group_labels) %in% levels(x$group_by) drop <- group_labels[!keep] if (length(drop) > 0) { cli::cli_alert_warning(c( "Problem in {.arg group_labels}:\n", "value{?s} {.strong {drop}} not found in the data and ignored." )) } group_labels <- group_labels[keep] l <- levels(x$group_by) names(l) <- l l[names(group_labels)] <- group_labels levels(x$group_by) <- l } } if (length(group_vars) == 0 && "group_by" %in% names(x)) x <- x |> dplyr::select(-.data$group_by) # sometimes, group_by not relevant after tidy_select_variable if ("group_by" %in% names(x) && all(x$group_by == "")) x <- x |> dplyr::select(-.data$group_by) x |> tidy_attach_model(model = model, .attributes = .attributes) } #' @rdname tidy_group_by #' @export auto_group_by <- function() { vars <- tidyselect::peek_vars() if ("group_by" %in% vars) # if already grouped, we keep it return("group_by") if ("y.level" %in% vars) return("y.level") if ("component" %in% vars) return("component") NULL } broom.helpers/R/tidy_add_header_rows.R0000644000176200001440000002444714762100744017540 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param show_single_row ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Names of dichotomous variables that should be displayed on a single row. #' See also [all_dichotomous()]. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examplesIf .assert_package("gtsummary", boolean = TRUE) #' \donttest{ #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' #' res <- #' glm( #' Survived ~ Class + Age + Sex, #' data = df, weights = df$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 cards::process_selectors( data = scope_tidy(x), show_single_row = {{ 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)) { 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)) { 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/tidy_identify_variables.R0000644000176200001440000001162014733566032020262 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. #' #' For `fixest` models, a new column `instrumental` is added to indicate #' instrumental variables. #' @param x (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @seealso [model_identify_variables()] #' @family tidy_helpers #' @examples #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' glm( #' Survived ~ Class + Age * Sex, #' data = df, #' weights = df$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 fixest models to handle instrumental variables if (inherits(model, "fixest")) { x <- x |> dplyr::mutate( original_term = .data$term, instrumental = .data$term |> stringr::str_starts("fit_"), term = dplyr::if_else( .data$term |> stringr::str_starts("fit_"), .data$term |> stringr::str_sub(5), .data$term ) ) } # 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", "random"), .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_list_contrasts.R0000644000176200001440000001043114662130321017605 0ustar liggesusers#' List contrasts used by a model #' #' @param model (a model object, e.g. `glm`)\cr #' 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/marginal_tidiers.R0000644000176200001440000012307314762100504016677 0ustar liggesusers#' Average Marginal Effects with `margins::margins()` #' #' `r lifecycle::badge("superseded")` #' #' The `margins` package is no longer under active development and may be #' removed from CRAN sooner or later. It is advised to use the `marginaleffects` #' package instead, offering more functionalities. You could have a look at the #' [article](https://larmarange.github.io/broom.helpers/articles/marginal_tidiers.html) #' dedicated to marginal estimates with `broom.helpers`. `tidy_avg_slopes()` #' could be used as an alternative. #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to `margins::margins()`. #' @family marginal_tieders #' @seealso `margins::margins()` #' @export #' @examplesIf .assert_package("margins", boolean = TRUE) #' \donttest{ #' 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()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to `effects::allEffects()`. #' @family marginal_tieders #' @seealso `effects::allEffects()` #' @export #' @examplesIf .assert_package("effects", boolean = TRUE) #' \donttest{ #' 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()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to `ggeffects::ggpredict()`. #' @family marginal_tieders #' @seealso `ggeffects::ggpredict()` #' @export #' @examplesIf .assert_package("ggeffects", boolean = TRUE) #' \donttest{ #' 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_level = 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()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to #' `marginaleffects::avg_slopes()`. #' @family marginal_tieders #' @seealso `marginaleffects::avg_slopes()` #' @export #' @examplesIf .assert_package("marginaleffects", boolean = TRUE) #' \donttest{ #' # 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 == "balanced") ~ "marginal_effects_at_marginalmeans", TRUE ~ "marginal_effects" ) attr(res, "skip_add_reference_rows") <- TRUE res |> dplyr::as_tibble() } #' Marginal Contrasts with `marginaleffects::avg_comparisons()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to #' `marginaleffects::avg_comparisons()`. #' @family marginal_tieders #' @seealso `marginaleffects::avg_comparisons()` #' @export #' @examplesIf .assert_package("marginaleffects", boolean = TRUE) #' \donttest{ #' # 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 == "balanced") ~ "marginal_contrasts_at_marginalmeans", TRUE ~ "marginal_contrasts" ) attr(res, "skip_add_reference_rows") <- TRUE res |> dplyr::as_tibble() } #' Marginal Means with deprecated `marginaleffects::marginal_means()` #' #' `r lifecycle::badge("deprecated")` #' This function is deprecated. `marginal_means()` is not anymore exported #' by `marginaleffects`. Use instead `tidy_marginal_predictions()` with #' the option `newdata = "balanced"`. #' @param x (a model object, e.g. `glm`)\cr #' A model to be tidied. #' @param conf.int (`logical`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters. #' @export tidy_marginal_means <- function(x, conf.int = TRUE, conf.level = 0.95, ...) { lifecycle::deprecate_stop( when = "1.19.0", what = "tidy_marginal_means()", with = "tidy_marginal_predictions()", details = "Specify `newdata = \"balanced\"`." ) } #' Marginal Predictions with `marginaleffects::avg_predictions()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param variables_list (`list` or `string`)\cr #' 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`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to #' `marginaleffects::avg_predictions()`. #' @family marginal_tieders #' @seealso `marginaleffects::avg_predictions()` #' @export #' @examplesIf .assert_package("marginaleffects", boolean = TRUE) #' # example code #' #' \donttest{ #' # 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 == "balanced") ~ "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::arrange(dplyr::pick(dplyr::any_of(c(names(variables)))), "group") |> 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 object, e.g. `glm`)\cr #' A model. #' @param interactions (`logical`)\cr #' Should combinations of variables corresponding to #' interactions be returned? #' @param categorical ([`predictor values`][marginaleffects::predictions()])\cr #' Default values for categorical variables. #' @param continuous ([`predictor values`][marginaleffects::predictions()])\cr #' Default values 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()` #' #' 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 object, e.g. `glm`)\cr #' A model to be tidied. #' @param variables_list (`list` or `string`)\cr #' 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`)\cr #' Whether or not to include a confidence interval in the tidied output. #' @param conf.level (`numeric`)\cr #' The confidence level to use for the confidence interval (between `0` ans `1`). #' @param ... Additional parameters passed to #' `marginaleffects::avg_comparisons()`. #' @family marginal_tieders #' @seealso `marginaleffects::avg_comparisons()`, `tidy_avg_comparisons()` #' @export #' @examplesIf .assert_package("marginaleffects", boolean = TRUE) #' \donttest{ #' # 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 == "balanced") ~ "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 args$grid_type <- "counterfactual" dots$newdata <- do.call(marginaleffects::datagrid, 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 object, e.g. `glm`)\cr #' A model. #' @param interactions (`logical`)\cr #' Should combinations of variables corresponding to interactions be returned? #' @param cross (`logical`)\cr #' 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 ([`predictor values`][marginaleffects::comparisons()])\cr #' Default `variable` value for categorical variables. #' @param var_continuous ([`predictor values`][marginaleffects::comparisons()])\cr #' Default `variable` value for continuous variables. #' @param by_categorical ([`predictor values`][marginaleffects::comparisons()])\cr #' Default `by` value for categorical variables. #' @param by_continuous ([`predictor values`][marginaleffects::comparisons()])\cr #' 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/model_get_xlevels.R0000644000176200001440000000372414662130321017062 0ustar liggesusers#' Get xlevels used in the model #' #' @param model (a model object, e.g. `glm`)\cr #' 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.R0000644000176200001440000002040514762100610017536 0ustar liggesusers#' List all the variables used in a model #' #' Including variables used only in an interaction. #' #' @param model (a model object, e.g. `glm`)\cr #' A model object. #' @param labels (`list` or `string`)\cr #' An optional named list or named vector of #' custom variable labels. #' @param only_variable (`logical`)\cr #' If `TRUE`, will return only "variable" column. #' @param add_var_type (`logical`)\cr #' If `TRUE`, add `var_nlevels` and `var_type` columns. #' @param instrumental_suffix (`string`)\cr #' Suffix added to variable labels for instrumental variables (`fixest` models). #' `NULL` to add nothing. #' @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 .assert_package("gtsummary", boolean = TRUE) #' \donttest{ #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) #' glm( #' Survived ~ Class + Age:Sex, #' data = df, weights = df$n, #' family = binomial #' ) |> #' model_list_variables() #' #' lm( #' Sepal.Length ~ poly(Sepal.Width, 2) + Species, #' data = iris, #' 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, instrumental_suffix = " (instrumental)") { UseMethod("model_list_variables") } #' @rdname model_list_variables #' @export model_list_variables.default <- function(model, labels = NULL, only_variable = FALSE, add_var_type = FALSE, instrumental_suffix = " (instrumental)") { 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) } # specific case for instrumental variables if (inherits(model, "fixest") && !is.null(instrumental_suffix)) { iv <- all.vars(model$iv_endo_fml) res <- res |> dplyr::mutate( var_label = dplyr::if_else( .data$variable %in% iv, paste0(.data$var_label, instrumental_suffix), .data$var_label ) ) } 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, instrumental_suffix = " (instrumental)") { 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, instrumental_suffix = " (instrumental)") { 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") } "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/model_get_model_matrix.R0000644000176200001440000001075014760117573020076 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, e.g. `glm`)\cr #' 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, ...) { if (!is.null(attr(model, "model_matrix"))) return(attr(model, "model_matrix")) 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 #' @details #' For `fixest` models, will recreate a model matrix with both main variables #' and instrumental variables. For more options, see #' [fixest::model.matrix.fixest]. model_get_model_matrix.fixest <- function(model, ...) { stats::model.matrix.default( model_get_terms(model), 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() ) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.cch <- function(model, ...) { stats::model.matrix.default( model$call$formula |> stats::formula(), data = model |> model_get_model_frame() ) } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.vglm <- function(model, ...) { stats::model.matrix(model, ..., type = "lm") } #' @export #' @rdname model_get_model_matrix model_get_model_matrix.vgam <- function(model, ...) { stats::model.matrix(model, ..., type = "lm") } broom.helpers/R/tidy_add_term_labels.R0000644000176200001440000002152614760117574017531 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param labels (`list` or `string`)\cr #' An optional named list or named vector of custom term labels. #' @param interaction_sep (`string`)\cr #' Separator for interaction terms. #' @param categorical_terms_pattern ([`glue pattern`][glue::glue()])\cr #' A [glue pattern][glue::glue()] for labels of categorical terms with treatment #' or sum contrasts (see examples and [model_list_terms_levels()]). #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @inheritParams tidy_plus_plus #' @export #' @family tidy_helpers #' @examples #' \donttest{ #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) |> #' labelled::set_variable_labels( #' Class = "Passenger's class", #' Sex = "Sex" #' ) #' #' mod <- #' glm(Survived ~ Class * Age * Sex, data = df, weights = df$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) } 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)) { xx <- x |> dplyr::distinct(.data$term, .keep_all = TRUE) } 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/select_utilities.R0000644000176200001440000004036014760322364016741 0ustar liggesusers#' Convert formula selector to a named list #' #' `r lifecycle::badge("deprecated")`\cr #' This function will soon be removed from `broom.helpers`. Please consider #' [`cards::process_formula_selectors()`] as an alternative. #' #' 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 #' @keywords internal #' @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) { lifecycle::deprecate_stop( "1.17.0", ".formula_list_to_named_list()", "cards::process_formula_selectors()" ) # 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) rd <- function(x) { x <- rev(x) x <- !duplicated(x) rev(x) } tokeep <- names(named_list) |> rd() 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) } 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) } } ) 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 #' #' `r lifecycle::badge("deprecated")`\cr #' This function will soon be removed from `broom.helpers`. Please consider #' [`cards::process_selectors()`] as an alternative. #' #' 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 #' @keywords internal #' @export .select_to_varnames <- function(select, data = NULL, var_info = NULL, arg_name = NULL, select_single = FALSE) { lifecycle::deprecate_stop( "1.17.0", ".select_to_varnames()", "cards::process_selectors()" ) 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) } # if var_info is provided, scope it if (!is.null(var_info)) data <- scope_tidy(var_info, data) # 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 #' #' `r lifecycle::badge("deprecated")` #' #' @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 #' @keywords internal #' @export .generic_selector <- function(variable_column, select_column, select_expr, fun_name) { lifecycle::deprecate_stop("1.17.0", ".generic_selector()") # 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 filter_complete_cases <- function(x) { dplyr::filter(x, stats::complete.cases(x)) } env_variable_type$df_var_info |> dplyr::select(all_of(c(variable_column, select_column))) |> filter_complete_cases() |> dplyr::filter({{ select_expr }}) |> dplyr::pull(dplyr::all_of(variable_column)) |> unique() } #' @rdname dot-generic_selector #' @keywords internal #' @export .is_selector_scoped <- function(variable_column, select_column) { lifecycle::deprecate_stop("1.17.0", ".is_selector_scoped()") 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 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_select_variables.R0000644000176200001440000000603214662130321017714 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables to include. Default is `everything()`. #' See also [all_continuous()], [all_categorical()], [all_dichotomous()] #' and [all_interaction()]. #' @param model (a model object, e.g. `glm`)\cr #' The corresponding model, if not attached to `x`. #' @return #' The `x` tibble limited to the included variables (and eventually the intercept), #' sorted according to the `include` parameter. #' @export #' @family tidy_helpers #' @examples #' df <- Titanic |> #' dplyr::as_tibble() |> #' dplyr::mutate(Survived = factor(Survived)) #' res <- #' glm(Survived ~ Class + Age * Sex, data = df, weights = df$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 cards::process_selectors( data = scope_tidy(x), include = {{ 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/scope_tidy.R0000644000176200001440000000655314760074335015541 0ustar liggesusers#' Scoping a tidy tibble allowing to tidy select #' #' This function uses the information from a model tidy tibble to generate #' a data frame exposing the different variables of the model, #' data frame that could be used for tidy selection. In addition, columns #' `"var_type"`, `"var_class"` and `"contrasts_type"` are scoped and their #' values are added as attributes to the data frame. #' For example, if `var_type='continuous'` for variable `"age"`, then the #' attribute `attr(.$age, 'gtsummary.var_type') <- 'continuous'` is set. #' That attribute is then used in a selector like `all_continuous()`. #' Note: attributes are prefixed with `"gtsummary."` to be compatible with #' selectors provided by `{gtsummary}`. #' #' @param x (`data.frame`)\cr #' A tidy tibble, with a `"variable"` column, as returned by #' [`tidy_identify_variables()`]. #' @param data (`data.frame`)\cr #' An optional data frame the attributes will be added to. #' @return A data frame. #' @export #' @examples #' mod <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) #' tt <- mod |> tidy_and_attach() |> tidy_add_contrasts() #' #' scope_tidy(tt) |> str() #' scope_tidy(tt, data = model_get_model_frame(mod)) |> str() #' #' scope_tidy(tt) |> dplyr::select(dplyr::starts_with("Se")) |> names() #' scope_tidy(tt) |> dplyr::select(where(is.factor)) |> names() #' scope_tidy(tt) |> dplyr::select(all_continuous()) |> names() #' scope_tidy(tt) |> dplyr::select(all_contrasts()) |> names() #' scope_tidy(tt) |> dplyr::select(all_interaction()) |> names() #' scope_tidy(tt) |> dplyr::select(all_intercepts()) |> names() scope_tidy <- function(x, data = NULL) { if (!"variable" %in% names(x)) { cli::cli_abort( "The {.code .$x} data frame does not have the required {.val variable} column." ) } # if data not passed, use x to construct one if (rlang::is_empty(data)) { data <- dplyr::tibble( !!!rlang::rep_named( unique(as.character(x$variable)), logical(0L) ) ) # if var_class available in x, convert columns if ("var_class" %in% names(x)) { df_class <- x[c("variable", "var_class")] |> unique() |> tidyr::drop_na() for (i in seq_len(nrow(df_class))) { f <- switch( df_class$var_class[i], "character" = as.character, "factor" = as.factor, "ordered" = as.ordered, "integer" = as.integer, "numeric" = as.numeric, "complex" = as.complex, "Date" = as.Date, "POSIXlt" = as.POSIXlt, "POSIXct" = as.POSIXct, "difftime" = as.difftime, as.logical ) data[[df_class$variable[i]]] <- f(NA) } } } # only keeping rows that have corresponding column names in data x <- x |> dplyr::filter(.data$variable %in% names(data)) # if x passed, add columns as attr to data base_attr_cols <- c("var_type", "var_class", "contrasts_type") attr_cols <- x |> dplyr::select(any_of(base_attr_cols)) |> names() # add attributes for (v in attr_cols) { df_attr <- x[c("variable", v)] |> unique() |> tidyr::drop_na() for (i in seq_len(nrow(df_attr))) { attr(data[[df_attr$variable[i]]], paste0("gtsummary.", v)) <- df_attr[[v]][i] } } # return data frame with attributes data } broom.helpers/R/reexport.R0000644000176200001440000000133014662130321015220 0ustar liggesusers#' @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 #' @importFrom dplyr where #' @export dplyr::where broom.helpers/R/model_get_response_variable.R0000644000176200001440000000203614760117573021113 0ustar liggesusers#' Get the name of the response variable #' #' @param model (a model object, e.g. `glm`)\cr #' 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")) { names(model_frame)[attr(model_terms, "response")] } else { NULL } } broom.helpers/R/model_get_pairwise_contrasts.R0000644000176200001440000000762114762100563021331 0ustar liggesusers#' Get pairwise comparison of the levels of a categorical variable #' #' It is computed with [emmeans::emmeans()]. #' #' @param model (a model object, e.g. `glm`)\cr #' A model object. #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Variables to add pairwise contrasts. #' @param pairwise_reverse (`logical`)\cr #' 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 (`numeric`)\cr #' Level of confidence for confidence intervals (default: 95%). #' @param emmeans_args (`logical`)\cr #' List of additional parameter to pass to #' [emmeans::emmeans()] when computing pairwise contrasts. #' @details #' 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. #' @family model_helpers #' @export #' @examplesIf .assert_package("emmeans", boolean = TRUE) #' \donttest{ #' 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/model_get_nlevels.R0000644000176200001440000000147114662130321017045 0ustar liggesusers#' Get the number of levels for each factor used in `xlevels` #' #' @param model (a model object, e.g. `glm`)\cr #' 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/model_get_offset.R0000644000176200001440000000125314662130321016661 0ustar liggesusers#' Get model offset #' #' This function does not cover `lavaan` models (`NULL` is returned). #' #' @param model (a model object, e.g. `glm`)\cr #' 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_model.R0000644000176200001440000000131314662130321016470 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, e.g. `glm`)\cr #' 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_assign.R0000644000176200001440000000303414662130321016656 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, e.g. `glm`)\cr #' 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/assert_package.R0000644000176200001440000001335614760117573016354 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 (`string`)\cr #' Name of the required package. #' @param fn (`string`)\cr #' Name of the calling function from the user perspective. Used to write #' informative error messages. #' @param pkg_search (`string`)\cr #' Name of the package the function will search for a minimum #' required version from. #' @param boolean (`logical`)\cr #' 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 (`logical`)\cr #' If several versions of a package are installed, #' should only the first one be returned? #' @param lib.loc (`string`)\cr #' 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 #' @examples #' \donttest{ #' .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_add_variable_labels.R0000644000176200001440000001040214733566032020333 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 (`data.frame`)\cr #' A tidy tibble as produced by `tidy_*()` functions. #' @param labels ([`formula-list-selector`][gtsummary::syntax])\cr #' An optional named list or a named vector of custom variable labels. #' @param instrumental_suffix (`string`)\cr #' Suffix added to variable labels for instrumental variables (`fixest` models). #' `NULL` to add nothing. #' @param model (a model object, e.g. `glm`)\cr #' 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" #' ) #' #' glm(Survived ~ Class * Age * Sex, data = df, weights = df$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 = " * ", instrumental_suffix = " (instrumental)", 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 ("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) } if (is.atomic(labels)) labels <- as.list(labels) # vectors allowed cards::process_formula_selectors( data = scope_tidy(x), labels = 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, instrumental_suffix = instrumental_suffix ) additional_labels <- variable_list$var_label names(additional_labels) <- variable_list$variable var_labels <- var_labels |> .update_vector(additional_labels) 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/vignettes/0000755000176200001440000000000014762273036015053 5ustar liggesusersbroom.helpers/vignettes/broom-helpers.Rmd0000644000176200001440000004105714760123275020301 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()`, `tidy_zeroinfl()` or `tidy_identify_variables()`", "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. For instrumental variables in \"fixest\" models, the \"fit_\" prefix is removed, and the original terms is stored in this column.", "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_ind", "`tidy_add_n()`", "Number of individuals (for Cox models)", "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)", "instrumental", "`tidy_identify_variables()`", "For \"fixest\" models, indicate if a variable was instrumental.", "group_by", "`tidy_group_by()`", "Grouping variable (particularly for multinomial or multi-components models).", ) |> dplyr::arrange(Column, .locale = "en") |> 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", "N_ind", "`tidy_add_n()`", "Total number of individuals (for Cox models)", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) |> dplyr::arrange(Attribute, .locale = "en") |> 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/data/0000755000176200001440000000000014733566032013753 5ustar liggesusersbroom.helpers/data/supported_models.rda0000644000176200001440000000224114760322606020027 0ustar liggesusersBZh91AY&SYH®¢³ÎÿÂÿ7ÿÁLgÌW?¯Ÿ@ÿÿÿþ@ и{±Çuw[´‡F JE3S4Fšh2A 4M2 ’˜M4)±OP4hhhz "&#@Œ”õ=Mdh € ¢ƒL†š40ÐÁdÑ  4HLT~)é¦TiF€Ðõƒ ÈõdÑ zŠÙ ŠH6é©ç…XŽûI2ÝÙX E<]–¥ùž¿N‚Y²¿»=,c[úßÙÍ“ü¸ÄX ê´ SMåMA‹BHI!0m Å¶ÛLLi!°I± ¶Û`Æ'3ØI ÓØp„=,ûhÐJÈÎå;ƒÜ’”¤Oƒ„U9©ðp“1EE¼Gk]H§BŠò,ÞFL!Îõ¥ Ê%crë$`ð;g8~ÒÎ}#¿ßôɘ7D&õ¸ƒl›kT>iÃ]fe¸âS)šjèÿ6|ˆ™ÃKõð™ó¹…¤t ò-rƒlÆ'¤¦5¯1Bªs;Ï®º© ò‹ q˜)˜˜­®ÇiÂßj pr­û²rïŽu ‚T ]`¿µ^'„Öî_<ÜÂ< -GrÞÁ6âÙ ÚyC‹Jï¡d€Á†CׯiùWžÏŸPÚAŸ3€ØÒÆvu„³Ü‘0`„›>&¯;Wƨ-°Û©×ØÑNbÑ¡‘¾(T¶B)hÀ“§Ú˜˜»®ot±7Å®^2ДÞ!®$o…K( ó@ÅÚX€º`ÞáÒd¢Yp¬æUe§]š£»Ç©eo>îü”ÄÔ)\Ž2…-]ºË¤¡3¢b@è,ò:±­v4AO²Yb£ *©‘‘É]x¡+¦uŠLÐS½ÂñÁR‡šL…(cš ÖÒÉËÇá@°“ºZÀIhÂXÜC?Óè ’×C‹µf) ‚9ñ rYŠ%fÀ›ð•Ï`_–êí9ņD¾c1tµãC……!›%E£‘xIo ’ƒ ¯SxÙbfJpXƒÅ³šµÊö¸X²LôEš1uøG$c Â8:ºš/EF Á§¶i,žø7ŠÓÓ£8Ú—®’¨*0åQRŠÊUœ?¬Mt°¼qxvd³Åc‰æÞz 9a½m7,ì\Ë=ÙZ KhmÒl¥i*lo…²óghg%²b³éPnå;Ãpbqê¾êÖA­ƒÏ¹: ³ J2YãÈ$)B8 ¨tÇ’Š£&BËá1µ ¡ ÅVIo{’çÝ4‰˜s¦ÃŸ‚ÅjJ¢ÖIÔév*¹WÆ«›aY&ð°<󪙖[¥ àMN—½ë¢Zv©.” Ù€pÈ«Z‹üI¦3P­jf>ÐÕ#6HÛ‚QÅ“tAöÃRø"ð×JèÕ &Çedµ„ÉØXÏ0À¢»Ö´±®Êâ•U$Ã3å]ZRŒÑ"d #Cl\Ñu³- (ȲlŒäTª úH)ÅSŠÊõ7¤*Úì+<Ï÷I0ßñw$S… Šê+0broom.helpers/NAMESPACE0000644000176200001440000001617714760117573014277 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,cch) 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_coefficients_type,vgam) S3method(model_get_coefficients_type,vglm) 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_frame,svycoxph) 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,cch) 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_model_matrix,vgam) S3method(model_get_model_matrix,vglm) 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,cch) S3method(model_get_terms,default) S3method(model_get_terms,fixest) 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,svrepglm) 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(.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(auto_group_by) 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(scope_tidy) 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_group_by) 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_vgam) export(tidy_with_broom_or_parameters) export(tidy_zeroinfl) export(variables_to_contrast) export(variables_to_predict) export(vars) export(where) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_code) importFrom(cli,cli_ul) 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(dplyr,where) importFrom(purrr,"%||%") importFrom(rlang,.data) importFrom(rlang,.env) broom.helpers/NEWS.md0000644000176200001440000004113314762272077014147 0ustar liggesusers# broom.helpers 1.20.0 **New supported models** - improved support for `VGAM::vglm()` and `VGAM::vgam()` models, see the experimental tidier `tidy_vgam()` (#253) **New features** - new `tidy_group_by()` function to indicate how to group results (#288) - new arguments `group_by` and `group_labels` for `tidy_plus_plus()` (#288) **Deprecated functions** - `.select_to_varnames()`, `.formula_list_to_named_list()`, `.generic_selector()` and `.is_selector_scoped()` are now hard deprecated. # broom.helpers 1.19.0 **Deprecated function** - `tidy_marginal_means()` is now hard deprecated (#284) # broom.helpers 1.18.0 **New supported models** - support for `glmtoolbox::glmgee()` models (#274) **New features** - support of instrumental variables for `fixest` models (#279) - new argument `instrumental_suffix` for `model_list_variables()`, `tidy_add_variable_labels()` and `tidy_plus_plus()` **Fixes** - variable labels are now returned by `model_list_variables()` for `svycoxph` models (#275) - compatibility with R version 4.1 minimum (#276) - fix for `tidy_add_n()` with models with a subset argument (#278) # broom.helpers 1.17.0 **Deprecated functions and changes in selectors functions** - selectors such as `all_categorical()` are now compatible with `gtsummary` version ≥ 2.0.0 (#270) - new function `scope_tidy()` to scope a tidy tibble allowing to tidy select (#270) - `.select_to_varnames()`, `.formula_list_to_named_list()`, `.generic_selector()` and `.is_selector_scoped()` are now deprecated and will be removed in a future release: you may consider `cards::process_selectors()` and `cards::process_formula_selectors()` as alternatives (#270) **Fixes** - `model_get_model_frame.coxph()` has been fixed to return a correct model frame a subject identifier is passed to `survival::coxph()` (#268) **Documentation** - Documentation has been improved, showing now clearly the type expected for each argument (#272) # broom.helpers 1.16.0 **New features** - new argument `model_matrix_attr` in `tidy_and_attach()` and `tidy_plus_plus()` to attach model frame and model matrix to the model as attributes for saving some execution time (#254) - `tidy_add_n()` now returns `n_ind` the number of individuals, in addition to the number of observations (#251) - by default, `tidy_parameters()` calls now `parameters::model_parameters()` with `pretty_names = FALSE` for saving execution time (#259) - internal code now uses the native R pipe (`|>`), requiring therefore R >= 4.2 (#262) **Deprecated support** - `biglmm::bigglm()` not supported anymore as `biglmm` has been removed from CRAN **Deprecated functions** - `tidy_marginal_means()` is now deprecated, following deprecation of `marginaleffects::marginal_means()`. Use instead `tidy_marginal_predictions()` with the option `newdata = "balanced"`. - `tidy_margins()` is now indicated as superseded and may be deprecated if `margins` is removed from CRAN. `tidy_avg_slopes()` could be used as an alternative. (#252) **Fixes** - `tidy_multgee()` has been fixed to properly identify the different `y.levels` (#260 @jackmwolf) - `tidy_marginal_predictions()` has been updated to avoid the use of the deprecated function `marginaleffects::datagridcf()` (#256) # broom.helpers 1.15.0 **New supported models** - support for `mmrm::mmrm()` models (#228) - support for `survival::cch()` models (#242) **New features** - new `tidy_post_fun` argument in `tidy_plus_plus()` (#235) **Fix** - fix the order of the levels of categorical variables in the results of `tidy_marginal_predictions()` (#245) - fix in `supported_models` - bug fix when using `tidy_parameters()` for mixed models (#238) - bug fix for `survey::svyglm()` models with replicate weights (#240) # 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/inst/0000755000176200001440000000000014762273020014011 5ustar liggesusersbroom.helpers/inst/doc/0000755000176200001440000000000014762273020014556 5ustar liggesusersbroom.helpers/inst/doc/broom-helpers.html0000644000176200001440000054151214762273017020240 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
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().
exposure tidy_add_n() Exposure time (for Poisson and Cox models)
group_by tidy_group_by() Grouping variable (particularly for multinomial or multi-components models).
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
instrumental tidy_identify_variables() For “fixest†models, indicate if a variable was instrumental.
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().
n_event tidy_add_n() Number of events (for binomial and multinomial logistic models, Poisson and Cox models)
n_ind tidy_add_n() Number of individuals (for Cox models)
n_obs tidy_add_n() Number of observations
original_term tidy_disambiguate_terms(), tidy_multgee(), tidy_zeroinfl() or tidy_identify_variables() 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. For instrumental variables in “fixest†models, the “fit_†prefix is removed, and the original terms is stored in this column.
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_class tidy_identify_variables() Class of the variable.
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().
var_nlevels tidy_identify_variables() Number of original levels for categorical variables
var_type tidy_identify_variables() One of “interceptâ€, “continuousâ€, “dichotomousâ€, “categoricalâ€, “interactionâ€, “ran_pars†or “ran_valsâ€
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.

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
coefficients_label tidy_add_coefficients_type() Coefficients label
coefficients_type tidy_add_coefficients_type() Type of coefficients
component tidy_zeroinfl() component argument passed to tidy_zeroinfl()
conf.level tidy_and_attach() Level of confidence used for confidence intervals
exponentiate tidy_and_attach() Indicates if estimates were exponentiated
Exposure tidy_add_n() Total of exposure time
N_event tidy_add_n() Total number of events
N_ind tidy_add_n() Total number of individuals (for Cox models)
N_obs tidy_add_n() Total number of observations
term_labels tidy_add_term_labels() Custom term labels passed to tidy_add_term_labels()
variable_labels tidy_add_variable_labels() Custom variable labels passed to tidy_add_variable_labels()

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 exponentiate argument for betareg models, use tidy_parameters() instead.
biglm::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
glmtoolbox::glmgee()
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_fun = function(x, ...) {mice::pool(x) |> mice::tidy(...)}
mmrm::mmrm()
multgee::nomLORgee() Use tidy_multgee() as tidy_fun.
multgee::ordLORgee() 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::cch() Experimental support.
survival::clogit()
survival::coxph()
survival::survreg()
tidycmprsk::crr()
VGAM::vgam() Experimental support. It is recommended to use tidy_vgam() as tidy_fun.
VGAM::vglm() Experimental support. It is recommended to use tidy_vgam() 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/broom-helpers.R0000644000176200001440000002721114762273014017465 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()`, `tidy_zeroinfl()` or `tidy_identify_variables()`", "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. For instrumental variables in \"fixest\" models, the \"fit_\" prefix is removed, and the original terms is stored in this column.", "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_ind", "`tidy_add_n()`", "Number of individuals (for Cox models)", "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)", "instrumental", "`tidy_identify_variables()`", "For \"fixest\" models, indicate if a variable was instrumental.", "group_by", "`tidy_group_by()`", "Grouping variable (particularly for multinomial or multi-components models).", ) |> dplyr::arrange(Column, .locale = "en") |> 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", "N_ind", "`tidy_add_n()`", "Total number of individuals (for Cox models)", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) |> dplyr::arrange(Attribute, .locale = "en") |> 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/broom-helpers.Rmd0000644000176200001440000004105714760123275020013 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()`, `tidy_zeroinfl()` or `tidy_identify_variables()`", "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. For instrumental variables in \"fixest\" models, the \"fit_\" prefix is removed, and the original terms is stored in this column.", "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_ind", "`tidy_add_n()`", "Number of individuals (for Cox models)", "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)", "instrumental", "`tidy_identify_variables()`", "For \"fixest\" models, indicate if a variable was instrumental.", "group_by", "`tidy_group_by()`", "Grouping variable (particularly for multinomial or multi-components models).", ) |> dplyr::arrange(Column, .locale = "en") |> 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", "N_ind", "`tidy_add_n()`", "Total number of individuals (for Cox models)", "Exposure", "`tidy_add_n()`", "Total of exposure time", "component", "`tidy_zeroinfl()`", "`component` argument passed to `tidy_zeroinfl()`" ) |> dplyr::arrange(Attribute, .locale = "en") |> 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/WORDLIST0000644000176200001440000000053614531620144015204 0ustar liggesusersAME Arel Bundock CMD Codecov DOI Heiss Helmert Lifecycle Lüdecke MEM Stata Tibbles betareg 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 broom.helpers/README.md0000644000176200001440000003421014760322715014317 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 variable var_label var_class var_type var_nlevels contrasts #> #> 1 Sepal.Width Sepal.Wi… Sepal.Wi… numeric continu… NA #> 2 Speciessetosa Species Species factor categor… 3 contr.tr… #> 3 Speciesversicolor Species Species factor categor… 3 contr.tr… #> 4 Speciesvirginica Species Species factor categor… 3 contr.tr… #> # ℹ 10 more variables: contrasts_type , reference_row , label , #> # n_obs , estimate , std.error , statistic , #> # p.value , conf.low , conf.high 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 variable var_label var_class var_type var_nlevels header_row contrasts #> #> 1 age Age (in … nmatrix.3 continu… NA TRUE #> 2 poly(… age Age (in … nmatrix.3 continu… NA FALSE #> 3 poly(… age Age (in … nmatrix.3 continu… NA FALSE #> 4 poly(… age Age (in … nmatrix.3 continu… NA FALSE #> 5 stage T Stage factor categor… 4 TRUE contr.tr… #> 6 stage1 stage T Stage factor categor… 4 FALSE contr.tr… #> 7 stage2 stage T Stage factor categor… 4 FALSE contr.tr… #> 8 stage3 stage T Stage factor categor… 4 FALSE contr.tr… #> 9 stage4 stage T Stage factor categor… 4 FALSE contr.tr… #> 10 grade Grade factor categor… 3 TRUE contr.sum #> 11 grade1 grade Grade factor categor… 3 FALSE contr.sum #> 12 grade2 grade Grade factor categor… 3 FALSE contr.sum #> 13 grade3 grade Grade factor categor… 3 FALSE contr.sum #> 14 trtDr… trt Chemothe… character dichoto… 2 NA contr.tr… #> 15 grade:t… Grade * … interac… NA TRUE #> 16 grade… grade:t… Grade * … interac… NA FALSE #> 17 grade… grade:t… Grade * … interac… NA FALSE #> # ℹ 11 more variables: contrasts_type , reference_row , label , #> # n_obs , n_event , estimate , std.error , #> # statistic , p.value , conf.low , conf.high 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, 173, 173, 173, NA, 46, 50, 35, 42, NA, 63, 53, 57, … #> $ n_event NA, 54, 54, 54, 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 variable var_label var_class var_type var_nlevels contrasts #> #> 1 Sepal.Width Sepal.Wi… Sepal.Wi… numeric continu… NA #> 2 Speciessetosa Species Species factor categor… 3 contr.tr… #> 3 Speciesversicolor Species Species factor categor… 3 contr.tr… #> 4 Speciesvirginica Species Species factor categor… 3 contr.tr… #> # ℹ 9 more variables: contrasts_type , reference_row , label , #> # estimate , std.error , statistic , p.value , #> # conf.low , conf.high 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 variable var_label var_class var_type var_nlevels header_row contrasts #> #> 1 (Inte… (Interc… (Interce… interce… NA NA #> 2 age Age in y… nmatrix.3 continu… NA TRUE #> 3 poly(… age Age in y… nmatrix.3 continu… NA FALSE #> 4 poly(… age Age in y… nmatrix.3 continu… NA FALSE #> 5 poly(… age Age in y… nmatrix.3 continu… NA FALSE #> 6 stage T Stage factor categor… 4 TRUE contr.tr… #> 7 stage1 stage T Stage factor categor… 4 FALSE contr.tr… #> 8 stage2 stage T Stage factor categor… 4 FALSE contr.tr… #> 9 stage3 stage T Stage factor categor… 4 FALSE contr.tr… #> 10 stage4 stage T Stage factor categor… 4 FALSE contr.tr… #> 11 grade Grade factor categor… 3 TRUE contr.sum #> 12 grade1 grade Grade factor categor… 3 FALSE contr.sum #> 13 grade2 grade Grade factor categor… 3 FALSE contr.sum #> 14 grade3 grade Grade factor categor… 3 FALSE contr.sum #> 15 trt Chemothe… character dichoto… 2 TRUE contr.tr… #> 16 trtDr… trt Chemothe… character dichoto… 2 FALSE contr.tr… #> 17 trtDr… trt Chemothe… character dichoto… 2 FALSE contr.tr… #> 18 grade:t… Grade * … interac… NA TRUE #> 19 grade… grade:t… Grade * … interac… NA FALSE #> 20 grade… grade:t… Grade * … interac… NA FALSE #> # ℹ 9 more variables: contrasts_type , reference_row , label , #> # estimate , std.error , statistic , p.value , #> # conf.low , conf.high 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/build/0000755000176200001440000000000014762273020014133 5ustar liggesusersbroom.helpers/build/vignette.rds0000644000176200001440000000033614762273020016474 0ustar liggesusers‹mQK‚@ >~ 1~¸q/§ ¸pcÐ…ÛQª0@†Iˆ;O. Õ&ít¦ïµ¯™“ÍÓ™iêL705 côºÆLfá¹<Ë<›Òdé…""€õ”J²›{P\*ˆÜ*Q±Û²¼ŽE«aËX‰” æd(ÊtÚò††š¿ðQÆÐ) È¢æùùŸ¯Õ„2ÝÁ½ÊeÏ`ÆÆ ’ú¹ÇD}.ÆÞºT ©†Ÿþý–Ì+¯ßaÖ|ÊCF½¤¼¤‹ÚWÜ»Jä7º_à´-Öbroom.helpers/man/0000755000176200001440000000000014760117574013620 5ustar liggesusersbroom.helpers/man/tidy_add_variable_labels.Rd0000644000176200001440000000526414760117574021066 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 = " * ", instrumental_suffix = " (instrumental)", model = tidy_get_model(x) ) } \arguments{ \item{x}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{labels}{(\code{\link[gtsummary:syntax]{formula-list-selector}})\cr An optional named list or a named vector of custom variable labels.} \item{interaction_sep}{(\code{string})\cr Separator for interaction terms.} \item{instrumental_suffix}{(\code{string})\cr Suffix added to variable labels for instrumental variables (\code{fixest} models). \code{NULL} to add nothing.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} } \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" ) glm(Survived ~ Class * Age * Sex, data = df, weights = df$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_group_by}()}, \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/supported_models.Rd0000644000176200001440000000726414760322727017506 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. \code{broom::tidy()} does not support the \code{exponentiate} argument for betareg models, use \code{tidy_parameters()} instead. \cr \code{biglm::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{glmtoolbox::glmgee()} \tab \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 \verb{tidy_fun = function(x, ...) \{mice::pool(x) |> mice::tidy(...)\}} \cr \code{mmrm::mmrm()} \tab \cr \code{multgee::nomLORgee()} \tab Use \code{tidy_multgee()} as \code{tidy_fun}. \cr \code{multgee::ordLORgee()} \tab 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::cch()} \tab Experimental support. \cr \code{survival::clogit()} \tab \cr \code{survival::coxph()} \tab \cr \code{survival::survreg()} \tab \cr \code{tidycmprsk::crr()} \tab \cr \code{VGAM::vgam()} \tab Experimental support. It is recommended to use \code{tidy_vgam()} as \code{tidy_fun}. \cr \code{VGAM::vglm()} \tab Experimental support. It is recommended to use \code{tidy_vgam()} as \code{tidy_fun}. \cr } } \keyword{datasets} broom.helpers/man/tidy_multgee.Rd0000644000176200001440000000371014762101117016567 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}{(\code{LORgee})\cr A \code{multgee::nomLORgee()} or a \code{multgee::ordLORgee()} model.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{parameters::model_parameters()}.} } \description{ 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. } \details{ To be noted, for \code{multgee::nomLORgee()}, the baseline \code{y} category is the latest modality of \code{y}. } \examples{ \dontshow{if (.assert_package("multgee", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ library(multgee) h <- housing h$status <- factor( h$y, labels = c("street", "community", "independant") ) mod <- multgee::nomLORgee( status ~ factor(time) * sec, data = h, 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_vgam}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/model_get_xlevels.Rd0000644000176200001440000000363014662130321017574 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \code{\link{model_get_response_variable}()}, \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/model_get_model.Rd0000644000176200001440000000312614662130321017212 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, e.g. \code{glm})\cr 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_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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_model_frame.Rd0000644000176200001440000000437114675302210020371 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.svycoxph} \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}{svycoxph}(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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_add_pairwise_contrasts.Rd0000644000176200001440000000765414762101120021665 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{variables}{include (\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables for those pairwise contrasts should be added. Default is \code{\link[=all_categorical]{all_categorical()}}.} \item{keep_model_terms}{(\code{logical})\cr Keep terms from the model?} \item{pairwise_reverse}{(\code{logical})\cr 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}{(\code{string})\cr Optional adjustment method when computing contrasts, see \code{\link[emmeans:contrast]{emmeans::contrast()}} (if \code{NULL}, use \code{emmeans} default).} \item{conf.level}{(\code{numeric})\cr Confidence level, by default use the value indicated previously in \code{\link[=tidy_and_attach]{tidy_and_attach()}}.} \item{emmeans_args}{(\code{list})\cr List of additional parameter to pass to \code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{broom.helpers} should not return a message when requested output cannot be generated. Default is \code{FALSE}.} } \description{ 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. For multi-components models, such as zero-inflated Poisson or beta regression, support of pairwise contrasts is still experimental. } \examples{ \dontshow{if (.assert_package("emmeans", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_group_by}()}, \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-escape_regex.Rd0000644000176200001440000000077714662130321017322 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}{(\code{string})\cr 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/tidy_disambiguate_terms.Rd0000644000176200001440000000425614760117574021017 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{sep}{(\code{string})\cr Separator added between group name and term.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{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{ \donttest{ 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() } } } \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_group_by}()}, \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_coefficients_type.Rd0000644000176200001440000000426214760117574021456 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{exponentiate}{(\code{logical})\cr 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}{(a model object, e.g. \code{glm})\cr 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") df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) ex2 <- glm( Survived ~ Class + Age * Sex, data = df, weights = df$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_group_by}()}, \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_variables.Rd0000644000176200001440000000776014762101120020262 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, instrumental_suffix = " (instrumental)" ) \method{model_list_variables}{default}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE, instrumental_suffix = " (instrumental)" ) \method{model_list_variables}{lavaan}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE, instrumental_suffix = " (instrumental)" ) \method{model_list_variables}{logitr}( model, labels = NULL, only_variable = FALSE, add_var_type = FALSE, instrumental_suffix = " (instrumental)" ) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr A model object.} \item{labels}{(\code{list} or \code{string})\cr An optional named list or named vector of custom variable labels.} \item{only_variable}{(\code{logical})\cr If \code{TRUE}, will return only "variable" column.} \item{add_var_type}{(\code{logical})\cr If \code{TRUE}, add \code{var_nlevels} and \code{var_type} columns.} \item{instrumental_suffix}{(\code{string})\cr Suffix added to variable labels for instrumental variables (\code{fixest} models). \code{NULL} to add nothing.} } \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 (.assert_package("gtsummary", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) glm( Survived ~ Class + Age:Sex, data = df, weights = df$n, family = binomial ) |> model_list_variables() lm( Sepal.Length ~ poly(Sepal.Width, 2) + Species, data = iris, 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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}()} } \concept{model_helpers} broom.helpers/man/tidy_add_n.Rd0000644000176200001440000001353414760117574016213 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{model}{(a model object, e.g. \code{glm})\cr 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{n_ind}. \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 individuals (\code{N_ind}), of events (\code{N_event}) and of exposure time (\code{Exposure}) are stored as attributes of the returned tibble. } \examples{ \donttest{ 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"))) glm( Survived ~ Class + Age + Sex, data = df, weights = df$n, family = binomial, contrasts = list(Age = contr.sum, Class = "contr.helmert") ) |> tidy_and_attach() |> tidy_add_n() glm( Survived ~ Class * (Age:Sex), data = df, weights = df$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() } } \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_group_by}()}, \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-generic_selector.Rd0000644000176200001440000000220314662130321020166 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} } \details{ \code{.is_selector_scoped()} checks if a selector has been properly registered in \code{env_variable_type$df_var_info}. } \keyword{internal} broom.helpers/man/tidy_attach_model.Rd0000644000176200001440000000574514760117574017577 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, model_matrix_attr = TRUE, ... ) tidy_get_model(x) tidy_detach_model(x) } \arguments{ \item{x}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{model}{(a model object, e.g. \code{glm})\cr A model to be attached/tidied.} \item{.attributes}{(\code{list})\cr Named list of additional attributes to be attached to \code{x}.} \item{tidy_fun}{(\code{function})\cr Option to specify a custom tidier function.} \item{conf.int}{(\code{logical})\cr Should confidence intervals be computed? (see \code{\link[broom:reexports]{broom::tidy()}})} \item{conf.level}{(\code{numeric})\cr Level of confidence for confidence intervals (default: 95\%).} \item{exponentiate}{(\code{logical})\cr 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{model_matrix_attr}{(\code{logical})\cr Whether model frame and model matrix should be added as attributes of \code{model} (respectively named \code{"model_frame"} and \code{"model_matrix"}) and passed through} \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_group_by}()}, \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.Rd0000644000176200001440000000730214762101121020741 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{no_reference_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables for those no reference row should be added. See also \code{\link[=all_categorical]{all_categorical()}} and \code{\link[=all_dichotomous]{all_dichotomous()}}.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{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 (.assert_package("gtsummary", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) res <- glm( Survived ~ Class + Age + Sex, data = df, weights = df$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_group_by}()}, \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_contrasts.Rd0000644000176200001440000000376114760117574017777 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr 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"))) glm( Survived ~ Class + Age + Sex, data = df, weights = df$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_group_by}()}, \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_compute_terms_contributions.Rd0000644000176200001440000000533314760117574023143 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, e.g. \code{glm})\cr 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{ \donttest{ 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() } } \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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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_list_terms_levels.Rd0000644000176200001440000000723414662130321021016 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, e.g. \code{glm})\cr A model object.} \item{label_pattern}{(\code{\link[glue:glue]{glue pattern}})\cr A \link[glue:glue]{glue pattern} for term labels (see examples).} \item{variable_labels}{(\code{list} or \code{string})\cr 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}{(\code{string})\cr 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 <- glm( Survived ~ Class + Age + Sex, data = df, weights = df$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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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_variables}()} } \concept{model_helpers} broom.helpers/man/model_get_offset.Rd0000644000176200001440000000270614662130321017403 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_add_term_labels.Rd0000644000176200001440000000655614760117574020255 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{labels}{(\code{list} or \code{string})\cr An optional named list or named vector of custom term labels.} \item{interaction_sep}{(\code{string})\cr Separator for interaction terms.} \item{categorical_terms_pattern}{(\code{\link[glue:glue]{glue pattern}})\cr 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}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{broom.helpers} should not return a message when requested output cannot be generated. Default is \code{FALSE}.} \item{strict}{(\code{logical})\cr Whether \code{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{ \donttest{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) |> labelled::set_variable_labels( Class = "Passenger's class", Sex = "Sex" ) mod <- glm(Survived ~ Class * Age * Sex, data = df, weights = df$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}" ) } } \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_group_by}()}, \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_higher_order_variables.Rd0000644000176200001440000000344314662130321023001 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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_terms_levels}()}, \code{\link{model_list_variables}()} } \concept{model_helpers} broom.helpers/man/tidy_parameters.Rd0000644000176200001440000000314614762101117017273 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \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 (.assert_package("parameters", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_vgam}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/tidy_remove_intercept.Rd0000644000176200001440000000313014760117574020507 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{model}{(a model object, e.g. \code{glm})\cr 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{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived)) glm(Survived ~ Class + Age + Sex, data = df, weights = df$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_group_by}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_avg_slopes.Rd0000644000176200001440000000502414762101120017261 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{marginaleffects::avg_slopes()}.} } \description{ 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 (.assert_package("marginaleffects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ # 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_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_response_variable.Rd0000644000176200001440000000335314662130321021617 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \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_select_variables.Rd0000644000176200001440000000527414760117574020457 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables to include. 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}{(a model object, e.g. \code{glm})\cr 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{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived)) res <- glm(Survived ~ Class + Age * Sex, data = df, weights = df$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_group_by}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()} } \concept{tidy_helpers} broom.helpers/man/model_get_assign.Rd0000644000176200001440000000325314662130321017377 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_marginal_contrasts.Rd0000644000176200001440000001653414762076566021052 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{variables_list}{(\code{list} or \code{string})\cr 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}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{marginaleffects::avg_comparisons()}.} \item{model}{(a model object, e.g. \code{glm})\cr A model.} \item{interactions}{(\code{logical})\cr Should combinations of variables corresponding to interactions be returned?} \item{cross}{(\code{logical})\cr 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}{(\code{\link[marginaleffects:comparisons]{predictor values}})\cr Default \code{variable} value for categorical variables.} \item{var_continuous}{(\code{\link[marginaleffects:comparisons]{predictor values}})\cr Default \code{variable} value for continuous variables.} \item{by_categorical}{(\code{\link[marginaleffects:comparisons]{predictor values}})\cr Default \code{by} value for categorical variables.} \item{by_continuous}{(\code{\link[marginaleffects:comparisons]{predictor values}})\cr Default \code{by} value for continuous variables.} } \description{ 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 (.assert_package("marginaleffects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ # 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_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_get_n.Rd0000644000176200001440000001020714662130321016345 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, e.g. \code{glm})\cr 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, exposure time and the number of individuals. 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 individuals (\code{N_ind}), 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_group_by.Rd0000644000176200001440000000453314762071357016773 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_group_by.R \name{tidy_group_by} \alias{tidy_group_by} \alias{auto_group_by} \title{Group results by selected columns} \usage{ tidy_group_by( x, group_by = auto_group_by(), group_labels = NULL, model = tidy_get_model(x) ) auto_group_by() } \arguments{ \item{x}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{group_by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr One or several variables to group by. Default is \code{auto_group_by()}. Use \code{NULL} to force ungrouping.} \item{group_labels}{(\code{string})\cr An optional named vector of custom term labels.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} } \value{ The \code{x} tibble with, if relevant, an additional \code{group_by} column. } \description{ Indicates that results should be grouped. By default (\code{group_by = auto_group_by()}), results will be grouped according to the \code{y.level} column (for multinomial models) or the \code{component} column (multi-components models) if any. } \examples{ \dontshow{if (require("nnet")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} mod <- multinom(Species ~ Petal.Width + Petal.Length, data = iris) mod |> tidy_and_attach() |> tidy_group_by() mod |> tidy_and_attach() |> tidy_group_by(group_labels = c(versicolor = "harlequin blueflag")) mod |> tidy_and_attach() |> tidy_group_by(group_by = NULL) mod |> tidy_and_attach() |> tidy_identify_variables() |> tidy_group_by(group_by = variable) \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_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/reexports.Rd0000644000176200001440000000203014662130321016117 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport.R \docType{import} \name{reexports} \alias{reexports} \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} \alias{where} \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]{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}}, \code{\link[dplyr:reexports]{where}}} }} broom.helpers/man/model_get_response.Rd0000644000176200001440000000451014662130321017746 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \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_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-clean_backticks.Rd0000644000176200001440000000131614662130321017756 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}{(\code{string})\cr A character vector to be cleaned.} \item{variable_names}{(\code{string})\cr Optional vector 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.Rd0000644000176200001440000000576714733566032021146 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, e.g. \code{glm})\cr 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{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) glm( Survived ~ Class + Age * Sex, data = df, weights = df$n, family = binomial ) |> model_identify_variables() lm( Sepal.Length ~ poly(Sepal.Width, 2) + Species, data = iris, 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \code{\link{model_get_response_variable}()}, \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/model_get_pairwise_contrasts.Rd0000644000176200001440000000557714762101120022045 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, e.g. \code{glm})\cr A model object.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables to add pairwise contrasts.} \item{pairwise_reverse}{(\code{logical})\cr 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}{(\code{numeric})\cr Level of confidence for confidence intervals (default: 95\%).} \item{emmeans_args}{(\code{logical})\cr 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{ 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. } \examples{ \dontshow{if (.assert_package("emmeans", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_response}()}, \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_contrasts.Rd0000644000176200001440000000332314662130321020131 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/dot-select_to_varnames.Rd0000644000176200001440000000277414662130321020544 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}\cr This function will soon be removed from \code{broom.helpers}. Please consider \code{\link[cards:process_selectors]{cards::process_selectors()}} as an alternative. } \details{ 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 } \keyword{internal} broom.helpers/man/figures/0000755000176200001440000000000014357760764015273 5ustar liggesusersbroom.helpers/man/figures/broom.helpers.png0000644000176200001440000010005114357760764020555 0ustar liggesusers‰PNG  IHDRôA°9GÑ pHYs ʱå4tEXtSoftwarewww.inkscape.org›î<"tEXtTitleRStudio_Hex 2016 v7 outlines}Êp} IDATxœìÝw˜UÛðûLú¶³t.XEQìˆJU©¬X°¢¯ Å^±‹Ÿ¢",X°! Ò¥‘Þ;Û[²Éœïe)²©›df’ûw]ïu½n&“‡-¹sÎÌ9ŬiC2[ªR¾H»y_ï yi]E†Ðº" ¿¯oHMUUÓ#Rb m‡¿\àS—»â±_Ô²>" ?:Q 5 JÛƒ„¯¨íå°\H<£:sßé?žhÖGD‘Ã@'ŠSevBàôŸò"q?G²."Š:‘Á}sczC·[>ˆÁ¡A|/<î{û|Q°9¼•Q41Љ jú­õÊËË#Økx:€ÊU<1èóÜÂ0”GDQÆ@'2 ˆœÁé}ð*€Fa>ýŒú³YîG£FA ó¹‰(‚èD’38óL@}@çH¾Ž–C‘÷ö—· ’¯CDáÃ@'2€o¯Ë¬WaQŸ0 €¥—•ÈG}¨ÏùÛ¢ôšD":‘ŽMî«bK¿£$kTF©xE–%¼ÔÊÎ2j "?èD:•38­' Þp’Öµ¶SJñX߉‡&@j] N¤3Ógœ¬B¾àR­k©Ž€˜ã1yFôÿ,•ÖµÑQ t"˜|s­tÅe~ Àp&­ëñCäç·å¡«¿Ü¿OëbˆˆN¤¹±·Â’Qš~'FHÕºž K×Sr_¸âm8µ.†(ž1Љ44uHÆERÊ1Új]Klõ›;EëRˆâHÇ´5½RëZÂJà7EÊlÓJ} t¢(:ÚÖTÞÀªu=âð Û´E( lkkr!ñLÆÎÜw/øn­‹!Šu t¢›:$ó)Õ7x[ÓX³N‘¸mZ‰"‹N!5okkÄ÷&Å=¢×¸‚MZWB‹èDa6~pv¢CT<¦¶¦±¦ÀûlÓJ~ t¢0‰p[ÓXÃ6­DaÆ@' ƒ©3:JEŽA„ÛšÆ,÷9¢ÿø¼ùZ×Bdt t¢˜:0½ñ¢„þ=Yk\%ºá–â ¨ò‘>ŸçîÔº"£Òå‘ÞMî×À!l%÷!ƒvmM}RêŸÚMÏî !l[9Û–ýÕ£Ûd¥Bˆ·=eʳý§(Öº"£a I‡mMOÙäT´ìÚŽ”¬ã¾î,ÎÃÆEßaïº%U¶i% (@9CRÛCUÆ@ «Öµx“––]ú £±ï­áóv­Çú99(>´+J•…d1 îí;áÐb­ !2:‘Ó†$g¨Òò$tÜÖÔbKÄIg]ާu…P+QJ‰½ÿ.ÁÆùÓà*Óí 7Û´ˆNäÅ‘¶¦ ž†DŠÖõTG(&ÔksšžÝVGRHçp;˰mù/ؾj–ž¯¯³M+‘ t¢j¡­izÃVhq^_$eÖ ËùJó÷cý¼©8´UÇÒØ¦•È+:Ñ1¦ Éléúºè¡u-Þ$¤f¡é9W!»y‡ˆœ?wÇ:¬Ÿ›ƒ’Ü=9X°M+Ñ èD0F[S“Õ†Fí»£É—@1Y"úZªêÁ®5s±yÉp;Ë"úZ5À6­DÇ` S\3B[S!²[uD‹s{ÚÝ%ïå%زäGì\3Rêv‡V¶i%âØ”A™Ý„PÇ@ÇmMSê4AË.}Q«Ž¶KÞ‹ìÀú¹S‘¿{ƒ¦uøÁ6­×èwŒÐÖÔ–”Šfç\…º­Î„~þLnùëçæ ¬PÏ3Üâ{áqßÛç‹‚ÍZWBMúy§ Š0#´5UÌV4:½šœyLV›ÖåTKuW`ûêÙØºt<åZ—ã ÀlÓJñ„N1Ï(mM3›œŠVç÷‡½VºÖ¥ÄU\€ ‹¾ÁÞ—R·;´²M+Å :Å´œÁ™gê›Ðq[ÓZY Ñ¢k?¤Ök¦u)!)Ü· ëçå `~g¸Ù¦•âbÒ·×eÖ«°¨O@ѺžêXk¡éY=P¯mg¡Ë'%ömZ‰ ó¦ÁYœ§u5ÞHäÀ£>Ôç‹ümZCn tŠ)“ûÁªØÒï€Àh ­©ÙªËKù!óT¸ ѦU ¼"Ë^ê?e§nÙ‹N1ÃÈmMc Û´E oò ©íLÓ y¾Öµxh[ÓXÃ6­DÑÃ@'Ú|s­tÅe~ 1ÖÖ4Ö°M+Qt0ÐÉpŽ´5 Uëzªs´­é•°:ty)?ê*œ¥Ø¾|&Û´E %ۚƶi%Š :´!™-U)_ä•Z×âM¤ÛšÆ¶i% /:éÚѶ¦H]î…j²XѨÃEQikkئ•(|è¤Klk_ئ•¨æè¤;†hkšÝ-»öÓ¼­i¬a›V¢Ð1ÐI7ØÖ”ª°M+QðøŽDš›~k½„òòò‡ÙÖ”ŽÅ6­DÁa “fØÖ”Á6­Da “&ŒÐÖ4¹vC´ìbܶ¦±¦pß6¬Ÿ;{·h]ŠWXEÞÛg\Þ­k¡øÃ@§¨b[Sª¶i%òŠNQÁ¶¦NlÓJt":EÜᶦc4Õºo⥭i¬a›V¢£è1Ógœ¬B¾àR­kñ&^ÛšÆ#´is<&ψþŸå¯ÒºŠM t ;c´5MÀIg]×mMc Û´R¼c SØŒ½–̲ô<'L­ë©ÛšÆ>ƒ´iÍ—R¾˜˜–7†mZ)\èlkJzS’·æOc›VŠ tª¶5%½3D›VàWò>¶i¥š` SHØÖ”ŒÄ mZ+|Ê6­*:ÅXmM{ÁšPKërHGŒÔ¦Uuæ¾Ó Ø|Þv­‹!í1ÐãÜ1mMŸ Ë5^lkJZ1R›Öb¥Ö‹7~¶U·7Pä1ÐãÛš†mZÉèqˆmM‰Bc„6­€ü]‘rDï‰ù«µ®„¢‹GØÖ”¨æØ¦•ôŠØÖ”(üئ•ô†ã·5}À)Z×âMZƒ–hÙ¥Ûš’!U¶iŠC[ÿÖº_ÖK!è7>ï{­ ¡Èa Ç¨œY-„Éóœúi]‹7lkJ±Ä(mZ¡`Dßq¹ºþôA¡a Ç¶5%ÒÛ´’–è1¢ª­)„|YÙZ×S-!P‡mM)°M+i&N=_‘Ê´ÓºoØÖ”âÛ´R41Ð ŒmM‰ŒmZ)øk@Ç´5}€CëzªÃ¶¦DÇ3R›V‹EyüêOi] ‡n Ç´5}@c­ëñ†mM‰¼c›VŠºALšy†âQßÔ[Ó¾H­×\ëRˆtÏ(mZ¥Ä½ý&æ.Ôºò®sSeÖ•B¶5%Š=lÓJaÄ@×)¶5%ŠlÓJáÀ@×!#´5MoØ­Î´:Z—B3Ê `ÓÂï°oã ­Kñe‡”âñ~׺:]G¦ Î8Ùùº.ÓºoӲтmM‰"ŠmZ) t`[S"ú¯£mZ¿†«L·+ÈT@~®Àú`ï ûök]L¼c khv7˜s¦ß¶5%"/ئ•Å@×ÛšQ0ئ•üa GÛšQM°M+yÃ@’Éý²’„Ãó â¶5%¢š0P›Ö÷M&õ©^Ÿåçk]L<` GÛšQ¤°M+‹AlkJDÑP´ÖÏËAþîZ—â Û´F=ØÖ”ˆ´ppËŸøwΔҺÄ÷*Ü÷ôŸP ëMìˆïäaͦD¤5¶i_ ô0`[S"Ò¶i? ôb[S"Ò3¶i ô±­)Û´ÆzØÖ”ˆŒÊ mZK¤À«lÓ<zØÖ”ˆbAiþl^Ä6­±†€œ2ZK|C÷mMÏ냌&lkJDÉÛ¹ëç²Mk¬` ûpL[Ó;˜µ®§:lkJD5Á6­±ƒ^ ¶5%¢xc¤6­Ò™÷Fÿ)pi]ŒÞ0ÐÿcÊÀŒîB‘cÀ¶¦D‡ŒÒ¦UHyŸ‰y?h]ˆž0Ðc[S"¢£Ø¦Õxâ>ÐÔÖ´ñ—ÂdÒå¥|"ŠAFjÓª–Ë'ûOÉ+к-Åm ³­)Q` Ò¦õ$FÇs›Ö¸ ôœÁù&€NZ×â Ûš‘Þ£M«X)ψ>ãòçj]I´ÅU ³­)QͱM«>ÅEbL¿µ^ByiÙÝBˆÇ$i]Ou³N¿€mM‰ÈŽ´i]ö3<.§ÖåxS&„xËlÏÅC›Ö˜t¶5%"Š,¶iÕ˜ ôÉC3Ï0©ê œ§u-Þ°­)mÚ±[wíÃÜ—!#5u²Òмq=ÔNOѺ¼€¤MëR)1"VÛ´Æ\ ÓÖôfºÜ ÕbOÄI/g[S¢8µæß­ø|úïøeÁJlÝUýN¦Š"Ðþ䦸ô¼Ú«»1ÂmZ53>öVX2JÓï4D[ÓNWÂlsh]EÙ†m»ñÂØ)øæ·ÅALO'8l¸íÚËpïà«’œÁ ÃmZµ^ÙÖTyÍ´®Å¶5%ŠoLú £ÞùNWEÈ稛•Žÿ}Îípr+‹¶i.CzÎ ­á–¯Càr­kñ†mM‰â›ªJ<üê§ø8gfXÎgµ˜ñÞ“w Ï¥Ãr¾h0H›ÖÙÑw|Þ­+ •!Ý(mMq1µ» ·k%ŠKª*qïóbâw¿‡õ¼&EÁø—îÃçŸÖóF’T=ؽv6ÿñ=Û´Fˆ¡mM‰È(¤”xà¥Oðé´_#rþ‡ ¿{-š«ë"Û´FŽa}ÊÀŒîÂ$߀ĩZ×âMZƒ–hÙµ/’2êk] i(Ø‘¹IV+lf3J].”Vvý¼3Ú`úûOÔ Rí°Mkøé>ÐÙÖ”ˆŒ$˜0O¶Ùйqc´©]‰V둯,)Áª={°lçN¸Ußû ä¼õºŸ}zMËÖ Û´†n}üàìD‡¨xˆmM‰È(‚ ó™™èÕ¶-¬&ïÛe,)Áä?ÿDni©×cÎhÛ ¿~úl(åêÛ´†‡îmM‰Èˆ‚¹fÞ&;×´i%€LÅ.>^ºENïû¥¯˜6'5ÐçÛe0ئµftµ“ZÎàŒNµóSp·Ði•”ìÆ8õòahxz7˜,ºœ8 ¢(SU‰{žûã¿å÷ØSëÔ 8Ì“‚¤Z‰ÈL©…5;½/ùjÖ°Îhkü-¤Mf+2·Ef“SQ’·åE¹Z—T\&Ì =¯moûgòêòmZTE#t¶5%"£ª óϧÿî÷ØSëÔÁU'Ÿ áç=Ä’`GbF-Xí$€ç¿ü{óò«=þª ϸï ¾xc›Öàhzá·ª­©xº‘³­)yî0Š‚ZÙi°§$ÿu§4ià5ÐwïÏ ¦lÃÈ<éT¤7l­ó6­òJ¦îS‡dhÞ¦U³¡fåv­âm°­)På5óñé´ßüÈ5sÅlBjƒ,XìÖj_ôÏ|1{Aµ5¬›‰5ß¾Xáe”6­PÅ£}'š *'V¢*ê>uPfõM¶5%"£ ÷È\1)HkTf[õaKþÝ„ ¿Í«ö±:Yiøç‡÷üÖ ömôiUîí?>wQ4_4jSîUmM%T¶5%"à {˜›M•anµø›¡½Èµi k O’œáQ­Ï!o…nÛš&¢i§¨êyŠ./呎D&̳a¶ú‹TUŸü2«7{ß»¤QÝ,¬úæM¿kÛã…T=Øõç|l^ü*œ%Z—ã[Jñ¡Iq=Ù{|øÙ‡å7 ª­©„xYá8g¸ !ݪ#Zœ×›mM‰( ª*q×èðåsýÛ6iö`Â\JŒÿu–oØìó¸·¿ƒ¯ºÀïùâM…³[ÿ€΃TuµCëÈS¥|)\mZkèlkJD±ÈaÞ¼Q],úê˜}4x‰wñÔ¦5ä@g[S"ŠUaŸfâ8ªâ³™s±jÓVŸÇ)ŠÀÔ·E·³t;–Ò•Üëðïœ)(ÍÛ«u)¾Ô¨MkÐ>¹_V’pxÔw[Suèζ¦D4#„9n€«2¬ß%xå¡ýGÇ“&¤-eEغ` v­ø9¦Ú´è9ƒ3:òMjT^%×m†ÝŒ”z-EB);H}Þ ADúökæA„y ×Ì`è5âG‡ñ®ö  ¨Ž @½ß xïl˜õ òwü£a]þˆ•BñŒè3.ßï/¦ÏßC´5MJGÓó¢NÛ®'´5'„³úîDDDU‚ ókÚ´ ÛÈœaÒ’iI¬ö±ƒ—a¼`”« †ÿ6­ÕþVL¿µ^ByyùÃBâaºÜ U1[ÑðÌh|N˜¬v¯Ç W„;¢»í‘1Ìã€b†j÷Ý5Su»°cÙضh*<.Ýf† À‹òxumZû̀ȜÞW¯@ÏmM›‰ß{JíŽV!ÊAè÷: i„a¤=R lkogq.6ý>ûÖÎÓu›VEâé?›å~4jŽ„Û‘ßŽÉC3ÏP<ê›8W›ýKªsZ\xR·g1§Þ‰è¿ÂæfÒÖ"Ìçbùÿ-@æ5#­Iæê§Ú})ܳ~û…»ÖG ª°Y&%îí71w!ˆª¶¦†ÐeÏP‹#M:÷Eý3.¹­©pB¸ËÂ\Ã_°aþñϳñçÖ~e˜‡7Œ‰zH³ „+ uŠOUÅO¿É?Ý4¦´Ì‰Ñï… ›5CçÆƒ:_(#ó@ÂüŽëyÍ<\¸,-º8ÿ%Òd…jϨ¼ŽDg<ªŠÛŸzï¸0?ÖÂmÛ‚:_(#ó@ïfg˜‡0Aµ¥3Ì£ŒMÂTyéð>ðDñÀ£ª¸íÉw‘3c×cÊÝn”¸\/RÓì ó0Q¬öt®ôѧÜ5 ­µÅÊëêóªÂ|ê/ }ç°XàæÑÅëåÚb kDšíРг­Ë! »ªkæþºžt’ßc"yÍüùû†ø=Ž|ÒZ ÒÄÍb´Ä)w-)¨ötHn²@1¦jdîíšù±ÚÕ«‡3ë×÷yL$¯™3ÌkH˜¡Ú2æ:À@ךP mi‡×«sºŒ/˜‘y»ºuÑ£U«w€ãÈ\o¤ÙÕ‘(&­K!pÊ]7¤%±r;Dg§àÉ ª[šæMà{³‡Ó†y åð»÷F:}¡ëˆT,Ž .õ Cb˜Ç‡#KpæºÃºîˆÊÍLV(®B@ªþŸB¤1†yì“BæÄÊÙDÒ%ŽÐõÊdƒ´güL:Ç0ŠÒ–Î0×9ŽÐuL Ò– á.…¨(æ¶±¤;as‹é ³`b˜ë†´$²É”A0Ð @š MvˆŠ"¶c%ˆ\˜‡·Ÿ9ÃLúq&ý0Û÷ÔüÚs <ªŠ%kÖcÉšõxâ͉èЦ†\s!ú]z.æúœ ¸9µm@¯‘evà»F=qõŽéø×é?Ô¤¤ø|œa^sÒd‡´8…Óê t ajµ–d ÂSxœZW%kÖcÌøï0cþŠ6k ·k7aÅÚMxò­ÏqÖi¾Gßµ}>~¬,³ß6 ,Ô¿û§r­û©uêœðü¤ÉQä܄ŒNá%DåÖ²æÊ›è„»¼ò&:©¿kíó—¯Åóc§`ѪuZ—R­ÂâRüºp•Ïc¬Anh¨K)« õH…ù=ƒ{âé»ð/0"¥òïÁœÉö¥Aüí¢È©êødIT×áp×~J~öÝõΗ'ljD›]hmK ê9¡†:Ã<8•Í•aεã tŠÅ iµBZ“!ÜNOyÔ§ä® ¼øaÞýâT¸Ã3ci¨ëȰ $[’Ìfpz$JÝ@®S"×)±½D¢Ôþ2Ó 7âYƒzŽ0IÔKWðK“ pÙ’_ñOa¡×c«B]Qœv;†¹?&Kå”ºÉÆíX)êèeÇìDÂíŠJ¸¯X» w>ýþÝâ?d¼i’¤àìÚ&tÌTÐ&UAˉæÀG^Ê%–ôàËÍnÌÚãF…r)GŒÍûצ´D3«ï›Ø°7(£Q1„U"Àìqá· °6¯ÈëÓ¤”øöï¿‘”†³Z5óùqæU×Å͆8iŠNRކ»TßLWx\×´¼”o|ö-^ø0' 6£ÇU'€sj›pY}3.k`BÃÄà߬9%fíñ`ùÁÊÿý“¯"œõbµ×îü ÓõD]s¢×ã„EERÛXÒŽÿà”í°aÖÕçú uUJ|>«²y‹·P«0?âv€ H'è¤âÄp‡Ç ¡:Z•”áöQï}­¼ŽC`ps ®=É‚‰Á_ûÜQ¢â§ü¸Ó¥<ðDø–-®ôÜ>ß5ê‰zÕ„º0I$ŸžsrõËßÂê±æR@±Ý5‘!N:Ä@'ý9î0Û+ÇéªëpÀ»n³yÇ^\wÿ+ذmwÀ/Û¢–‚»ÛXÑ«±– ã*0c—ã7V`Þ^OÔoûÛâ*ÀU^B=±e×0¯R“Pw{<ø¿ŸfaívÿðÜ;¸'F$Ì¥P*׈›ì•7¸±×8éôO±B*VÀHé9<5ï„T]ÕŒÞÿÚ° }îyûyßÿüXu:ÅŠk›Z` ò=;Ï)ñÑú LÜT}eÚÞ½_]¨›“+`­SÐóC õÍ›ÄT˜Ëãp˜¬•ÿŸÈ@èd,Âtx¿k yxÔ.Tà©ÀâÕÿâÚû_FAQ©ßS™pK+ :ÕŠ„ nn€|—ÄØuøh}Š*´ßŒ¦ÊCÝÖÀÿ÷áXÁ†úìÕcçÁ\¿çÕm˜+æÊÑ·r8ÀyS LÝzÀ‚¥«pÝ=/¢´Ìÿˆ´eŠ‚÷α㔴àÞÀË=À{ÿ¸ðþ:}ù±Ž õ¶éÎL¨.Ì…éh€›¬ pŠ) tŠ ó—¬Âuw>вrÿË߆4·à™6؃¼¯iÆ.7žXáÂö⚯7KKh™eFëlêÔR–  Ù&   \¢Ø)±«Àƒ¿÷x°nŸ…åÁ}xØâ*ÀÕÛ¿Ã×Ùh` ¾—v ¡î¶a. SåupÅZ¹FœN1ŒN†h˜[àÅ3mØ,¸k£Û‹U<ºÜ‰ßv‡¾Mó,.laE׿tmfAôÀ?MH ,ßáÆkøzµ«v¹zÞfW!.ønf_u.$E?Ô£æÂT9…®X M6=¡¸#r§‡mÞÐlKD—ãÂu:"¿ óZñ]í8»vpÃòÉ[Üxl¹3¤éõ–µMèßÞŽ~ím8­^ø>;ÏÛT7f—â›?­èkž’r¨À¾2gСñ0?6¼sexó.t2˜yc†Âí, Ûù8B'à 4Ì3l“.pàÔ ®—ç»$\âÄ÷; W1+ÀU§Ú0¼‹´°F$cº4³ K³ÌÛTÛ¿*ÂÚ½¾kÜXPÕ‘ú•Ý:†1Ì•ÊM\3 ˜+{‡›Ì`§2¢ñ¯‚ )Ð0ϲ |Ý=¸0_qȃ ~, *Ìmf»º:°ù© L½9¶ŒL˜«K3 VŽLÈn ~­ õÅe!½VU¨·IKö{ìo¬Áß·qvQy³šb…4'@Z“!miŽ,¨ YPíéÖZ•™¬àÛQõø—A†h˜×¶ Lëî@Ë”ÀÍ'oq£×oeØàšr‹ ¸¥³ëŸHÇÛ}“ƒº6V“À½“ðn¿d˜üü3£êeåN ùÊ]Çlf#HÅ i²Wvà;Úª=jBm¨ŽLH{Zå×7o`# ÿbÈP‚ ó©ÝhQ+°_q·žXáÄ=”Ãà½oç7·`åÃéøðºd4Šrÿ×]øê†Xü”ŽPŸ}õ¹h›î;Ô7ïØ‹O§/„jÏ€ê¨ Õ‘iÏ€´¥@Z’ŽŽ¶n¡J. t2ŒH…y¹¸q^9þïßÀ¶•­SKÁÄ!µ0ûî4´­«ŸÛPú´³áË¡‘õÚf]å?ÔÇ|<N·äÍjDQÂ@'C˜·xeD¼¨BâúßË03À¥`לfߦcà™v]æT0¡ÞíÛš‡zóïÞöÌÅ‚¥«B:?Nº7oñJ\?üaó\§DßYeX´ßÿ{¢UàÃë’ñõ°d†ÐF5š õM…5õ)—t„âã“Í̹‹C:7OßïL÷"æn œSŽÕ¹þw}k‘eÂÒ‡ÒpKçÐÖqk!ØPßb¨·ËLÁ•³½>þçº !—ˆ‚Ç@'ÝŠT˜ÀW›+°òÿ‘ù¥'[±øtœœ­Ÿkå &Ô/¨A¨_Ô Ëëc{øßëˆÂƒNºÉ0€UùþGæ#º%à‡ÛR‘– Ã‹åŠF¨g9l^+( }x" t'Òan² 4hà{?÷g¯LĽ“ü®í6‚>íl˜À’¶PC}w‰÷Žni©A‹ˆBoWK‚ ói!†yZ[;v²ÃVMtEïôKÆc—x¿{ÛˆzŸ¹Pÿyû>¯eg¥|"ª:éF°aÞ<Ä07ÙÚÖ5cÜ d¤:ކzV’‚)7¥`xãÜüŒÞ§Ûð~ÿ[·êsw¯;x}¼}ÛVAÕHD¡3Þ>“¢æU®í`Ç%­møckL Щ±)ã^/ÄÍç8°ñ /Î,õy\U¨ÿ|å9^ךÿ“W„ëf.ƒ¯Mr/íÖ¹ÕQ08B'ÍiæUÒ.ocÅ%­­1æUží‘„Žü÷„ßTX‚ŽSçàµÕq ìèÏfo©/¬Ø€³§ÍÅžRï×Ïëש³Ú· KÍDäG褩¹¬À€»óæÙ©†7Ìã•IÆ^—Œ³^Í…ÛÏÍþùÎ <¸ðo<¼h-²6HHì+uú•Wydø 0)3E ÿÚH3 sí´o`Æ ¿W@•{J˱7À0?¥U3\{õ%¡HDAc “&.[ƒA÷<P?ó)0Ì#áÁî P"ðíIKIÆgoŒâèœ(ÊøGQ7÷èûH””ú¾‹:Û!ðuý̆y ZÕ6á¢VÖ°žÓa·áÓ×Gá¤FõÃz^"òNQµpÙ ¼ûqŽÌu¢o;ﻼ«níL|?n ºtj¶sQàè5U#óÒ2ïwF™GÓmm5nk6™pcÿžø}ê‡hÇuçDšá]îsÿXë‡?†r'o€Ó“ú) NÎ6cíÞÀúÁ«Qý:¸êâ®Ôç ´8©Qª#¢`0Ð)â‚ ói:Ð,Ø0· ¤µa˜‡ªm]SÀ~R£úxí‰hÚ¸ÖóÞ6•ˆ¢SîQU×Ìý…yÕ5s†yôÓvÛÎÝhÖ¤!ÜH‡è1s-G¿Û»fþM(×ÌæaÑ8ÝOÇ–c¨ªÄ¤ogD°" "¢j9Gæú—d î{øù×?AUÙ^†ˆ¢‰Na·pÙ\{Ç#~GæYöÊà82×V°¾}×^Ì]¼"BÕQ¨èVN³×á4»n˜BøV~÷ËœðBD5Â@§° fš}2§Ùu£ <øéóY –F "ª :…ÅïŽÌ9Í®?e~Z®UcÇî}Ø´ugª!¢P1Ð©Ææ,ZŽwù_šÆiv}Ú_| Àì…ËÂ\ Õjä÷EË1 À0ŸÊMctiÃ~OHÏ›½ˆN¤' t ÙïAŒÌæúµþ€÷@7ùø‘ýùÏÆTCD¡b SHæ±A•ð¹ík×fÞÛ«îÞwÅ%¥‘(‹ˆBÀ@§ æ¼›]ÿVïr£ Ìû]îCβ{}LJ‰ [vD¢," ‚L˜ónvý›»Ñåõ1‡E {lfï?‹õ›·E¢," Ì4û71Ì`ö† ¯uldF‚U Umï{½¯ß²=eQè ®™ww Y2Ã\¬ó>BïÜÔhšé=Ðsó Â^…†N~}ÍœanÓÿr¢¬ÂûõóËO¶R|ü\ŠKÊÂ^…&ðFÈ—82]9«¼ÿL³’œ{x„žšàýgZX\öºˆ(4 tòjöÂet·ÿ½Ù£æ» T|´° ïu£i† ·tv ™é`ònO¡Šéyÿ¹ö<Åzd z-ŽÐ‰ NÕÒS˜;%^þ­¯Í*E©ëèñ»óÊðãí©èÒÌÔkðá‚2TøØ ®×i¶#ÿßw s:‘^ð: Ð0¯á0W%ðñ¢2´}£.9.ÌÊ ¿é‹Â ^›€ 0v÷‘u½—žl;îxoÌfŽ ˆô‚tœ`üi„Â|Özøº«vyßÅ 6ð`ÓA§Þƒ0~IözoÈ2ì,Ç|;‹Ê½›”ègiDT t:"òa® ­Íg˜ÿ»ßƒ‡¾)öy}÷¿|m|BÇsy$žá}šÜ¤ÃÎ9~w¸"§÷;á“ÂVÕ T†ùÀ»‡Óé}]2PÃ0okƒÉV}ø*QñôO%øÀϵÝÿêÐÐŒ©¼r¨O•ck®÷opÏSlh˜vülGa¹@OàH/è„ [¶cÐÝOhæ.Ä;sËðìŒä•zoF÷H ú9ñªÈ)1zF‰Ïcþwɉ#î­‡¼HMI®q]D tÂ3c>Šì4»—0Ÿ¶Ú‰‘ßc£ö¾\ÜÚŠ+ÚxïFÇõc vx¿Þ£­¸b`ƒŸOÓFõÃRÕ°úïõ>·*@Î…á óå;ܸZænò¾¸ßs+Àk×pt¨?w»ñÖï×Î…žº<ñ„¯9¥Ïèš6j–úˆ¨æxñ‘•îóq— ¼õOÔ fÄ« óù*†N,ÄY¯æÖ(Ìàæ³8µ?£·U·÷\ÆU§Øª¯Ûç{•Aó& t"½à;"ah¿+±âÏu>ùjse¿q– ŠŸ›Êÿæ%.‰—-Å«ÿÙ&TÉ6gzœ8š¤ê½0³ ·xÿe·¼Ö«úÙŽy>>xYÌf4¬_§ÆõQxp„NØër\{Õ%~ûjsî[âô9R?6ÌU |òG9ZŽ>„gªÙ&T^’ˆì §ÿãÕÒíxægß7¼(Áë:þß}´W=õäæ0›¸þŸH/8B'!ðö³CJ‰ÉÓgú<ö«ÍRbL'û #õcÃ|öîŸæc˜`5N7á¾n\*ˆÂr‰Aã }.lšaÂÈ‹ª_KîQy›¼¯|8÷ÌÓkZ"…&EÁ;Ï„_}÷‹Ïc'oq(?.Ô«Â|SЇ¾-Æw¾1L•ÖÍ›`ÝÆ­>y¡g"ìn$ã*Á ±~¿÷4xÿÚd8¼|?ÿØZü2ï³*çvlWã:‰(|èt„IQðγ•¡>éÛ>¼Å —ZŽwϱÃjW€¦V<6£c~/ƒÓÜÔzƒºµñ¿»oÂêµ|úÙM,¸®ƒÝëãtÔ?”øýPuwW.ií}ÙßË˽>f6™pv‡SC®ˆÂNÇQ·F?)¥ß‘ú7Ûܰ[œ8ódž›|(èaR’“pÿmƒpË€^صgF<õª×c…^ï•ÁÁ¹_“V”ã…™¾¯›·©cÆ‹Wy_öWá&¯ðþàŒÓNFr·}%Ò:À¤(xûÙ‡Ào¨OÚXIƒ[‚f6™0´OŒ¼s(2ÒRO½þ!\Þ¯·_ÛÞŽsNb›T~YçÂÐ E>>[YM×ò:Õ3þqâ`‰÷un}zt¯I™D tªV0ÓïÁ8ÿœ3ðìÃw M‹¦G¾¶`é*üøÛ|¯Ï±[^¸ŠËÔüY¼­}>.€Ëã{¦äí~IèÐÐ÷Ÿþ[s½·W5›L¸ú’óCª‘ˆ"‡N^)ŠÀÛ£húÝŸ¶-›bôCwàüsÎ8îëª*ñøËïû|îˆn4Içò(_Öíóàò÷óQì£3ÜÙÅ[;û^%°l»3×y¿»ýÂs;"3=5¤:‰(rèä“¢¼óìHþ§ß«S;3ÿ»ûF èu9LʉkÇ¿únÖü³Áëó³“öyž§¯HD-ýÓ Ø–ëÁ’m¾ïch‘e”›R`ñ3ѱz—_¯ö~3\£úupåE]B)“ˆ"ŒN©š~à3Ô…èÛ£;ž1 õëÔöyη>™„½ûy}ü”ºf ;‡›Èøãoš½Aª‚™ÃS‘•ä{w=)»¦ùÜ ð®¯…ÅÌ· "=â_&Ì_¨ŸÝáT<ûðhJ+¿çÚ½ïÞùô+ŸÇ¼Ö+ &îðêW«l3êÔR°·š®h™‰ ~žŠÆ܃0ai9æoö>ÒÏÊHÃÀ^—Õ¨V"Š:¥rúýa´oÛ OúûæâäMpÛ >èyq×€Ïó웣¬ÜûÔîåm¬>7=¡£Ì ðáuÉèýQÁqÕÒ~º#'gûÿ3Ï+•ù]±ÏcîÚv›­¦åQ„0Ð)hB p † ¸&¤ç¯^»S¾÷¾g¼Y^e¯ó ô<ņù÷¥á³Å娖ëÁ)uÍÞÅÐÈ\Jàæ/ «áWiÒ .nØ+œ%Q˜1Ð)êù=¨>.ÔÞz®mê„þ«©JàÇ¿øéÞ§ÛÐ96¥éÔØ‚Nƒÿw¾3¯ _¯ñ½MìsÜÅÑ9‘Î1Ð)ª¾ÿu.[ãõñ‡À¨ËC_¦6gcøºËwÝuîõÙ¥Ý#]Âåoÿµ|‡}ã{ªýÒóÏÁeÝΉRED*:E«ÂQ¯õyÌc—$ú½»:xðð·ÅÕŽ4¥žü¡=ÚÚЮ>å«lÍõ çØ|ŸÍtvžô®(VED¡â»EÍÿ}> [vìöúxÓ î9?¸ejy¥£g”àݹe>·<­š†g W:P¬âÒ÷ò±ÇÇusxñw£IƒºQªŠˆj‚ïn‡ò ðÚØ‰>yéê$ØÌm"SáÞŸ_†g~.Á!MDèDEN‰øì•ý®¼ƒz_¥ªˆ¨¦è/¿?EÞ¯Õž×Ô‚>§vÓÕô¿œxè›büë'þ늶¼©«È)qùûùXºÝ÷ÎrÍš4À«OŒˆRUD tЏ]{÷cÜäï½>.ðzoÿ½ÎWír㯋1k½÷Æ!Þ\s¯ŸW…ù›Ç@rR>}}’ÙïœÈHâûŽ¢â§Y QáöÞë¼M3:4ð¾ÜjO¡ŠÇ¿/Æg‹Ë}nKêÕ$ðòÕñ½®=Ð0·Y-˜ðæh´mÙÔçqD¤?ÜX“"®Üå{Dý÷7nø¼žÿ\ /uIŒþ¹-GÂ'„æ0¼«-²â·ýj‘Sâ²÷ü‡¹¢¼÷ü£èÒ©}”*#¢pâ"®ëYí!„€”ÞyâÒrÀgkAÀÄeåøßôbì̯٠o‰ ž¸4~ןW…ùÂ-¾Ã^xän\sY·ÈEDÁ@§ˆ;­M Ü2 >ü|šÏã&.-G‰SbG¾˶{Ÿ¢Æ“—%"-!>ۯ棸-ä­|‰HèÏ?2®Š |6yºÏãümAŒVµM¸ã¼øl¿Zâ’è96°0üÞ›q÷×F¡*"Š$^C§¨BàÕ'FàÆþ=£öš¯\“K^:/qIôø s6æ÷Ý20 UQ¤1Ð)j„xùñPÞÚÉI HO­åó˜ [ZÑó”ø[w^X.qÉ»…ùÓÞÎ0'Š! tŠ*Ex뙇B©+Š@ÿžc›£QXTâý8¼‡ËÔ‚™fâÞa¸ë†þQ¨Šˆ¢…×Ð)ê„xåð.dŸú¹¦^¥ëÙ0ú¡;pJ«fè{ëÃp{¼ïwÓÙth_¿Ú%.‰+ÞÏÇÜM…ùˆ[D¡*"Цøz×#Ý4Ô›7iˆÿÝ}®¾ô|ÀŒ9‹0{á2¯Ç'Ùžé_ËÔæD0ÐICU×ÔU)1nÊñ[Ãf¦¥bä]7`Hß0›*ïls{<õÚ‡>Ï9ò¢Ô­?W’ Ë%.{?‹˜fæÁÛ1œÓìD1‹NšRןºw¦þ8 E%¥èvÎÔç ÔJ:~¤=nòt¬ß¼Í빦)xàÂøÙœaNDÇb “.\Ñý<\Ñý<¯ã¥÷Æù<Ç =“à°ÄÇ&2U7ÀæOÜ;ŒaNèd¯ˆCy^?«±ΰG±"í–K\ú^>þØÊkæDttoËŽÝø?ÛÆ ¼ÖËûÕXqýg…9§Ù‰âKüÜ=D†õÁ„¸*¼ïíÞ· ç5õÞ~5–üü ?®õßžaNè¤{KVýíóqœÐz5V-Ûîd>ú¡;æDqˆNº—Z+Ùçã“W:1dâ‰ýÔcQ?KòF?tîÚ/JÕ‘ž0ÐI÷\ãï÷/–•ÇE¨_}ª YIÕÿÙ2̉ât¯ß•aHß~ûbY9OˆíPÏJ2ãóçnF£úuŽ|­VR"Þ}n$Ü(Îñ.w2„מ¼ª*1qÚ>ûry9`ÂàZ0ÅÜÇUÅmïÂÙñÇy}°úŸ (/w¢Ý)­NØ„‡ˆâ AQÆ<ý¬3>ùê;ŸÇ~¹¼nUâ‹¡)0ÇL¨W†¹+»3Àf³â¬vm5®‰ˆô$fÞî(öUîý~/n¾îj¿ÇNYéø IDATÄ€qpÇÄôûñaNDTŽÐÉP„xñ÷ÀUáÆ„©?øbØõQ¨ŠˆbbN0¡ž³*:¡Î0'¢Hc SLÒS¨W­3$ÌŸ¼aND¡a SÌÒC¨W…ùâm…ù½73̉(4 tŠiZ†:܈¢‰N1O‹Pg˜Q´1Ð).D3ÔæD¤:Åh„z a.„Àó g˜QØ0Ð)®D2Ôƒ óçFÞ‰Ûõ ìÄDD` S܉D¨3̉Hk tŠKá u†9éâÖ‘P¿þ¿ÇV…z…çø¯3̉H/èׄxéwêÆ u†9é‰Y눴Vêðñ—ßø<6g•@Þ¿6W~PÀ0'"Ý` áh¨{<|6yºÏcsV9ñË: Ë¥ßs2̉(Z8åNt˜¯>1" é÷@ÂüùG†3̉(jèDÇ暺¯s<ÿÈpÜ:°w+#"òNô5 u†9i…NTPBaNDZb yL¨3̉Hk t" u†9éȪP¿±Ïj{á‘»æD¤9®C' €¯<1­š5Á¸œï±mçœÜâ$Œ¸ùz\Ñý<­Ë#"b J[öÂ-{i] Ñ 8åNDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1À¬u‘âªpc÷¾>±[­¨S;#Ji¯ ¨yE>IKIFJrR”*ÒÎÁÜ|””•ù<&;3v›-JÕLÌúÆ­ÛÑ¥×0ŸÇt<½ ~þü(UD¤½O&}‹gßüØç1Ýsî¿uP”*ÒÎϼïçó˜É¼ˆî祊ˆj†SîDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDDèDDD1€NDÇ1›c¶ÅQL‹ë@7›MZ—@¤;‰ ­K ¢ÄõGq‹Åâõ±=ûbÿÁ\جV4ª_ {+«TVîÄÖ»!!‘•ž†¬Œ´/¿°ûæ¢¬Ü ‹ÅŒÚéÈLO Sµ+*.ÅÞQZV³ÙŒÌ´dgé£íþƒ¹Ø{àL&2RSBn¯[ávcçî}(,.AjJ²¡Úp&ùôÝûàÀ¡<8ì6Ô©‰ZI‰¯GJ‰ÝûàP^¤”HNL@ƒzu`µûík×Þý8˜›Õ÷˜‚¢bìÝåÎÊ÷€:Y™HO­ñ×õæP^ví݆݇ºµ3‘”˜Ôó=ªŠ¼‚B£¸´ ;ÒRj!=5Š""Tµ~û/¢†þÛó9¯ ï|: _}7{ö<òu“¢ c»¶6à\si7Ü/Ê»ŸM†Ûã©ö±®: ý)­ŽûÚŽÝûðì›aú¯óàtºŽ|½Qý:˜üÁ‹hqR£€^WU%~¿_ÿ8s—¬ÀÞý‡N8&3-]:µGïË/Àeœ‘?)%æþ±Sœ…9,ÇÎ=ûO8&µV2Î;«®¾ô|ô¼¸+,!Nû.X¶ËV¯­ö±“[œ„Kºž}Â×·ìØ±§âû™óŽû¹@VF.îÚ Ã®¿§·ié÷õøm>>›< —­A¹ÓyÜc§·i‰k.놡ý®Ôu¿ñÿŽÐ·ïÚ‹w>ý ßΘƒƒyùÇ=–•+/ê‚A½.ÇimZ„­§Ó…)?üŠogÌÁâ•¡¤ôø¾åf“ §´nŽKÏ?ƒûö@ÝÚ™a{í@íÚ»9?üVícõ²³ÐïÊ‹NøúÁÜ|¼ùñ—Èùá7ì?˜{äë&EÁYíÛâ–½qÕ%]ƒ~ñeå_ÿâói?â·K±}×ÞÏÎÊÀùgwÀõW_Š.ÚýÚ;÷ìÇÔ«ÿ>Àà>=NøÐ0É*<÷ÖÇXºz-¤”*¿:œ‚éŸñùzûæâ‹¯Æü¥«°lÍZ—žpL­¤Dt8µ5Îíx:úôèŽÆõëõo2*‘38]†ëdf["ºŒ®ÓÕÈÚ ›ýöCÒ·Þõ`ñÊ¿0tÄS8p(ÏçsÎ?ç |øòcÈL |d[ïŒËŽ æcÝ>¸ž9üÈ/_ó®»óQäæV{üꙓРnm¿¯9kÁR<öÒ{X¿y[Àu6oÒ/Ê+K ÿn:¸»öî÷æ&Eñ;ìöxðØKï¢ßm#ƒ sظuúÝ6O½ú<ªÔsÿKJ‰—Þ‡ž7Œ*ÌÊŠ¡#žÂ}£^ êן¿Öm„ÓU rJü†ûFáõ'ú s r¶ã£/¾Á #ž:á{³gÿA\:`x@aTN[þfÌYü?" ª¦=ߟƒO½æ7ÌÊ©Ï&LÅ ÷ èûYW…w=þ2îx䅀Ü® ¼ùñ—¸lÐÝÕÎBi¡¤´ ó–¬:òß?Ï^ˆw=æ7Ì`öÂe¸úÿÛ»Ïð(ª5àÿ³»IHƒ4z/¡AD@¥£¨ ´äJ vºˆt”^¤)%5 Eé½Hï½w’MBBúî¹ ÂîÎÙ:³»ïïyî‡ËÎygΜ9ÿ>ƒ˜,½­1›wDóÎ}ÍjæpðØi´îòbÖn²ø³óË{Œûóï1Ùp3€’Å _¬&pαûà1¼Óg>új¼Yïu6nÝÐ ù#%5 }EZz†ðûÎ_¾Ž¿úÎè—Òy¿ìƒÆM3ÚÌ'Ccµñ‰|9:>ùú{Ì\aUMs–Æà‹“-þù8çòÝ üðÓ2«~GqëÐgÐX›5õ̬lœ>0nÚB¬ßºÇì}lؾg/yfŸÝ¾‰k·îšµŸùî™ÿþJáëS{Çè)óÌ~ï¦ðÍ÷³Í~ŸN¯Gß¡ãñëê f¿7׉³Ѷ÷Äk“¤7v€Û÷xrK§ï×Ì:I>sñ >6áßáhsü½s?zô‰G©–]ùeffáóá“ðÛ-z~¹Ú¤Güít“?SÉb…Ÿû·3¯à½O¿Áí{Ïߪ3W‘ëæ!)[7ôÀBþ?ëgܼsßì÷îÜKbþ´º†;÷âQêc>q›w4¹­ÔPû˜)ó±jÃ6«k€˜5›0aÖϽwê‚(,Yc“:6lÛ‹aßϲɾàÈÉs8zê¼U'=s–üŽK×nfü¼ÇÏ\°h?ié5M{óòðDÿÑS,>[·ÖìßÉ÷³~ÁšM;-ú¼¼®Þ¸žýG³âHwìçƒÆM{n€ˆÍ»"zÕz³Þsñê |0ø[«O‚õzŽc§â#óQÌ‘{Òº j…É (U¼è3ÿ?%5 aä”T«ëP©>ìÚÁêý(™[7ô£§ÎcYÌZ‹ß?iΤgHGJ¹pù:¦Ì”ÜÎØpðäÊÑÚ+óüfþò›äIF~ûŸÄ䟖ڴŽe±kN>2×oÇðIs,ºòÉ•“ƒ™¿üЇ ‰˜õËoVÕ³y×Aì;|Òª}ØÚ”‘¸zã¶Åï×ë9¾¾Hxû}‡ObÖbë~y8z s–ÄØl–º}ïÆL]€ûX¼ïg/nÎ:½}¿ž`Öh£)YÙ9ølø$¡[.¦œ»t )©iøyùjÉmó_¡ÏüåW›ÝFy½i#”/]Â&ûR*·nèËb×Z|¿x2„³Æú{M‹–¯Â¦]Ò÷ºJŽžÜ¯òít«ëÈsŽÁߊ_]deç`À˯ìL>iŽMæ-ì=t¶z?«ÖoÃÐ ³¬>Ø@ܺÍVïÖlñÞyÀðSùéôz|5~†Í¿3ÓF)bè}îRëN,î?LÀêb£nKÿÓìù*R®\¿……Ñ«¬ÚGrJ*†|7]hþ@‰¢ÿã2³²±0z¥UŸ×ÇÝ:Úl_JåÖ =??_T -ÀBþÂïY½Òª«=ˆ[·EhƆÜF¯|îq+cÔ*Š ~,ìÖÝX%vå½jý¿CÑRT*†âEB„Ÿ%NHLÆŒŸ Ï^·–§‡Ë•2ëì==#þ½ã¹÷÷óAõÐ fÍP^·e·Õ“íI¥b([²8*•+-üX£^ϱn‹éäðÇÆí8{ñªÉmÔ*†|ÒG7.Çé­±˜2z äóÊÓÒ±ø·?„ju$_oT -oÖS2 £¤›ZfV6¦-Š–Ü®Á 5°vÙL\ص ë"f¢Ñ‹µ$ß3/"Îê[¢#lyq{º˜¨P¶Æ ùËçNÀ²ã0²ÿhÖèE¨Uÿµ·j¡åñÚËuÍ/ÜÉPCÇ“Æø¡Ÿá®Uؽê\ص³¾ûJ¨Ùœ»t 'Ï]r@•@)Cî™YÙ˜!Ýp½¼<1ñ›/póŸ¿pjk nú ³¿*´0ÈÜ¥±’·ôzŽ9æµ£úˆkû×âÔÖÜ:¼?O%´ÀÍâßþ”¼g®º´Ç©­±8¸6‡ÖGacô‹“)èç‹y¿Áå½bתŸqvÇ |;ä¡gz&$ââ•–”owßl›Ç‘Ñ8°vö¬^ŒÊÊ ½wÏ¡ã’Ûü´,Vr›G À7_ôA™’ÅP¬H0ú„·Ã¯s¿æ€mHÌÚÍVŸlÛŠZ¥Â˜A}qa×Jì^õ Îí\…?ŒzÄïè©ó¸rý–ÉmVoØ&9"R·f¬þe*½X Á…а^-¬X4/Ö®fò}âµÂOpXƒ1öÌ(ä¾Ã'$ßS´p06ý:_ôÇM¡m«×0ð£nX±èGßüõí?_ôíÖѦÏö+5tã†|‚O{v†—ç“•ãT*†nÞĤáý„Þ¿óÀQ›ÖPÐýÞk–ÎÀ¡õQøg]bæOB½ZÏÿá­Û²ë¹Å> ùåÇQèÛ­ã¿ÏÅzh4èÚ¡ ~ýIúÀ˜ô(«%&ÛíØXh¦÷´±ƒ0࣮ÿ.^¢V©Ð¡Ms¬Xô£äÁ-#3Óf3oàãîðÈ~,ôï¿Õ¯S‹§Ž1ë_­Rá·yÞ®õ¿¿KZÏ{‡ãýÿ½#´%Îvçõ¦X0yÄ3‹¶T®PËçŒzÞûÜ¥k’¯=uÞä6 ëÕB¯°¶Ïý{ãúµñ¿w_7ùÞ«7nãЉ³’u:˜A}Ñïý÷þýŽ3ÆÐé­˜:z€Ðû¥Ž1Ë%ž`ŒaúØÁÏýwóòôÀ”‘Ò5Ä®µím¡ÊÊbÒ7_bËïópdc4öý¹K¦yæð ^ú1â¾Ý:"  áÕâEB0¢ßû8²!áíž_äǹ}C/Y¬>êfxæcNo£ZhyÉ}ØòìµNõÊØ¹rÆ ê‹Æõk£|é¨P¶Z¾ÚÀà•ãŸöͯMóÆx³Å+_kX¯ºu|SrRCf"u4¬W Ý:þ¬šU*âãîÒ÷¸l59®há`Œè÷¾Á×^®[¯¼TGx_]Ú·ÁËuk|­ß]„†©Ï]¾&üyŽàåéï‡}n°öòeJ¢C›æ’û¸rý¶É ]R‹º0ùè.}²ô÷Žý’ÛØ[éEñqN_ o÷:ªV*'¹ŒO¬KHLÆ^‰ÑÆ/ÖF­ª• ¾V»zès«Uæ·iç›vô k‹íq ñQ·x¡F”-Y•+”E»ÖMžÙ.!IzÎL¥r¥$· ,ä4Ë.[Ëíz»Ö¯}¶[¥bèòî’ûØä¤Mî-Œås&˜œÍžWvN¶í=$¹ÝGj;¡Ékï¡ã—X̵i—ôóîí%_—º2>qö"îÜ(ùYRþ×®µÉ’¶-ÅW©ëó¿vF_+U¼jU•^õþCe,ˆ’«m«×L.§Ú¶å«’ûÈÎÉÖÄDF©ï®‡FcrÕÂjT‘œïrÊA·ÃLéЦ¹ÉcLØÛÒW{þ1Þ°wì?,9©ðõfL¾.µ:dÒ£‹ï}®Ž& 1eÔÀGCMñ˜çc‹š\‰Û7ô/¾²ÊÕ¦YcÉ}¤¥gà¶õÉÍ5üË>fÝ¿½xõ†ä¤‘Ü5ÒM©Z•Ê•6¹MVvŽ6< Ê3¡Ñ˜I£öâåå) ì¡Ñ R9éÅk7 c¤ûóòô|Œ2Xä÷(pOÛ”·nÓäU¯¦Ø(ÐÄ9K0êÇyŠ~ôÓQÜ:>µ Ÿ¯Ðd‰'÷´M/Frý¶u ]äyÐüÎ^’nè¥KÚ—H¼à#gè"'eJŠÕ!²Ýé Ö5t‘«Æ xyI®Ò%²/‘¡C%©TÞôí—\Þ¤ó»M¤™˜žž!¹„lJŠôz妿~Ø[q“àÉɋԉñ;ÏGŸ>J},¹…¯·äï1Uà–Ï#ßµ)$F}ò{±v5”*^Ä`Ür~?-‹ÅÁc§1ïûa¨PVz¢œ«rë†.ºøG‘ ÉmD,¦ˆ>Û›—ÈJX¢÷䥮"à¡Öðc$"gîE Kÿ…ëHÅ3%$XlQ//O@"à"Xàùy‘[6J"ò}//é‰MÆÜ˜¸ø÷?±øwëóR, )±…@ÁcLá`éÐC õþÃÉÙçÚ¤Ghþ‰P¦Xs[((  Y‹éONª{‡·“ŒûÍuèø4 ûã‡~†žß¶¤L§çÖCîîZ9.ÍÊ5Ý¥†þ I},}V-z@ ”ÞÎØºÈzP€ô 6ô—™•ýo ª% ‰%.‰<‹.²/s®?³¢‚ Ýš…:§Ùf½q)2ÎO™gý$·IÏxþwæÈÉ”ÖüËŒòQ×fM~œ–Žc§¢ëç#¬>ñwFÎu¤±1Ñg=±H·2ÁÏWzÂX~)¥¯< xJ/"º]zF¦Á% E†4½ëÝNäg7ÆÇ[z¨X”èÛ™øK,«j Žœ¨ÓÉwoÕ–ß{C«5ŠœÔÛŠ5¿G‘ ±†øùú`þÄáÂ3ãsmܱ¯¶ÿ[v›.åìܺ¡{h¤g@U±¬I8bŒ ÿáç%ÒH=×J÷ø|ιÁ±Hs]³ÝÓC#tågÍ}QÑ߉ÑŸË™ˆœÀZKi³úíE#xŒùN:ƈÜûVoËO|_{¹.f}û•ÙM=>1 ]>n³(ggàÖ ]oÃuž­ /P1fÑðeŽ@RœJbY×ÿ¶ûüœœçN‘Ä:Ñ:cùUdg[>äîéa»†¥1óÉg`îÓ–°EJ3½ªùû×8ÆdØ ¾Ù¤–—–Ò¥}L;Øìï¦N¯Çïf jå_V}¾³p놞-˜3,r¿Ö–ø¢D®ê…FÁǦ ÇŠ ×g 6à¬ì¡…"üBeŒQ«m÷µ=Qq&¶üý#2CÞˆÆ3g cž¶ä ºw| +ý 40/Î9†N˜eõúÎÀõ./Ì`Ó?6PÞÞðHb¯h#5ö¼p^Áç·½Nf¤ÿÊ%zbáçã\3ÇɳDfþ¿T§ú3é[–*iƒ}XJü¢Aú{oè¢A$-1$0¯4Ï&0¦JÅrVïÃZ¯¼ôö¬^Œ!ßÍ0_lLff¾™8k–ΰcuòsë†.:‘Mä±o+îYª¿Ÿäà¢ÏŽŠÌ`5v.ä/=C÷Qjª`Òõ2Æ,ždC”ÁßWºõo‡÷²”LtºÈœCǑɴ¥JÅâ©c„êpÁ…°dÚĬ݄¯ÇÏ’¼¨Éµ÷Ð ìùç˜äR¼ÎÌõÆ Í ºòÑÇär/U\:Äå~¼Xè‡H8ˆ±ƒ°Pµ‚uHoççëmö¢,"WèIÄN•ÌØÚ ù‰¬)ákà#rë)ÙÈðÎ.¼mkìZõ‹ä2Åy­Zo:ÚÙ¹uCOIMº?~?^ºÉ˜J¦²‘g×¥BSrI­6ðHn Úd¡9!" íJa,$9¡îÞ×]µTñ"X±h Þ}£©ÐöÛ÷¡unÝÐà–@üžÔZÉ€tH„=ˆ¬.'R;œ>/½{Í*†×{¯"R‡ÀÚÝ€X„±:ˆó¨$°<§+LbÊÎÉÁÍ»Ï/Ùš—^ÏqéÚMÉ}•/óü µwÉ‹‰ôŒL\¹~KrÿÎÊÓCƒE?ŽÂk/וÜöêÛÂóyœ‘Û7t©5¥ãµIx p…^®ŒãºH„åÉób‘‡'Κ^ëª X©ãô¹Ë’KTÀñ³%·©QE,è…(Wuÿ†ÇN·jE@¥8{ñšÉׯ߾+t¯½‚†ˆà8zJrg¦V©0é›/…ÿÓ&Z2£dnßÐ¥²µ·í=$¹ÆÊ•r|C¯]­’äÂ&—¯ÝÂU‰h×Ää:~Vòój9pT,[JryÜøÄ$ÉüëŒÌLì:pTºŽÊt…îìÊ–,.yeù(õ1¶ºÀJ_{þ9fòõÃÀý|b$7 A]éÈá•.~ïªV*‡Š#?Ö¬2©tnßÐ×oÛkòõ?7í”ÜGµJåe™WÀË MÖ“ÜnõÓÌ«6l“|„¯pp ÑYÆZ¿ÖP²Ž•ë·š|}ý¶½’+ˆùx@ý:Õ$?ËU=LHÄ¢èUè?z Þ<C¾Ž¨•9åÊk"C¤s—Åì(Ùú­{LÞG_»y—ä>^®WÓèkM¾(ùþ]ŽàÄéÑ/g'’!òT޳rû†~ñê £P§/\Á†m{$÷Ѥ¡ôÉ^Úµn"¹ÍOËb‘œbxÆpZz¦.ˆ”ÜG›fMÎ,o×ú5É},ùýO£“ï²²s0iÎRÉ}4o\_x ~W³vê¾ÑÃ&ÎFÔÊ¿ðÇÆX³ýGOÁ‹mºc÷AÓW‚JÓ¶•ôwfßᓈ\aþ*_W®ß¢èU–”esWoÞÁŠ¿¶|íÄ™‹B£€¦švÝšU$G;ôzŽÁßM^ç!WfV6æEÄ O®µ¥%1kÌþÜ·MÏW`Œ V9#›6ôœÌÇ8öû8¤>¼nËÝÚÝàqÓŸ›ŒŸ˜„+4Cµi#é3d{i׺‰ä3ÙÚ¤GèÙôskAgffáýÁã„þhÞ{÷u“¯·|µä Né™è"GdIDATþå($å{Œ&G§Ã#& M êÚ¾ä6®èŸãgðÅðÉ:€'ß×n_ŽÄõÛw\™åZ½ö²Ðª__}71k7 íóÜ¥küít4~÷}lÞ}ÀÚmæë ³pôÔùgþ-!1 /4Ñ´‘ñ‘8ƺü]9y½Žzn;õq–ƬA£v½1ò‡Ÿ.ÃR½o߇†ïô´…QÐ&=’Ü~ö½’Oë”,VØ!KKI×Þʼn¸‰ÈÉ´íð¿Í²Äk'qhéP¯Ý囼Oo±ØL9Å'&¡Õÿ>Á»o4CÕJåñ0A‹˜5›„¾D¾>Þx¥¾õ«0Yª¿ºw| ¢V˜Ün÷Ácxéíèòn”/S·î>ÀòUëqë®ô£AµªVBÃzµLnãå剻´ÇÄ9KLnwìôy4x»'ºuxË•Âý‡Zü¾æo\¾&= ·lÉâhÕäeÉí\ÑŒEÑ’¥>NÃOËb1yx?Ue/Oôo‡çE˜Ü.G§Ã§Ã&bõúíèÞ¯Ô¯¿§Kk“áüåëØwø86í<€ƒÇN;¢t³%§¤â®Ÿ£]ë&¨Uµ’’óç&Ä'J?^¾LI£·»rõù_;Ì]ú»ä$ÂM; Ñ;½ñeŸ÷ðf‹Æ(]¼T*†ŒÌLܾûÂÎGñ×Ö=Џ“’š† ³cê‚ht|«9Þjþ š4¬÷ÜEÌß;÷ãËQ?HŒÇjÈÎHÅÍàæ?k ×Ù~¶½]NU¸^‡;Ç6áá¹}(÷JJÖk¦K’KVvb×n6û}];´‘}Õ²Ï{‡!rÅ:ÉÄ·{0}Q´Ùûöyo¡í>èÒ ¢VHž%$&cÖâßÌ®ã«O{@£Vö÷Èrt:ì˜,ˆMâT’Ïz…año A`æñÆû°qÇ>OæRdee[Šäh:½«7nÇêÛÍzß'Ý;IÎÞ.Q´0z‡¿#yb<9Œ˜<#&Ï…F­†§§‡Ui‘Ž‘™‰å«6`ùª ðôР|™’(Q´0Ôj.\¹!9Ôž«yãúv®Ô0Î9îŸÞ‰KÛ–!;MúBÑRv½‡ž‘Š‹[–àà/ƒpEì€äLcø°K{¹Ë@ÉbEðÕ§=í²ï–¯6@›æ…¶ ,ä1ƒúÚ¥Žzµª"üÓÃþ®J›˜,|ÀYWAI úùbì Í~_Zz†S5sKùûùà‚ßû¡Ÿõ4{«NñÍ<¿¬ìœ¿|ÛöÂæ]…›yÑÂÁx÷u±hl)éÆiZ2g×Ͷk34).M{'b'àdÜ$¤'‰ýòí-8°ðŠ1ï¼Þ•Ê•¶QEÖù´gg³–@€ic™õžnÞD›flZ‡Ÿ¯æNøÚêFg%2#—N§wºYá];´^éËÙˆLü3峞aBËä@@AÌðµ[Žb‰ôQ7ƒáRö’™3kgáè¯c6¯Ì¡GÈøË‡ppÑ\ܼ9™b¡öÒ®uÌÿµÅ÷¿ úcÂן۸*Ëyh4X:}Ê•*n“ýðòÂ’éc…ÖiÏ‹1†“G z¨mñÐh°ð‡B«â¹ªÀ€‚ÂyŠ,ªDs' Cƒ¤Ÿ§v6ßlañÉJ•ŠeÑÿƒ.f½§i£ñÃÈþNù°§7š6Âûï½ëÏÒegâêžì_ø%~ìÙ–~É£×çàÖá¿pàç~¸sl8—gáöo4ƒJÅ0oÒ7(hzQ”üÔ*~š8L–õÛM ,„u³¬^ÕßÏ¿Î`ñ¿Ÿ¯þX2Íêt//,ž:o4µí¿³ñòô@ÝšU„¶}å%y'ýXÊ»€âþ€–¯6»›z˜ˆ)£\‡Ý”Bþ~X2m¬EW”½ÂÚbÎø¡’‹N¹‹zµªbÞ¤oìèÄ9œÛ‡‹úãÚîès¿Ê¡lc˜Y©‰8¿qE|¤[Ò«”ÙRáà@4~zà+Y¬~›7Q(Wx2›{þäáŠm2ÅŠcí²™èÖÖ¢³ôkWÃÖßç -XcJP@A¬úe >íÙÙ¢¡ò•+àï_çâ­–¯ZU‡«ø¸{'Ém4j5>íÙÙÕØ‡¯7~ûi"FüȪ…š<4ô k‹écÛ°:ËÜ×"(  bæO2ºÒ[~!ˆ[øªT´|Tê½wßÀÆè¹¨ad¹fQ5«TÄò¹dɪx£Y#áã²!Œ1ôo‡µËfÚ}1™”»—q$jNÿ1™)bATö ûMÉÔ{Wq4zNÆMBF²tÒ–-¼ÓºÉ3Mæ¥:Õ±5všIˆGzF4j5 úù"0 BË—F­ª•Z¡Œ"'Öݾ÷'Ï^ÂÙKWq÷~Þ,TEC‚P¿Nu¼P£Š]›8ès²póÐ:\ß·º,yçƒåÅâz¥PÔâ¶ FŦ=P¤šØãR„âh" ½Á 5°>j¶ƒ*"Žðàì^\Þé°e3¤ªWU°€<³Ó ÈH~ˆÓNÃáÈoðè¶üÄb g{„—rÿ Ž.ÓNSZ3ç ˆÕ3^CÓ)*þ.€cz…,Téô3ÁðŠÜÕåztç"ŽD@‘ê¯!´y/xø*YB!®#;=×öÄâö‘ ²=•eÂ!ÎÑ¿s”v/gé×ðeñ‡9ðZ\ Î ø€"üÍ]2/þ”~ù]”mØ*µ}ïBqoz}îÙˆ«»GN¦üëÚçÅî¨8Ƭ¨ýyìØÿFן™vÌŽHmìš¾%Öe¤¥É …Ü_×egâÚîÜ?³ ^ëŠ"U•ùØ!„ç–xí.nY‚ÇñÒ –Λå¡aÞ]Ÿ’ÿEƒÏµ[x' ÀäÝ‚¢¹Š°î±ôPºö.Nÿ1wŽ×B¥½áWX „Bœ\ºö..n]Š„Ë‡å.ŶVœ~áÉWmaòÁàNÑÚ[zÆõž Æg€£¡Ík´Ð31­¯u§ë†ÖB±ŸœÌǸ±µÝbM­ÃŽ2•n@§eI’ëÈ ­šÐ92áÀ© ÚW8g½8 ˜8§Ü˜Öƒ‹úáÖ¡uàz×O_"„bœsÜ;µû~‰ëûW)­™'€c€>#á%‘f˜‘‡þäÆ{BDD¢+¼YöWŒ³a÷²¼VÛÉi½}ôoTjÙÁêÊ]!„Kºq7/vXš²ÌÓgðÑá±‰Éæ¼ÑìÕû{FÞ `lL÷ÂQj¦ûžaæîÃ^rcZC*ÖG¥V½á`ÿÕÏ!„8Ì”x\Þ±ÜáIh‚6ëõè­=cÉ›-Žã zx @xl·à–Lͧƒ£–¥û²µøË‡ ½z %꾎ò¯uÆË[î’!„ÈH—‰ÿÀý«dIB“pžq>¸STâ:kvbu8KXt–àÚz ø`ŠY>G)1­„Bdô4ÖôàÏòÅšÀDÎù0}†¶¶µÍ°â =¯æÛ‘h®ìé¿B§÷ü–1Þ×Vû¶VnLë›Úê*áÜiT„BÄ$ß¹€‹›AÊÝËr—’_çl¡J•5:,2%ÁV;µiÓí‘’àó¸ÞÁ³‘çáM[îß¹yµEª4DÅf=Q éhEB!Î)+%W÷ÆàîñÍ \OŸoÀ°Hí [ïÙ.WÑ—&œðV\Àv€j:À+ÚãsÌötè%þÒaÙcZ !„Ø–RcMŸºÉ9¥°×X}ݔΑ‰k¼ªc€Göü,sès²p}ÿ*ø¹?îÚ(î ŽBˆ9â/ÂÁŸâÊŽh¥5óÇœa\Šº`å°¨»5sÀ˹.ïââ©ñàsjG}®ˆ‚%BÚò},*w)„'qÿa6lßgr›"Áx³…b,]RÊý+¸´e)’nZô¤—=q€GéÕš¡áKÞsÄ:|}öÝCêégràUG¶)Œ1Ši%„'¡ðXÓô ýÃ#´¦ÏølL¶À•'÷×Ùl($¦5—Ú³J7x‡bZ !D”k =û¦sTB$~/WÖµ5}Kø(-¦5—wPqŠi%„Qz¬©ÆH¬©£("uE· RJ‹iÍX®B[ôoá2r—B!nÉ)bM#Çš:¬¹ È+¦gpøL%Å´S©)¦•BÌUbMEQ ÆŽ…ªÆ¥àî`ü•»ž¼< ø¡Ü+a(Y¯ ˜JQõ !ÄepÎqÿôN\Ú¶ ÙiŠyâ9W8¾Ógjç„ÇBQ™ÝŠkè¹"zõUZLk.Ÿ ’mÙAÓJ!6•tã4.nY‚Ô×ä.%?‹cME± =W\סL­› ¤˜Ö\ÓJ!¶¡ôXS¨0 ó2íi¹ 1Eñ =Wl·à–LÅg¨)w-y©TŠi%„ )<Öôã|-’ÐÁi:lk¶tÐû&p Dîzòòô DùWÂQ¼N+0æT¿VBq<Îñàü~\Þ¶ âå®&¿$Îù$ž™8=<Yr#Ê);ÕTYš1>ƒBbZsù­€J­ú  T5¹K!„EJ¹{·,Fòíór—’ŸàÑ*xéyÿÜŘË)z®¸ÞÁU¹ŽOg@¹kycÓJ!ù(=ÖTÅùÀŽQIÇå®ÄRNÝÐs=]Fv€ r×’—JãI1­„·ç±¦öMBs—hèO•WЧ`ø€¢VñòF…&]Q¬F€î¯BÜHü¥C¸´y Ò“ïË]J~9ÔTUÁI}–^Ë»[p¹î²¢{HqÎôc|;ç½›‹bZ !îBɱ¦ ˆÓ1>$<"ñ†ÜÅØ’Ë5ô\1½B^Téô3Á ¨0bŠi%„¸2…Çšâýâ´{å.Ä\¶¡X\ Î øÓJ!v£ôXSǸ“µ? ÅeØŠK7ô\kú–ðÉÈÈÊ8†PÔê/ÓJqv Ž5Í0ßÃC5RÎXSGq‹†ž‹bZ !Äv(ÖTYÕÔ%¦G@SWÍà r×’Å´Bœ²cMqÀÀΑÚrâhnÙЊi%„s)<ÖT Žo•kê(nÛÐsÅ„öcÞº!ÓJ!Æ)=ÖT­Öé°4)Iîbääö =—òcZûÀ;@Q „7@±¦Îƒz>+z·âœO‡ÒbZÕ”xbZ !Ž¡ôXSÎøà°ˆÄµr¢$ÔÐ XÐ!éA}@1­„w㱦¾‰3ÞšL¹‹Qê&ä‰iý€¢f§QL+!ÄÖRî]ÆÅÍkꬨ¡ XÙ#¸š|:€7ä®åÓJ±…ÇšnWq>À™cM…º”ÓZ¦a{”}¹=TO¹Ë!„8 ½.wŽnÄ•]¿)6Ö´sTB$”v–¡HÔÐÍD1­„W àXÓ4Îð£+Åš: õ-ôÇ{!%²=ôc@1­„'’òà*.o^ŠÄ›Š{ÒËecM…º•âz„Ô×Ï ˜VBˆ’)=Ö”©ø€NË÷È]ˆ3£†nybZ§PTº Å´âÞ(ÖÔ}PC·¡<1­_( w=yQL+!îG鱦zŒê­UÜ¢ðΊº¬îT:'‡O ˜VBˆÒµwqië2Ä_>$w)°µL—Ó¿Óòä+rWâjÕl\Ml÷fŒég¨#w-yQL+!®‰bMÝ5t;ËieŒÿ ˆÜõäE1­„¸Š5%5t‡YÕ; @¯Wã(¦•b+ 5]’•“=¢ë¯)Š[ÞQCw°•=C*ë9Ÿ ð¶r×’Å´â<”kªØ12ñ”Ü…¸jè2yÓ:@ ¹kÉ‹bZ Q6}N®X­ÌXS†‹œcDX¤6VîRÜ5t-è à´ ÏÀ0@€ÜõäE1­„(Œ²cMS9ÃTßBÚ‰k*:R+Å´BLQz¬©GŽÇWïþú@q‹Â»jè B1­„¼”kÊÀvèÔºáK“ŽÉ] y‚º=i  ¼ÜµäE1­„8†ÂcMoqÎFP¬©òPCW¨<1­ß𗻞¼(¦•ûQz¬)O÷™{Kqg„ºâ)9¦5°t TlÕþE5@ˆSJK¸…‹[–B{Uq#ØœqÐé¿ê´<éºÜÅ㨡;‰¸!õýLå®%/Ši%Ä:Ù©¸¶;F‘±¦ 8¬c|@xDân¹k!Ò¨¡;Ši%ÄuükƒœÌÇr—“ß]Œ¥XSçB Ý Eô(êëͲ¿¢˜VBœÅš{ †îÄòÄ´ö»–üËÕFh‹ÞÓJHkJ쉺 XÑ3¤9çúé ˜VBé¿XÓµÐë¶\+pNÅ1°c”vƒÜ…ëPCwNÓúâ›`LQõ ±+gˆ5 ¾¥Û|;žNÌG ÝÅüÓÊPÔê/>Á¥Ú¢Å´· àXÓ‹)ÖÔõPCwQ+{†TÖA?q¼-w-ùQL+qeŠŽ5eØ¢â|Åšº&jè.ŽbZ q Š5%r£†îþiUa8µú Å´§§ìXÓÇœa Åšº:‚º‘•=ýƒõÜc4ÓÚú}*YUîRF±¦DI¨¡»¡¸žu¡WÍC¹kyÅ´'¡ìXS„ý;Ek÷Ë] q,jènŒbZ 1Åš%£†îæbÂJy3¯Çýc#@1­„é.mY‚ô$Å`§1ÆfëÒUãÃc¦Ê] ‘% €Ü˜VÝ$€u‡Â¾ÓJä¤àXSÔЉUbº‡TQ1ý4oÉ]K~ÓJòú7ÖôÌ.@a˵r`+×óáщ'å®…8/jèÄ&žÆ´ÎP]îZò¢˜V¢èXSðKl8Åš[ †Nl†bZ‰¢P¬)q3td#6§è˜ÖbڪŴº¸'±¦K|ûœÜ¥äÇ¥Wk††/}xOîbˆk¡†NìfE÷zœégxMîZžA1­.‹bM‰;£†NìîiLë,åä®%/Šiu 5½Í9N±¦ÄÞ¨¡‡ÈÓ:€ŸÜõäE1­ÎMÁ±¦éŒ±YkJ…Ž^Ä¡bz—TqýDŠi%ÖRz¬©Z­û²ÃÒ¤krWB܇¢¨Ä}Äô n æ|Å´s)=Ö”s ‹JÜ%w%ÄýPC'²QrL«ÆËe¶Gé—ÚRL«Bèõ9¸wb®îúY [®@8¾£XS"'jèDvÓJ¤(=ÖTŸÁG‡Ç&&Ë] qoÔЉbÄt/\IÍtßs LîZò£˜Vy(;Ö›õzôÖž‘»BjèDVön¡g|8jÉ]K^Óê8 5=ðA#ÿ’»Bò¢†Ni[3h´¥ƒÞç`ã)¦Õ}ükº=Ù•5‚Í€D=ç“yfâôðXdÉ]!ùQC'ŠݵP —Z=Àg42—ó Šiµ-Çšê­×d¦XS¢dÔЉS ˜Vו™’€Ë;¢kÊØ9"ñ„ܵ"…:q*OcZg¨&w-yQL«ù”kÊ.sðo(Ö”8jèÄéüÓÊð-EÍNóôDùÆÓj’Äš¦ª Nê³ôZ†ÜÅb:â§µ¼‹ˆ§Æc(¦ÕiP¬)!öC 8=ÅÇ´6ï…Cä®FVJŽ5ðž¡x„vŸÜ…b jèÄe(?¦µT÷ZF67Öôêîß“I±¦„Ø5tâRÖô-á“‘–þ%Å´ÊO鱦 ›ðîâø¹‹!ÄV\ÿ¨BÜ’ÒcZ+µê¿"åä.Å.”kªGN¿ðÈä«rWBˆ­)ê@Gˆ­Åô n Ÿ ކr×’—+Æ´*;Ö”e*Ý€NË’vÊ] !öB ¸¼±c¡ªq)¸;Å´ÚÅš¢ ÔÐ‰Ûø/¦• ¸—ÜõäåT•ZôBHÅúr—bŠ5%D9¨¡·£ø˜Ö–}àRZîRLJ×ÞÅ•]Ëñàœ"Ÿô¢XSâ–¨¡·Û-¸%SóéÓ*Nᱦçƒ:E%®“»Bä@ ¸5ŠiC±¦„(5tBÄ|P0H•¥Ši}NâÍÓ¸¼y)R(îI/=À£UðÒ1òþ¹‹!DnÔÐ É#®wpUäði`xSîZòstL«’cM¾ (Ö”ÿPC'Ä€'ËȪ¦¼¢Üµä•ÓZ¡I¨=íÓªìXSÜäœ ‹Jˆ»B”†:!F¸]Lkn¬éöd$?´Í>m‡bM ‘@  +º‡çL?À‡ä–­bZ•kÊ€8ãCÂ#oÈ] !JF A1½B^Tëõ38ðªÜµ<ʘ֬ÔD\Ý£ÜXSÎ1 ,J»WîBqÔÐ 1X\ Î ø@Y¹ëÉËœ˜V%Çšr†;*Žq'+j;J[žÅ¢†NˆÖô-á“‘‘1”q `ŸÙiòòA…&]ŒÆ´*8Ö4 À|ÕHŠ5%Ä|ÔÐ ±ÂŠnA¥¸Š¯Ä˜Ö€25Úò¿˜VŠ5%ĵ)êDˆ³ŠéÐTÅU3À Ïê/F0¦B‰:­wŽoV^¬)Ç1=ÓLÚ!w)„8;jè„ØHnL+ÿŽYýÅyQ¬)!6F ‹ +ìǼuC”ÓªkJˆPC'ÄNâºejÝ%Æ´Êd3TÐy™ö´Ü…⊨¡bgJiu óŒóÁkJˆ}QC'Ä”Ój/kJˆcQC'Ä¢» ôR«ÇB1­6D±¦„È€:!2ˆéREÅôÓ¼%w-¶Ä­ŒñkJˆãQC'DF+z·âœÏP]îZ¬Ã/q°áa‘ÚX¹+!Ä])*9ŠwÓ)"as‚·öp ƒ3>Æõ˜3ŒKQªEÍœyÑ:! ±²§°ž{Œð9µÜõHàÒ«5C×>¼'w1„jè„(Ίî!õ8ôÓÁÐDîZ aÀAèÑ¿S´v¿ÜµBþC …ŠëØ`3”—»–§nsΆwŽJˆd€âÂÓ qwÔÐ Q°˜°RÞÌëq?ÆØþ2•‘Æ›­KW}˜*S „ ÔÐ q1=ƒKª¸~¢ãcZÙZµZ÷e‡¥I×÷™„KPC'ĉ¬èüWñÛóspXÇø€ðˆÄÝöüBˆíPC'ÄÉp€ÅõêÌ€)ÊØx÷w0V—¡ý…bM q.ÔÐ qR=Šúz³ì¯Ç× X¹»,ó3ôÕ=ZûÈåBŒ:!NnuŸ Ò99|ÀzX¶¶–érúwZž|Ŷ•B‰:!."¶{H3Æô3Ô|ËYÇ ŽQÚ ö¬‹â´ô+!.",*~û©ŠÚzœ³^L¥œiÁ1@Ÿ¡­EÍœ×AW脸 U½ôzõ0Î1à^Oÿ9À’¬œì]M‰—³>BˆíQC'Ä…Åõ®Š>  aƒ:/M8'sI„;ù?æîóÒ ûIEND®B`‚broom.helpers/man/figures/lifecycle-questioning.svg0000644000176200001440000000171414357760764022321 0ustar liggesuserslifecyclelifecyclequestioningquestioning 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/figures/lifecycle-superseded.svg0000644000176200001440000000171314357760764022116 0ustar liggesusers lifecyclelifecyclesupersededsuperseded broom.helpers/man/figures/lifecycle-archived.svg0000644000176200001440000000170714357760764021543 0ustar liggesusers lifecyclelifecyclearchivedarchived broom.helpers/man/figures/lifecycle-defunct.svg0000644000176200001440000000170414357760764021403 0ustar liggesuserslifecyclelifecycledefunctdefunct 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-soft-deprecated.svg0000644000176200001440000000172614357760764023030 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated broom.helpers/man/figures/lifecycle-maturing.svg0000644000176200001440000000170614357760764021603 0ustar liggesuserslifecyclelifecyclematuringmaturing broom.helpers/man/model_get_coefficients_type.Rd0000644000176200001440000000715214760117574021635 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.cch} \alias{model_get_coefficients_type.model_fit} \alias{model_get_coefficients_type.LORgee} \alias{model_get_coefficients_type.vglm} \alias{model_get_coefficients_type.vgam} \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}{cch}(model) \method{model_get_coefficients_type}{model_fit}(model) \method{model_get_coefficients_type}{LORgee}(model) \method{model_get_coefficients_type}{vglm}(model) \method{model_get_coefficients_type}{vgam}(model) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr 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() df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) glm(Survived ~ Class + Age * Sex, data = df, weights = df$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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_all_effects.Rd0000644000176200001440000000460214762101120017367 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{effects::allEffects()}.} } \description{ 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 (.assert_package("effects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/model_list_contrasts.Rd0000644000176200001440000000401514662130321020324 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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_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.Rd0000644000176200001440000000760514762101433023352 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{exponentiate}{(\code{logical})\cr 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}{(\code{numeric})\cr 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}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{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 (require("gtsummary") && require("emmeans")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(dplyr::across(where(is.character), factor)) glm( Survived ~ Class + Age + Sex, data = df, weights = df$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_group_by}()}, \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-formula_list_to_named_list.Rd0000644000176200001440000000451314662130321022261 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}\cr This function will soon be removed from \code{broom.helpers}. Please consider \code{\link[cards:process_selectors]{cards::process_formula_selectors()}} as an alternative. } \details{ 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)} } \keyword{internal} broom.helpers/man/tidy_broom.Rd0000644000176200001440000000133014760117574016253 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 object, e.g. \code{glm})\cr A model to be tidied.} \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_vgam}()}, \code{\link{tidy_with_broom_or_parameters}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/assert_package.Rd0000644000176200001440000000475514760117574017076 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}{(\code{string})\cr Name of the required package.} \item{fn}{(\code{string})\cr Name of the calling function from the user perspective. Used to write informative error messages.} \item{pkg_search}{(\code{string})\cr Name of the package the function will search for a minimum required version from.} \item{boolean}{(\code{logical})\cr 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}{(\code{logical})\cr If several versions of a package are installed, should only the first one be returned?} \item{lib.loc}{(\code{string})\cr 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{ \donttest{ .assert_package("broom", boolean = TRUE) .get_package_dependencies() .get_min_version_required("brms") } } broom.helpers/man/tidy_identify_variables.Rd0000644000176200001440000000555114760117574021011 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{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. For \code{fixest} models, a new column \code{instrumental} is added to indicate instrumental variables. } \examples{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) glm( Survived ~ Class + Age * Sex, data = df, weights = df$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_group_by}()}, \code{\link{tidy_plus_plus}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/tidy_margins.Rd0000644000176200001440000000541114762101120016557 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{margins::margins()}.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} } \details{ The \code{margins} package is no longer under active development and may be removed from CRAN sooner or later. It is advised to use the \code{marginaleffects} package instead, offering more functionalities. You could have a look at the \href{https://larmarange.github.io/broom.helpers/articles/marginal_tidiers.html}{article} dedicated to marginal estimates with \code{broom.helpers}. \code{tidy_avg_slopes()} could be used as an alternative. 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. 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 (.assert_package("margins", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_predictions}()} } \concept{marginal_tieders} broom.helpers/man/tidy_add_header_rows.Rd0000644000176200001440000000727614762101120020244 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}{(\code{data.frame})\cr A tidy tibble as produced by \verb{tidy_*()} functions.} \item{show_single_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Names of dichotomous variables that should be displayed on a single row. See also \code{\link[=all_dichotomous]{all_dichotomous()}}.} \item{model}{(a model object, e.g. \code{glm})\cr The corresponding model, if not attached to \code{x}.} \item{quiet}{(\code{logical})\cr Whether \code{broom.helpers} should not return a message when requested output cannot be generated. Default is \code{FALSE}.} \item{strict}{(\code{logical})\cr Whether \code{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 (.assert_package("gtsummary", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ df <- Titanic |> dplyr::as_tibble() |> dplyr::mutate(Survived = factor(Survived, c("No", "Yes"))) res <- glm( Survived ~ Class + Age + Sex, data = df, weights = df$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_group_by}()}, \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_terms.Rd0000644000176200001440000000451114733566032017256 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} \alias{model_get_terms.cch} \alias{model_get_terms.fixest} \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) \method{model_get_terms}{betareg}(model) \method{model_get_terms}{cch}(model) \method{model_get_terms}{fixest}(model) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr 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()}. For \code{fixest} models, return a term object combining main variables and instrumental variables. } \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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \code{\link{model_get_response_variable}()}, \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_weights.Rd0000644000176200001440000000501514662130321017563 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.svrepglm} \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}{svrepglm}(model) \method{model_get_weights}{model_fit}(model) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr A model object.} } \description{ This function does not cover \code{lavaan} models (\code{NULL} is returned). } \note{ For class \code{svrepglm} objects (GLM on a survey object with replicate weights), it will return the original sampling weights of the data, not the replicate weights. } \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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \code{\link{model_get_response_variable}()}, \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_plus_plus.Rd0000644000176200001440000002273614762101342017164 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, model_matrix_attr = TRUE, variable_labels = NULL, instrumental_suffix = " (instrumental)", 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(), group_by = auto_group_by(), group_labels = NULL, keep_model = FALSE, tidy_post_fun = NULL, quiet = FALSE, strict = FALSE, ... ) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr A model to be attached/tidied.} \item{tidy_fun}{(\code{function})\cr Option to specify a custom tidier function.} \item{conf.int}{(\code{logical})\cr Should confidence intervals be computed? (see \code{\link[broom:reexports]{broom::tidy()}})} \item{conf.level}{(\code{numeric})\cr Level of confidence for confidence intervals (default: 95\%).} \item{exponentiate}{(\code{logical})\cr 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{model_matrix_attr}{(\code{logical})\cr Whether model frame and model matrix should be added as attributes of \code{model} (respectively named \code{"model_frame"} and \code{"model_matrix"}) and passed through.} \item{variable_labels}{(\code{\link[gtsummary:syntax]{formula-list-selector}})\cr A named list or a named vector of custom variable labels.} \item{instrumental_suffix}{(\code{string})\cr Suffix added to variable labels for instrumental variables (\code{fixest} models). \code{NULL} to add nothing.} \item{term_labels}{(\code{list} or \code{vector})\cr A named list or a named vector of custom term labels.} \item{interaction_sep}{(\code{string})\cr Separator for interaction terms.} \item{categorical_terms_pattern}{(\code{\link[glue:glue]{glue pattern}})\cr 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}{(\code{logical})\cr Should terms be disambiguated with \code{\link[=tidy_disambiguate_terms]{tidy_disambiguate_terms()}}? (default \code{TRUE})} \item{disambiguate_sep}{(\code{string})\cr Separator for \code{\link[=tidy_disambiguate_terms]{tidy_disambiguate_terms()}}.} \item{add_reference_rows}{(\code{logical})\cr Should reference rows be added?} \item{no_reference_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables for those no reference row should be added, when \code{add_reference_rows = TRUE}.} \item{add_pairwise_contrasts}{(\code{logical})\cr Apply \code{\link[=tidy_add_pairwise_contrasts]{tidy_add_pairwise_contrasts()}}?} \item{pairwise_variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables to add pairwise contrasts.} \item{keep_model_terms}{(\code{logical})\cr Keep original model terms for variables where pairwise contrasts are added? (default is \code{FALSE})} \item{pairwise_reverse}{(\code{logical})\cr 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}{(\code{string})\cr Optional adjustment method when computing contrasts, see \code{\link[emmeans:contrast]{emmeans::contrast()}} (if \code{NULL}, use \code{emmeans} default).} \item{emmeans_args}{(\code{list})\cr List of additional parameter to pass to \code{\link[emmeans:emmeans]{emmeans::emmeans()}} when computing pairwise contrasts.} \item{add_estimate_to_reference_rows}{(\code{logical})\cr Should an estimate value be added to reference rows?} \item{add_header_rows}{(\code{logical})\cr Should header rows be added?} \item{show_single_row}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables that should be displayed on a single row, when \code{add_header_rows} is \code{TRUE}.} \item{add_n}{(\code{logical})\cr Should the number of observations be added?} \item{intercept}{(\code{logical})\cr Should the intercept(s) be included?} \item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Variables to include. 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{group_by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr One or several variables to group by. Default is \code{auto_group_by()}. Use \code{NULL} to force ungrouping.} \item{group_labels}{(\code{string})\cr An optional named vector of custom term labels.} \item{keep_model}{(\code{logical})\cr Should the model be kept as an attribute of the final result?} \item{tidy_post_fun}{(\code{function})\cr Custom function applied to the results at the end of \code{tidy_plus_plus()} (see note)} \item{quiet}{(\code{logical})\cr Whether \code{broom.helpers} should not return a message when requested output cannot be generated. Default is \code{FALSE}.} \item{strict}{(\code{logical})\cr Whether \code{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_group_by]{tidy_group_by()}} \item \code{\link[=tidy_add_coefficients_type]{tidy_add_coefficients_type()}} \item \code{\link[=tidy_detach_model]{tidy_detach_model()}} } } \note{ \code{tidy_post_fun} is applied to the result at the end of \code{tidy_plus_plus()} and receive only one argument (the result of \code{tidy_plus_plus()}). However, if needed, the model is still attached to the tibble as an attribute, even if \code{keep_model = FALSE}. Therefore, it is possible to use \code{\link[=tidy_get_model]{tidy_get_model()}} within \code{tidy_fun} if, for any reason, you need to access the source model. } \examples{ \donttest{ 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 } \dontshow{if (require("gtsummary") && require("emmeans")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_group_by}()}, \code{\link{tidy_identify_variables}()}, \code{\link{tidy_remove_intercept}()}, \code{\link{tidy_select_variables}()} } \concept{tidy_helpers} broom.helpers/man/model_get_model_matrix.Rd0000644000176200001440000000704214760117574020615 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} \alias{model_get_model_matrix.cch} \alias{model_get_model_matrix.vglm} \alias{model_get_model_matrix.vgam} \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, ...) \method{model_get_model_matrix}{cch}(model, ...) \method{model_get_model_matrix}{vglm}(model, ...) \method{model_get_model_matrix}{vgam}(model, ...) } \arguments{ \item{model}{(a model object, e.g. \code{glm})\cr 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. For \code{fixest} models, will recreate a model matrix with both main variables and instrumental variables. For more options, see \link[fixest:model.matrix.fixest]{fixest::model.matrix.fixest}. } \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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_n}()}, \code{\link{model_get_nlevels}()}, \code{\link{model_get_offset}()}, \code{\link{model_get_pairwise_contrasts}()}, \code{\link{model_get_response}()}, \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/tidy_vgam.Rd0000644000176200001440000000372314762101120016055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_tidiers.R \name{tidy_vgam} \alias{tidy_vgam} \title{Tidy a \code{vglm} or a \code{vgam} model} \usage{ tidy_vgam(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{(\code{vglm} or \code{vgam})\cr A \code{VGAM::vglm()} or a \code{VGAM::vgam()} model.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \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{VGAM::vglm()} or \code{VGAM::vgam()}. Term names will be updated to be consistent with generic models. The original term names are preserved in an \code{"original_term"} column. Depending on the model, additional column \code{"group"}, \code{"component"} and/or \code{"y.level"} may be added to the results. } \examples{ \dontshow{if (.assert_package("VGAM", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ library(VGAM) mod <- vglm( Species ~ Sepal.Length + Sepal.Width, family = multinomial(), data = iris ) mod |> tidy_vgam(exponentiate = TRUE) mod <- vglm( Species ~ Sepal.Length + Sepal.Width, family = multinomial(parallel = TRUE), data = iris ) mod |> tidy_vgam(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}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/tidy_zeroinfl.Rd0000644000176200001440000000323714762101120016753 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}{(\code{zeroinfl} or \code{hurdle})\cr A \code{pscl::zeroinfl()} or a \code{pscl::hurdle()} model.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{component}{(\code{string})\cr \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{ 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 (.assert_package("pscl", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_vgam}()}, \code{\link{tidy_with_broom_or_parameters}()} } \concept{custom_tieders} broom.helpers/man/tidy_marginal_predictions.Rd0000644000176200001440000001605514762076566021353 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{variables_list}{(\code{list} or \code{string})\cr 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}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{marginaleffects::avg_predictions()}.} \item{model}{(a model object, e.g. \code{glm})\cr A model.} \item{interactions}{(\code{logical})\cr Should combinations of variables corresponding to interactions be returned?} \item{categorical}{(\code{\link[marginaleffects:predictions]{predictor values}})\cr Default values for categorical variables.} \item{continuous}{(\code{\link[marginaleffects:predictions]{predictor values}})\cr Default values for continuous variables.} } \description{ 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 (.assert_package("marginaleffects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # example code \donttest{ # 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_margins}()} } \concept{marginal_tieders} broom.helpers/man/tidy_ggpredict.Rd0000644000176200001440000000427014762101120017071 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{ggeffects::ggpredict()}.} } \description{ 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 (.assert_package("ggeffects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/scope_tidy.Rd0000644000176200001440000000347114760074354016254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/scope_tidy.R \name{scope_tidy} \alias{scope_tidy} \title{Scoping a tidy tibble allowing to tidy select} \usage{ scope_tidy(x, data = NULL) } \arguments{ \item{x}{(\code{data.frame})\cr A tidy tibble, with a \code{"variable"} column, as returned by \code{\link[=tidy_identify_variables]{tidy_identify_variables()}}.} \item{data}{(\code{data.frame})\cr An optional data frame the attributes will be added to.} } \value{ A data frame. } \description{ This function uses the information from a model tidy tibble to generate a data frame exposing the different variables of the model, data frame that could be used for tidy selection. In addition, columns \code{"var_type"}, \code{"var_class"} and \code{"contrasts_type"} are scoped and their values are added as attributes to the data frame. For example, if \code{var_type='continuous'} for variable \code{"age"}, then the attribute \code{attr(.$age, 'gtsummary.var_type') <- 'continuous'} is set. That attribute is then used in a selector like \code{all_continuous()}. Note: attributes are prefixed with \code{"gtsummary."} to be compatible with selectors provided by \code{{gtsummary}}. } \examples{ mod <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) tt <- mod |> tidy_and_attach() |> tidy_add_contrasts() scope_tidy(tt) |> str() scope_tidy(tt, data = model_get_model_frame(mod)) |> str() scope_tidy(tt) |> dplyr::select(dplyr::starts_with("Se")) |> names() scope_tidy(tt) |> dplyr::select(where(is.factor)) |> names() scope_tidy(tt) |> dplyr::select(all_continuous()) |> names() scope_tidy(tt) |> dplyr::select(all_contrasts()) |> names() scope_tidy(tt) |> dplyr::select(all_interaction()) |> names() scope_tidy(tt) |> dplyr::select(all_intercepts()) |> names() } broom.helpers/man/tidy_avg_comparisons.Rd0000644000176200001440000000551514762101120020316 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters passed to \code{marginaleffects::avg_comparisons()}.} } \description{ 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 (.assert_package("marginaleffects", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ # 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_predictions}()}, \code{\link{tidy_margins}()} } \concept{marginal_tieders} broom.helpers/man/select_helpers.Rd0000644000176200001440000000544514762101120017076 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_categorical} \alias{all_dichotomous} \alias{all_interaction} \alias{all_ran_pars} \alias{all_ran_vals} \alias{all_intercepts} \alias{all_contrasts} \title{Select helper functions} \usage{ all_continuous(continuous2 = TRUE) all_categorical(dichotomous = TRUE) all_dichotomous() all_interaction() all_ran_pars() all_ran_vals() all_intercepts() all_contrasts( contrasts_type = c("treatment", "sum", "poly", "helmert", "sdif", "other") ) } \arguments{ \item{continuous2}{(\code{logical})\cr Whether to include continuous2 variables, default is \code{TRUE}. For compatibility with \code{{gtsummary}}), see \code{\link[gtsummary:select_helpers]{gtsummary::all_continuous2()}}.} \item{dichotomous}{(\code{logical})\cr Whether to include dichotomous variables, default is \code{TRUE}.} \item{contrasts_type}{(\code{string})\cr 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", "sdif", "other")}.} } \value{ A character vector of column names selected. } \description{ Set of functions to supplement the \emph{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{ \donttest{ glm(response ~ age * trt + grade, gtsummary::trial, family = binomial) |> tidy_plus_plus(exponentiate = TRUE, include = all_categorical()) } \dontshow{if (.assert_package("emmeans", boolean = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} \donttest{ 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} } \seealso{ \code{\link[=scope_tidy]{scope_tidy()}} } broom.helpers/man/tidy_with_broom_or_parameters.Rd0000644000176200001440000000217714760117574022243 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 object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \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_vgam}()}, \code{\link{tidy_zeroinfl}()} } \concept{custom_tieders} broom.helpers/man/tidy_marginal_means.Rd0000644000176200001440000000205514746125043020111 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 deprecated \code{marginaleffects::marginal_means()}} \usage{ tidy_marginal_means(x, conf.int = TRUE, conf.level = 0.95, ...) } \arguments{ \item{x}{(a model object, e.g. \code{glm})\cr A model to be tidied.} \item{conf.int}{(\code{logical})\cr Whether or not to include a confidence interval in the tidied output.} \item{conf.level}{(\code{numeric})\cr The confidence level to use for the confidence interval (between \code{0} ans \code{1}).} \item{...}{Additional parameters.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} This function is deprecated. \code{marginal_means()} is not anymore exported by \code{marginaleffects}. Use instead \code{tidy_marginal_predictions()} with the option \code{newdata = "balanced"}. } broom.helpers/man/model_get_nlevels.Rd0000644000176200001440000000300014662130321017551 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, e.g. \code{glm})\cr 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}()}, \code{\link{model_get_model_frame}()}, \code{\link{model_get_model_matrix}()}, \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_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/seq_range.Rd0000644000176200001440000000124314662130321016035 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}{(\code{numeric})\cr A numeric vector.} \item{length.out}{(\code{integer})\cr Desired length of the sequence (a positive integer).} } \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/DESCRIPTION0000644000176200001440000000404414762300062014541 0ustar liggesusersPackage: broom.helpers Title: Helpers for Model Coefficients Tibbles Version: 1.20.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/, https://github.com/larmarange/broom.helpers BugReports: https://github.com/larmarange/broom.helpers/issues Depends: R (>= 4.1) Imports: broom (>= 0.8), cards, cli, dplyr (>= 1.1.0), labelled, lifecycle, purrr, rlang (>= 1.0.1), stats, stringr, tibble, tidyr, tidyselect Suggests: betareg, biglm, brms (>= 2.13.0), broom.mixed, cmprsk, covr, datasets, effects, emmeans, fixest (>= 0.10.0), forcats, gam, gee, geepack, ggplot2, ggeffects (>= 1.3.2), ggstats (>= 0.2.1), glmmTMB, glmtoolbox, glue, gt, gtsummary (>= 2.0.0), knitr, lavaan, lfe, lme4 (>= 1.1.28), logitr (>= 0.8.0), marginaleffects (>= 0.21.0), margins, MASS, mgcv, mice, mmrm (>= 0.3.6), multgee, nnet, ordinal, parameters, parsnip, patchwork, plm, pscl, rmarkdown, rstanarm, scales, spelling, survey, survival, testthat (>= 3.0.0), tidycmprsk, VGAM VignetteBuilder: knitr RdMacros: lifecycle Encoding: UTF-8 Language: en-US LazyData: true RoxygenNote: 7.3.2 Config/testthat/edition: 3 NeedsCompilation: no Packaged: 2025-03-06 10:17:03 UTC; josep Author: Joseph Larmarange [aut, cre] (), Daniel D. Sjoberg [aut] () Maintainer: Joseph Larmarange Repository: CRAN Date/Publication: 2025-03-06 11:00:02 UTC