R/bcat_fmt_style_table.R

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

#' UC table formatting
#'
#' Format tables for output to final documentation. Automatically detects
#' output format (HTML, PDF, Word, PPTX) and applies UC styling.
#'
#' @param df Data frame to format.
#' @param caption Character. Table caption.
#' @param footer Character. Table footnote.
#' @param header Character. Spanning header text above all columns.
#' @param header_bg_color Background fill color for header. Default is UC Red.
#' @param header_txt_color Text color for header. Default is white.
#' @param align Character vector of column alignments: 'l' (left), 'c' (center), 'r' (right).
#' @param font_size Numeric. Font size for table. Default is 12.
#' @param striped Logical. Enable zebra striping? Default is TRUE.
#' @param full_width Logical. Should HTML table be full width? Default is FALSE.
#' @param scale_down Logical. Scale LaTeX table to fit page? Default is FALSE.
#' @param longtable Logical. Use longtable for multi-page PDF tables? Default is FALSE.
#' @param col_names Character vector of column names. Set to NULL to remove header row.
#' @param threeparttable Logical. Use LaTeX threeparttable for footnotes? Default is FALSE.
#' @param doc_type Manually set document type. Auto-detected if not specified.
#' @param ... Additional arguments passed to \code{knitr::kable}.
#' @return A formatted table object (kableExtra for HTML/PDF, flextable for Word/PPTX).
#' @author Saannidhya Rawat
#' @family tables
#' @export
#'
#' @examples
#' bcat_fmt_style_table(iris[1:10, ])
#' bcat_fmt_style_table(iris[1:5, ], caption = "Iris Sample", striped = TRUE)
bcat_fmt_style_table <- function(df,
                                 caption = NULL,
                                 footer = NULL,
                                 header = NULL,
                                 header_bg_color = palette_UC[["UC Red"]],
                                 header_txt_color = palette_UC[["White"]],
                                 align,
                                 font_size = 12,
                                 striped = TRUE,
                                 full_width = FALSE,
                                 scale_down = FALSE,
                                 longtable = FALSE,
                                 col_names = NA,
                                 threeparttable = FALSE,
                                 doc_type = c(knitr::opts_knit$get('rmarkdown.pandoc.to'),
                                              "html",
                                              "pdf",
                                              "docx",
                                              "pptx"),
                                 ...) {

  doc_type <- match.arg(doc_type)

  # Build spanning header if provided
  myHeader <- NULL
  if (!is.null(header)) {
    myHeader <- stats::setNames(ncol(df), header)
  }

  if (doc_type %in% c("html") || knitr::is_html_output()) {
    .style_table_html(df, caption, footer, myHeader, col_names,
                      header_bg_color, header_txt_color,
                      align, font_size, striped, full_width, ...)
  } else if (doc_type %in% c("pdf") || knitr::is_latex_output()) {
    .style_table_latex(df, caption, footer, myHeader, col_names,
                       header_bg_color, header_txt_color,
                       align, font_size, striped, scale_down,
                       longtable, threeparttable, ...)
  } else if (doc_type %in% c("docx", "pptx")) {
    .style_table_word(df, header_bg_color, header_txt_color,
                      font_size, striped, caption, footer)
  }
}

# -- Internal format helpers --------------------------------------------------

#' @noRd
.style_table_html <- function(df, caption, footer, myHeader, col_names,
                               header_bg_color, header_txt_color,
                               align, font_size, striped, full_width, ...) {
  bootstrap_opts <- c("hover", "condensed")
  if (striped) bootstrap_opts <- c(bootstrap_opts, "striped")

  tbl <- knitr::kable(df, format = "html", caption = caption,
                       align = align, col.names = col_names, ...) %>%
    kableExtra::kable_styling(full_width = full_width,
                              font_size = font_size,
                              bootstrap_options = bootstrap_opts)

  # Apply header styling
  if (!is.null(col_names) && is.null(myHeader)) {
    tbl <- kableExtra::row_spec(tbl, 0, bold = TRUE,
                                background = header_bg_color,
                                color = header_txt_color)
  } else if (!is.null(myHeader)) {
    tbl <- kableExtra::add_header_above(tbl, header = myHeader,
                                        background = header_bg_color,
                                        color = header_txt_color)
  }

  # Apply footnote
  if (!is.null(footer)) {
    tbl <- kableExtra::footnote(tbl, footer, footnote_as_chunk = TRUE)
  }

  tbl
}

#' @noRd
.style_table_latex <- function(df, caption, footer, myHeader, col_names,
                                header_bg_color, header_txt_color,
                                align, font_size, striped, scale_down,
                                longtable, threeparttable, ...) {
  latex_opts <- c("HOLD_position", "repeat_header")
  if (scale_down) latex_opts <- c(latex_opts, "scale_down")
  if (striped) latex_opts <- c(latex_opts, "striped")

  tbl <- knitr::kable(df, format = "latex", align = align, caption = caption,
                       booktabs = TRUE, longtable = longtable,
                       col.names = col_names, ...) %>%
    kableExtra::kable_styling(latex_options = latex_opts, font_size = font_size)

  if (!is.null(col_names) && is.null(myHeader)) {
    tbl <- kableExtra::row_spec(tbl, 0, bold = TRUE,
                                background = header_bg_color,
                                color = header_txt_color)
  } else if (!is.null(myHeader)) {
    tbl <- kableExtra::add_header_above(tbl, header = myHeader,
                                        background = header_bg_color,
                                        color = header_txt_color)
  }

  if (!is.null(footer)) {
    tbl <- kableExtra::footnote(tbl, footer, footnote_as_chunk = TRUE,
                                threeparttable = threeparttable)
  }

  tbl
}

#' @noRd
.style_table_word <- function(df, header_bg_color, header_txt_color,
                               font_size, striped, caption, footer) {
  tbl <- flextable::flextable(df) %>%
    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::align(align = "center", part = "header") %>%
    flextable::border_remove() %>%
    flextable::hline_top(part = "header") %>%
    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
}