#' 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
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.