Nothing
#' Attach a full model to the tibble of model terms
#'
#' To facilitate the use of broom helpers with pipe, it is recommended to
#' attach the original model as an attribute to the tibble of model terms
#' generated by `broom::tidy()`.
#'
#' `tidy_attach_model()` attach the model to a tibble already generated while
#' `tidy_and_attach()` will apply `broom::tidy()` and attach the model.
#'
#' Use `tidy_get_model()` to get the model attached to the tibble and
#' `tidy_detach_model()` to remove the attribute containing the model.
#' @param model a model to be attached/tidied
#' @param x a tibble of model terms
#' @param tidy_fun option to specify a custom tidier function
#' @param conf.int logical indicating whether or not to include a confidence
#' interval in the tidied output
#' @param conf.level level of confidence for confidence intervals (default: 95%)
#' @param exponentiate logical indicating whether or not to exponentiate the
#' coefficient estimates. This is typical for logistic, Poisson and Cox models,
#' but a bad idea if there is no log or logit link; defaults to `FALSE`
#' @param .attributes named list of additional attributes to be attached to `x`
#' @param ... other arguments passed to `tidy_fun()`
#' @family tidy_helpers
#' @examples
#' mod <- lm(Sepal.Length ~ Sepal.Width + Species, data = iris)
#' tt <- mod %>%
#' tidy_and_attach(conf.int = TRUE)
#' tt
#' tidy_get_model(tt)
#' @export
tidy_attach_model <- function(x, model, .attributes = NULL) {
x <- x %>%
dplyr::as_tibble() %>%
.order_tidy_columns()
class(x) <- c("broom.helpers", class(x))
model <- model_get_model(model)
# if force_contr.treatment
if (isTRUE(attr(x, "force_contr.treatment"))) {
for (v in names(model$contrasts)) {
model$contrasts[[v]] <- "contr.treatment"
}
}
attr(x, "model") <- model
for (a in names(.attributes)) {
if (!is.null(.attributes[[a]])) {
attr(x, a) <- .attributes[[a]]
}
}
x
}
#' @rdname tidy_attach_model
#' @export
tidy_and_attach <- function(
model, tidy_fun = tidy_with_broom_or_parameters,
conf.int = TRUE, conf.level = .95, exponentiate = FALSE, ...) {
# exponentiate cannot be used with lm models
# but broom will not produce an error and will return unexponentiated estimates
if (identical(class(model), "lm") && exponentiate) {
cli::cli_abort("{.code exponentiate = TRUE} is not valid for this type of model.")
}
tidy_args <- list(...)
tidy_args$x <- model
tidy_args$conf.int <- conf.int
if (conf.int) tidy_args$conf.level <- conf.level
tidy_args$exponentiate <- exponentiate
# test if exponentiate can be passed to tidy_fun, and if tidy_fun runs without error
result <-
tryCatch(
do.call(tidy_fun, tidy_args) %>%
tidy_attach_model(
model,
.attributes = list(
exponentiate = exponentiate,
conf.level = conf.level
)
),
error = function(e) {
# `tidy_fun()` fails for two primary reasons:
# 1. `tidy_fun()` does not accept the `exponentiate=` arg
# - in this case, we re-run `tidy_fun()` without the `exponentiate=` argument
# 2. Incorrect input or incorrect custom `tidy_fun()` passed
# - in this case, we print a message explaining the likely source of error
# first attempting to run without `exponentiate=` argument
tryCatch(
{
tidy_args$exponentiate <- NULL
xx <-
do.call(tidy_fun, tidy_args) %>%
tidy_attach_model(
model,
.attributes = list(exponentiate = FALSE, conf.level = conf.level)
)
if (exponentiate) {
cli::cli_alert_warning(
"`exponentiate = TRUE` is not valid for this type of model and was ignored."
)
}
xx
},
error = function(e) {
# if error persists, then there is a problem with either model input or `tidy_fun=`
paste0(
"There was an error calling {.code tidy_fun()}. ",
"Most likely, this is because the function supplied in {.code tidy_fun=} ",
"was misspelled, does not exist, is not compatible with your object, ",
"or was missing necessary arguments (e.g. {.code conf.level=} ",
"or {.code conf.int=}). See error message below."
) %>%
stringr::str_wrap() %>%
cli_alert_danger()
cli::cli_abort(as.character(e), call = NULL)
}
)
}
)
# return result
result
}
#' @rdname tidy_attach_model
#' @export
tidy_get_model <- function(x) {
attr(x, "model")
}
#' @rdname tidy_attach_model
#' @export
tidy_detach_model <- function(x) {
attr(x, "model") <- NULL
x
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.