R/add_header_above.R

#' Add a header row on top of current header
#'
#' @description Tables with multiple rows of header rows are extremely useful
#' to demonstrate grouped data. This function takes the output of a `kable()`
#' function and adds an header row on top of it.
#'
#' @param kable_input Output of `knitr::kable()` with `format` specified
#' @param header A (named) character vector with `colspan` as values. For
#' example, `c(" " = 1, "title" = 2)` can be used to create a new header row
#' for a 3-column table with "title" spanning across column 2 and 3. For
#' convenience, when `colspan` equals to 1, users can drop the ` = 1` part.
#' As a result, `c(" ", "title" = 2)` is the same as `c(" " = 1, "title" = 2)`.
#' @param bold A T/F value to control whether the text should be bolded.
#' @param italic A T/F value to control whether the text should to be emphasized.
#' @param monospace A T/F value to control whether the text of the selected column
#' need to be monospaced (verbatim)
#' @param align A character string for cell alignment. For HTML, possible values could
#' be `l`, `c`, `r` plus `left`, `center`, `right`, `justify`, `initial` and `inherit`
#' while for LaTeX, you can only choose from `l`, `c` & `r`.
#' @param escape A T/F value showing whether special characters should be
#' escaped.
#' @param line A T/F value to control whether a line will appear underneath the
#' header
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' # Add a row of header with 3 columns on the top of the table. The column
#' # span for the 2nd and 3rd one are 5 & 6.
#' add_header_above(x, c(" ", "Group 1" = 5, "Group 2" = 6))
#'
#' @export
add_header_above <- function(kable_input, header = NULL,
                             bold = FALSE, italic = FALSE,
                             monospace = FALSE, align = "c",
                             escape = TRUE, line = TRUE) {
  kable_format <- attr(kable_input, "format")
  if (!kable_format %in% c("html", "latex")) {
    warning("Please specify format in kable. kableExtra can customize either ",
         "HTML or LaTeX outputs. See https://haozhu233.github.io/kableExtra/ ",
         "for details.")
    return(kable_input)
  }
  if (kable_format == "html") {
    return(htmlTable_add_header_above(kable_input, header, bold, italic,
                                      monospace, align, escape,line))
  }
  if (kable_format == "latex") {
    return(pdfTable_add_header_above(kable_input, header, bold, italic,
                                     monospace, align, escape,line))
  }
}

# HTML
htmlTable_add_header_above <- function(kable_input, header, bold, italic,
                                       monospace, align, escape, line) {
  if (is.null(header)) return(kable_input)
  kable_attrs <- attributes(kable_input)
  kable_xml <- read_kable_as_xml(kable_input)
  kable_xml_thead <- xml_tpart(kable_xml, "thead")

  header <- standardize_header_input(header)

  if (escape) {
    header$header <- escape_html(header$header)
  }

  header_rows <- xml_children(kable_xml_thead)
  bottom_header_row <- header_rows[[length(header_rows)]]
  kable_ncol <- length(xml_children(bottom_header_row))
  if (sum(header$colspan) != kable_ncol) {
    stop("The new header row you provided has a different total number of ",
         "columns with the original kable output.")
  }

  new_header_row <- htmlTable_new_header_generator(header, bold, italic,
                                                   monospace,align, line)
  xml_add_child(kable_xml_thead, new_header_row, .where = 0)
  out <- as_kable_xml(kable_xml)
  if (is.null(kable_attrs$header_above)) {
    kable_attrs$header_above <- 1
  } else {
    kable_attrs$header_above <- kable_attrs$header_above + 1
  }
  attributes(out) <- kable_attrs
  if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
  return(out)
}

standardize_header_input <- function(header) {
  header_names <- names(header)

  if (is.null(header_names)) {
    return(data.frame(header = header, colspan = 1, row.names = NULL))
  }

  names(header)[header_names == ""] <- header[header_names == ""]
  header[header_names == ""] <- 1
  header_names <- names(header)
  header <- as.numeric(header)
  names(header) <- header_names
  return(data.frame(header = names(header), colspan = header, row.names = NULL))
}

htmlTable_new_header_generator <- function(header_df, bold, italic,
                                           monospace, align, line) {
  if (align %in% c("l", "c", "r")) {
    align <- switch(align, r = "right", c = "center", l = "left")
  }
  row_style <- paste0(
    paste0("text-align: ", align, "; "),
    ifelse(bold, "font-weight: bold; ", ""),
    ifelse(italic, "font-style: italic; ", ""),
    ifelse(monospace, "font-family: monospace; ", "")
  )
  header_items <- apply(header_df, 1, function(x) {
    if (trimws(x[1]) == "") {
      paste0('<th style="border-bottom:hidden" colspan="', x[2], '"></th>')
    } else {
      paste0('<th style="border-bottom:hidden; ',
             'padding-bottom:0; padding-left:3px;padding-right:3px;',
             row_style,
             '" colspan="',
             x[2], '"><div style="',
             ifelse(line,'border-bottom: 1px solid #ddd; padding-bottom: 5px;">','">'),
             x[1], '</div></th>')
    }
  })
  header_text <- paste(c("<tr>", header_items, "</tr>"), collapse = "")
  header_xml <- read_xml(header_text, options = c("COMPACT"))
  return(header_xml)
}

# Add an extra header row above the current header in a LaTeX table ------
pdfTable_add_header_above <- function(kable_input, header, bold, italic,
                                      monospace, align, escape, line) {
  table_info <- magic_mirror(kable_input)
  header <- standardize_header_input(header)

  if (escape) {
    header$header <- escape_latex2(header$header)
    header$header <- linebreak(header$header, align = align, double_escape = TRUE)
  }

  align <- match.arg(align, c("c", "l", "r"))

  hline_type <- switch(table_info$booktabs + 1, "\\\\hline", "\\\\toprule")
  new_header_split <- pdfTable_new_header_generator(
    header, table_info$booktabs, bold, italic, monospace, align)
  if(line){
    new_header <- paste0(new_header_split[1], "\n", new_header_split[2])
  } else {
    new_header <- new_header_split[1]
  }
  out <- str_replace(solve_enc(kable_input),
                     hline_type,
                     paste0(hline_type, "\n", new_header))
  out <- structure(out, format = "latex", class = "knitr_kable")
  # new_header_row <- latex_contents_escape(new_header_split[1])
  if (is.null(table_info$new_header_row)) {
    table_info$new_header_row <- new_header_split[1]
    table_info$header_df <- list(header)
  } else {
    table_info$new_header_row <- c(table_info$new_header_row, new_header_split[1])
    table_info$header_df[[length(table_info$header_df) + 1]] <- header
  }
  attr(out, "kable_meta") <- table_info
  return(out)
}

pdfTable_new_header_generator <- function(header_df, booktabs = FALSE,
                                          bold, italic, monospace, align) {
  if (booktabs) {
    header_df$align <- align
  } else {
    header_df$align <- paste0("|", align, "|")
    header_df$align[1] <- paste0(align, "|")
    header_df$align[nrow(header_df)] <- paste0("|", align)
  }
  header_items <- apply(header_df, 1, function(x) {
    # if(x[2] == 1) return(x[1])
    paste0('\\\\multicolumn{', x[2], '}{', x[3], '}{',
           ifelse(bold, "\\\\bfseries ", ""),
           ifelse(italic, "\\\\em ", ""),
           ifelse(monospace, "\\\\ttfamily ", ""),
           x[1],
           "}")
  })
  header_text <- paste(paste(header_items, collapse = " & "), "\\\\\\\\")
  cline <- cline_gen(header_df, booktabs)
  return(c(header_text, cline))
}

cline_gen <- function(header_df, booktabs) {
  cline_end <- cumsum(header_df$colspan)
  cline_start <- c(0, cline_end) + 1
  cline_start <- cline_start[-length(cline_start)]
  cline_type <- switch(booktabs + 1,
                       "\\\\cline{",
                       "\\\\cmidrule(l{2pt}r{2pt}){")
  cline <- paste0(cline_type, cline_start, "-", cline_end, "}")
  cline <- cline[trimws(header_df$header) != ""]
  cline <- paste(cline, collapse = " ")
  return(cline)
}