R/tidy_and_attach.R

In larmarange/broom.helpers: Helpers for Model Coefficients Tibbles

#' 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
}