R/bcat_reg_table.R

In Rbearcat: University of Cincinnati Themes and Utilities for Econometrics and Data Science

#' UC-branded regression table
#'
#' Produce publication-quality regression tables with UC styling.
#' Wraps \code{modelsummary::modelsummary()} with UC defaults for
#' formatting, colors, and statistical conventions.
#'
#' @param models A model object, or a list of model objects. Supports \code{lm},
#'   \code{glm}, \code{fixest::feols}, \code{plm}, \code{ivreg}, and any model
#'   supported by \code{broom::tidy()}.
#' @param stars Named numeric vector for significance stars. Set to \code{FALSE}
#'   to suppress stars. Default: \code{c("*" = 0.1, "**" = 0.05, "***" = 0.01)}.
#' @param se_type Character. Standard error type passed to \code{modelsummary}'s
#'   \code{vcov} argument. Options: \code{"default"}, \code{"HC1"}, \code{"HC3"},
#'   or a function/named list. Default is \code{"default"}.
#' @param coef_rename Named character vector to rename coefficients.
#'   If \code{NULL} (default), coefficients are auto-cleaned to Title Case.
#' @param gof_map Character vector of goodness-of-fit statistics to include.
#'   Default: \code{c("nobs", "r.squared", "adj.r.squared", "statistic")}.
#' @param caption Character. Table caption.
#' @param footer Character. Table footnote.
#' @param font_size Numeric. Font size. Default is 12.
#' @param header_bg_color Background color for header. Default is UC Red.
#' @param header_txt_color Text color for header. Default is white.
#' @param striped Logical. Zebra striping? Default is TRUE.
#' @param doc_type Character. Force output format. Auto-detected if NULL.
#' @param ... Additional arguments passed to \code{modelsummary::modelsummary()}.
#' @return A formatted table object.
#' @author Saannidhya Rawat
#' @family tables
#' @export
#'
#' @examples
#' # Single model
#' m1 <- lm(mpg ~ wt + hp, data = mtcars)
#' bcat_reg_table(m1)
#'
#' # Compare models side-by-side
#' m2 <- lm(mpg ~ wt + hp + cyl, data = mtcars)
#' bcat_reg_table(list("Base" = m1, "Extended" = m2))
bcat_reg_table <- function(models,
                           stars = c("*" = 0.1, "**" = 0.05, "***" = 0.01),
                           se_type = "default",
                           coef_rename = NULL,
                           gof_map = c("nobs", "r.squared", "adj.r.squared",
                                       "statistic"),
                           caption = NULL,
                           footer = NULL,
                           font_size = 12,
                           header_bg_color = palette_UC[["UC Red"]],
                           header_txt_color = palette_UC[["White"]],
                           striped = TRUE,
                           doc_type = NULL,
                           ...) {

  # Wrap single model in list
  if (!is.list(models) || inherits(models, "lm") || inherits(models, "glm")) {
    models <- list(models)
  }
  models <- .normalize_model_list_names(models)

  # Determine output format
  if (is.null(doc_type)) doc_type <- .detect_doc_type()

  output_format <- if (doc_type %in% c("html", "latex", "pdf")) {
    "kableExtra"
  } else {
    "flextable"
  }

  # Auto-clean coefficient names if no rename provided
  if (is.null(coef_rename)) {
    coef_rename <- .auto_clean_coef_names
  }

  # Set vcov
  vcov_arg <- if (identical(se_type, "default")) NULL else se_type

  # Build table via modelsummary
  tbl <- modelsummary::modelsummary(
    models,
    output = output_format,
    stars = stars,
    vcov = vcov_arg,
    coef_rename = coef_rename,
    gof_map = gof_map,
    title = caption,
    ...
  )

  # Apply UC styling
  if (output_format == "kableExtra") {
    if (doc_type %in% c("html")) {
      tbl <- .sanitize_modelsummary_html_headers(tbl)

      bootstrap_opts <- c("hover", "condensed")
      if (striped) bootstrap_opts <- c(bootstrap_opts, "striped")

      tbl <- tbl %>%
        kableExtra::kable_styling(font_size = font_size,
                                  bootstrap_options = bootstrap_opts) %>%
        kableExtra::row_spec(0, bold = TRUE,
                             background = header_bg_color,
                             color = header_txt_color)
    } else {
      latex_opts <- "HOLD_position"
      if (striped) latex_opts <- c(latex_opts, "striped")

      tbl <- tbl %>%
        kableExtra::kable_styling(font_size = font_size,
                                  latex_options = latex_opts) %>%
        kableExtra::row_spec(0, bold = TRUE,
                             background = header_bg_color,
                             color = header_txt_color)
    }

    if (!is.null(footer)) {
      tbl <- kableExtra::footnote(tbl, general = footer,
                                  footnote_as_chunk = TRUE)
    }
  } else {
    tbl <- tbl %>%
      flextable::color(color = header_txt_color, part = "header") %>%
      flextable::bg(bg = header_bg_color, part = "header") %>%
      flextable::font(fontname = .uc_font_family("sans")) %>%
      flextable::fontsize(size = font_size) %>%
      flextable::bold(part = "header") %>%
      flextable::border_remove() %>%
      flextable::hline(part = "all",
                       border = officer::fp_border(color = .uc_border_color())) %>%
      flextable::autofit()

    if (striped) {
      tbl <- flextable::theme_zebra(tbl,
                                    odd_header = header_bg_color,
                                    even_header = header_bg_color,
                                    odd_body = .uc_table_stripe(),
                                    even_body = .uc_color("White"))
    }

    if (!is.null(caption)) {
      tbl <- flextable::set_caption(tbl, caption = caption)
    }

    if (!is.null(footer)) {
      tbl <- flextable::add_footer_lines(tbl, values = footer)
    }
  }

  tbl
}

#' Auto-clean coefficient names from snake_case/code to Title Case
#' @noRd
.auto_clean_coef_names <- function(x) {
  x <- gsub("[_.]", " ", x)
  x <- tools::toTitleCase(x)
  x
}

#' Ensure model lists have stable display names
#' @noRd
.normalize_model_list_names <- function(models) {
  model_names <- names(models)

  if (is.null(model_names)) {
    model_names <- rep("", length(models))
  }

  blank_names <- !nzchar(trimws(model_names))
  if (any(blank_names)) {
    default_names <- paste("Model", seq_along(models))
    model_names[blank_names] <- default_names[blank_names]
    names(models) <- model_names
  }

  models
}

#' Remove escaped non-breaking spaces injected into HTML model headers
#' @noRd
.sanitize_modelsummary_html_headers <- function(tbl) {
  nbsp_tokens <- c("&amp;nbsp;", "&nbsp;", "\u00a0")

  for (token in nbsp_tokens) {
    tbl <- gsub(token, "", tbl, fixed = TRUE)
  }

  backend <- attr(tbl, "backend", exact = TRUE)
  if (!is.null(backend)) {
    backend_names <- names(backend)

    if (!is.null(backend_names)) {
      for (token in nbsp_tokens) {
        backend_names <- gsub(token, "", backend_names, fixed = TRUE)
      }

      names(backend) <- backend_names
      attr(tbl, "backend") <- backend
    }
  }

  tbl
}