R/add_header_left.R

#' Add a heading column to the left side of the table
#'
#' @description This function uses the same syntax as add_header_above. It will
#' add a heading column with grouped rows to the left side of the table. It can
#' act as an alternative way to `group_rows` to show grouped information. As
#' `add_header_above`, users can use this function to add multiple layers of
#' heading columns one by one.
#'
#' @param kable_input Output of `knitr::kable()` with `format` specified
#' @param header A (named) character vector with `rowspan` as values. For
#' example, `c("xxx" = 1, "title" = 2)` can be used to create a new header column
#' for a 3-row table with "xxx" spanning row 1 and "title" spanning row 2 & 3 (
#' two rows). For convenience, when `rowspan` equals to 1, users can drop the
#' ` = 1` part. As a result, `c("xxx", "title" = 2)` is the same as
#' `c("xxx" = 1, "title" = 2)`.
#' @param header_name Column name that that extra column
#' @param width A character string for the width of the new column. Values
#' could be "10cm", "3in" or "30em", etc..
#' @param align Column alignment. you can choose from "c", "l" or "r"
#' @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 ... Extra options to be passed into HTML or LaTeX. Right now there is
#' only one for LaTeX. Option full_midline is a TRUE/FALSE option to control
#' if the mid line needs to be extended to the end of row.
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' add_header_left(x, c("A" = 2, "B" = 2, "C" = 2))
add_header_left <- function(kable_input, header = NULL, header_name = "",
                            align = "c", width = NULL, bold = F, italic = F,
                            ...) {
  if (is.null(header)) return(kable_input)
  kable_format <- attr(kable_input, "format")
  if (!kable_format %in% c("html", "latex")) {
    stop("Please specify output format in your kable function. Currently ",
         "generic markdown table using pandoc is not supported.")
  }
  if (kable_format == "html") {
    return(add_header_left_html(kable_input, header, header_name, align,
                                width, bold, italic))
  }
  if (kable_format == "latex") {
    return(add_header_left_latex(kable_input, header, header_name, align,
                                 width, bold, italic, ...))
  }
}

# HTML
add_header_left_html <- function(kable_input, header, header_name, align,
                                 width, bold, italic) {
  kable_attrs <- attributes(kable_input)
  kable_xml <- read_xml(as.character(kable_input), options = "COMPACT")
  kable_thead <- xml_tpart(kable_xml, "thead")
  kable_tbody <- xml_tpart(kable_xml, "tbody")

  align <- match.arg(align, c("c", "l", "r"))
  align <- switch(align, "c" = "center", "l" = "left", "r" = "right")

  column_style <- paste0(
    ifelse(!is.null(width), paste0("width: ", width, "; "), ""),
    ifelse(bold, "font-weight: bold; ", ""),
    ifelse(italic, "font-style: italic; ", "")
  )

  new_header <- paste0(
    '<th style="text-align:', align, '; vertical-align: bottom;', column_style,
    '" rowspan="', length(xml_children(kable_thead)), '">', header_name, '</th>'
  )
  new_header <- read_xml(new_header, options = c("COMPACT"))
  xml_add_child(xml_child(kable_thead, 1), new_header, .where = 0)

  header <- standardize_header(header, length(xml_children(kable_tbody)))
  for (i in 1:nrow(header)) {
    new_row_item <- paste0(
      '<td style="text-align:', align, '; vertical-align: middle;',
      column_style, '" rowspan="',
      header$rowspan[i], '">', header$header[i], '</td>')
    new_row_item <- read_xml(new_row_item, options = "COMPACT")
    target_row <- xml_child(kable_tbody, header$row[i])
    xml_add_child(target_row, new_row_item, .where = 0)
  }

  out <- structure(as.character(kable_xml), format = "html",
                   class = "knitr_kable")

  # Adjust for column_spec
  if (is.null(kable_attrs$column_adjust)) {
    table_nrow <- length(xml_children(kable_tbody))
    # if (!is.null(kable_attrs$group_header_rows)) {
    #   table_nrow <- table_nrow - length(kable_attrs$group_header_rows)
    # }
    table_ncol <- length(xml_children(
      xml_child(kable_thead, length(xml_children(kable_thead)))
    ))
    kable_attrs$column_adjust$matrix <- matrix(
      rep(TRUE, table_nrow * table_ncol), ncol = table_nrow)
    kable_attrs$column_adjust$count <- 1
    new_row_index <- rep(FALSE, table_nrow)
  } else {
    new_row_index <- rep(FALSE, ncol(kable_attrs$column_adjust$matrix))
    kable_attrs$column_adjust$count <- 1 + kable_attrs$column_adjust$count
  }
  new_row_index[header$row] <- TRUE
  kable_attrs$column_adjust$matrix <- rbind(
    new_row_index, kable_attrs$column_adjust$matrix
  )
  attributes(out) <- kable_attrs

  return(out)
}

standardize_header <- function(header, n_row) {
  header_names <- names(header)

  if (is.null(header_names)) {
    return(data.frame(header = header, row = 1:length(header),
                      rowspan = 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
  if (sum(header) < n_row) {
    header <- c(header, " " = n_row - sum(header))
  }
  row_pos <- c(1, cumsum(header)[-length(header)] + 1)
  return(data.frame(
    header = names(header),
    row = row_pos, rowspan = header, row.names = NULL
    ))
}

add_header_left_latex <- function(kable_input, header, header_name, align,
                                  width, bold, italic, full_midline = F) {
  table_info <- magic_mirror(kable_input)
  usepackage_latex("multirow")
  if (!table_info$booktabs) {
    warning("add_header_left only supports LaTeX table with booktabs. Please",
            " use kable(..., booktabs = T) in your kable function.")
  }
  out <- as.character(kable_input)
  contents <- table_info$contents
  header_name <- escape_latex(header_name)
  header <- standardize_header(header, length(contents) - 1)
  header$header <- escape_latex(header$header)
  header$header <- gsub("\\\\", "\\\\\\\\", header$header)
  header$row <- header$row + 1
  header$row_end <- header$row + header$rowspan - 1

  # Align
  align_row <- latex_column_align_builder(align, width, bold, italic)

  out <- sub(paste0(table_info$begin_tabular, "\\{"),
             paste0(table_info$begin_tabular, "{", align_row,
                    ifelse(table_info$booktabs, "", "|")),
             out, perl = T)
  # table_info$align_vector <- c(align, table_info$align_vector)

  # Header
  ## Extra header rows introduced by add_header_above
  if (!is.null(table_info$new_header_row)) {
    new_header_row <- table_info$new_header_row
    for (i in 1:length(new_header_row)) {
      out <- sub(regex_escape(new_header_row[i]),
                 paste0(" & ", new_header_row[i]), out)
      cline_old <- cline_gen(table_info$header_df[[i]], table_info$booktabs)
      cline_old <- regex_escape(cline_old)
      table_info$header_df[[i]] <- rbind(
        data.frame(header = " ", colspan = 1),
        table_info$header_df[[i]]
      )
      cline_new <- cline_gen(table_info$header_df[[i]], table_info$booktabs)
      out <- sub(cline_old, cline_new, out)
    }
  }
  ## Base Header row
  out <- sub(contents[1], paste0(header_name, " & ", contents[1]), out)
  table_info$contents[1] <- paste0(header_name, " & ", contents[1])

  # move existing midrules if exists
  out_lines <- read_lines(out)
  tbody_start_row <- which(out_lines == "\\midrule")
  tbody_end_row <- which(out_lines == "\\bottomrule")
  before_tbody <- out_lines[seq(1, tbody_start_row)]
  tbody <- out_lines[seq(tbody_start_row + 1, tbody_end_row - 1)]
  after_tbody <- out_lines[seq(tbody_end_row, length(out_lines))]

  # Remove addlinespace in this case
  tbody <- tbody[tbody != "\\addlinespace"]

  midrule_exist <- str_sub(tbody, 1, 9) == "\\cmidrule"
  if (sum(midrule_exist) > 0) {
    existing_midrules <- which(midrule_exist)
    tbody[existing_midrules] <- unlist(lapply(
      tbody[existing_midrules], cmidrule_plus_one
    ))
    out <- paste0(c(before_tbody, tbody, after_tbody), collapse = "\n")
  }

  for (j in 1:nrow(header)) {
    new_row_pre <- paste0(
      "\\\\multirow\\{", -header$rowspan[j], "\\}\\{",
      ifelse(is.null(width), "\\*", width),
      "\\}\\{",
      switch(align,
             "l" = "\\\\raggedright\\\\arraybackslash ",
             "c" = "\\\\centering\\\\arraybackslash ",
             "r" = "\\\\raggedleft\\\\arraybackslash "),
      header$header[j], "\\} & "
    )
    new_row_text <- paste0(new_row_pre, contents[header$row_end[j]])
    out <- sub(contents[header$row_end[j]], new_row_text, out)
    table_info$contents[header$row_end[j]] <- new_row_text
    if (j != nrow(header)) {
      out <- sub(
        paste0(contents[header$row_end[j]], "\\\\\\\\\n"),
        paste0(contents[header$row_end[j]],
               "\\\\\\\\\n\\\\cmidrule[0.5pt](l{2pt}r{2pt}){1-",
               ifelse(full_midline, str_count(tbody[1], " & ") + 2, 1),
               "}\n"),
        out
      )
    }
  }

  for (k in setdiff(seq(2, length(contents)), header$row_end)) {
    out <- sub(contents[k],
               paste0("  & ", contents[k]),
               out)
    table_info$contents[k] <- paste0("  & ", contents[k])
  }

  out <- structure(out, format = "latex", class = "knitr_kable")

  attr(out, "kable_meta") <- table_info
  return(out)
}

cmidrule_plus_one <- function(x) {
  start_pos <- as.numeric(str_match(x, "\\)\\{(.*)-")[2]) + 1
  stop_pos <- as.numeric(str_match(x, "-(.*)\\}")[2]) + 1
  return(
    paste0("\\cmidrule[0.5pt](l{2pt}r{2pt}){", start_pos, "-", stop_pos, "}")
  )
}