R/bcat_cor_table.R

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

#' UC-branded correlation matrix
#'
#' Produce a formatted correlation matrix with significance stars and UC styling.
#' By default shows only the lower triangle.
#'
#' @param df A data frame of numeric columns.
#' @param method Character. Correlation method: \code{"pearson"} (default),
#'   \code{"spearman"}, or \code{"kendall"}.
#' @param full_matrix Logical. Show full matrix? Default is FALSE (lower triangle only).
#' @param digits Integer. Decimal places. Default is 2.
#' @param stars Logical. Show significance stars? Default is TRUE.
#' @param p_threshold Numeric vector of p-value thresholds for stars.
#'   Default: \code{c(0.01, 0.05, 0.1)}.
#' @param caption Character. Table caption.
#' @param font_size Numeric. Font size. Default is 12.
#' @param header_bg_color Background color for header.
#' @param header_txt_color Text color for header.
#' @param striped Logical. Zebra striping?
#' @param doc_type Character. Force output format. Auto-detected if NULL.
#' @param ... Additional arguments passed to table formatting.
#' @return A formatted table object.
#' @author Saannidhya Rawat
#' @family tables
#' @export
#'
#' @examples
#' bcat_cor_table(mtcars[, c("mpg", "wt", "hp", "disp")])
#' bcat_cor_table(mtcars[, c("mpg", "wt", "hp")], method = "spearman")
bcat_cor_table <- function(df,
                           method = c("pearson", "spearman", "kendall"),
                           full_matrix = FALSE,
                           digits = 2,
                           stars = TRUE,
                           p_threshold = c(0.01, 0.05, 0.1),
                           caption = NULL,
                           font_size = 12,
                           header_bg_color = palette_UC[["UC Red"]],
                           header_txt_color = palette_UC[["White"]],
                           striped = TRUE,
                           doc_type = NULL,
                           ...) {

  .validate_df(df)
  method <- match.arg(method)

  num_df <- df[, vapply(df, is.numeric, logical(1)), drop = FALSE]
  if (ncol(num_df) < 2L) {
    stop("Need at least 2 numeric columns for correlation matrix.", call. = FALSE)
  }

  n <- ncol(num_df)
  cor_mat <- stats::cor(num_df, method = method, use = "pairwise.complete.obs")

  # Compute p-values
  p_mat <- matrix(NA_real_, n, n)
  for (i in seq_len(n)) {
    for (j in seq_len(n)) {
      if (i != j) {
        test <- stats::cor.test(num_df[[i]], num_df[[j]], method = method)
        p_mat[i, j] <- test$p.value
      }
    }
  }

  # Format with optional stars
  fmt_mat <- matrix("", n, n)
  for (i in seq_len(n)) {
    for (j in seq_len(n)) {
      if (i == j) {
        fmt_mat[i, j] <- "1"
      } else {
        val <- formatC(cor_mat[i, j], digits = digits, format = "f")
        if (stars && !is.na(p_mat[i, j])) {
          p <- p_mat[i, j]
          star_str <- if (p < p_threshold[1]) "***"
                      else if (p < p_threshold[2]) "**"
                      else if (p < p_threshold[3]) "*"
                      else ""
          val <- paste0(val, star_str)
        }
        fmt_mat[i, j] <- val
      }
    }
  }

  # Lower triangle only
  if (!full_matrix) {
    for (i in seq_len(n)) {
      for (j in seq_len(n)) {
        if (j > i) fmt_mat[i, j] <- ""
      }
    }
  }

  result_df <- as.data.frame(fmt_mat, stringsAsFactors = FALSE)
  names(result_df) <- names(num_df)
  result_df <- cbind(Variable = names(num_df), result_df)

  star_footer <- if (stars) {
    paste0("* p<", p_threshold[3],
           "  ** p<", p_threshold[2],
           "  *** p<", p_threshold[1])
  } else {
    NULL
  }

  effective_doc_type <- doc_type
  if (is.null(effective_doc_type)) {
    effective_doc_type <- knitr::opts_knit$get('rmarkdown.pandoc.to')
  }
  if (is.null(effective_doc_type)) effective_doc_type <- "html"

  bcat_fmt_style_table(result_df,
                       caption = caption,
                       footer = star_footer,
                       font_size = font_size,
                       header_bg_color = header_bg_color,
                       header_txt_color = header_txt_color,
                       striped = striped,
                       doc_type = effective_doc_type,
                       ...)
}