R/group_rows.R

#' Put a few rows of a table into one category
#'
#' @description Group a few rows in a table together under a label.
#'
#' @param kable_input Output of `knitr::kable()` with `format` specified
#' @param group_label A character string for the name of the group
#' @param start_row A numeric value that tells the function in which row the
#' group starts. Note that the counting excludes header rows and other group
#' labeling rows
#' @param end_row A numeric value that tells the function in which row the group
#' ends.
#' @param index A named vector providing the index for robust row-grouping tasks.
#' Basically, you can use it in the same way as `add_header_above()`.
#' @param label_row_css A character string for any customized css used for the
#' labeling row. By default, the labeling row will have a solid black line
#' underneath. Only useful for HTML documents.
#' @param latex_gap_space A character value telling LaTeX how large the gap
#' between the previous row and the group labeling row. Only useful for LaTeX
#' documents.
#' @param escape A T/F value showing whether special characters should be
#' escaped.
#' @param latex_align Adjust justification of group_label in latex only. Value should be "c" for
#' centered on row, "r" for right justification, or "l" for left justification. Default
#' Value is "l"  If using html, the alignment can be set by using the label_row_css
#' parameter.
#' @param colnum A numeric that determines how many columns the text should span.
#' The default setting will have the text span the entire length.
#' @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 hline_before A T/F value that addes a horizontal line before the group_row label.  Default
#' value is False.
#' @param hline_after A replicate of `hline.after` in xtable. It
#' addes a hline after the row
#' @param extra_latex_after Extra LaTeX text to be added after the row.
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' # Put Row 2 to Row 5 into a Group and label it as "Group A"
#' group_rows(x, "Group A", 2, 5)
#'
#' @export
group_rows <- function(kable_input, group_label = NULL,
                       start_row = NULL, end_row = NULL,
                       index = NULL,
                       label_row_css = "border-bottom: 1px solid;",
                       latex_gap_space = "0.3em",
                       escape = TRUE, latex_align = "l", colnum = NULL,
                       bold = T,
                       italic = F,
                       hline_before = F,
                       hline_after = F,
                       extra_latex_after = NULL) {

  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 (is.null(index)) {
    if (kable_format == "html") {
      if(!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
                                    use label_row_css instead.")
      return(group_rows_html(kable_input, group_label, start_row, end_row,
                             label_row_css, escape, colnum))
    }
    if (kable_format == "latex") {
      return(group_rows_latex(kable_input, group_label, start_row, end_row,
                              latex_gap_space, escape, latex_align, colnum,
                              bold, italic, hline_before, hline_after, extra_latex_after))
    }
  } else {
    index <- group_row_index_translator(index)
    out <- kable_input
    if (kable_format == "html") {
      for (i in 1:nrow(index)) {
        if(!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
                                    use label_row_css instead.")
        out <- group_rows_html(out, index$header[i],
                               index$start[i], index$end[i],
                               label_row_css, escape, colnum)
      }
    }
    if (kable_format == "latex") {
      for (i in 1:nrow(index)) {
        out <- group_rows_latex(out, index$header[i],
                               index$start[i], index$end[i],
                               latex_gap_space, escape, latex_align, colnum,
                               bold, italic, hline_before, hline_after, extra_latex_after)
      }
    }
    return(out)
  }
}

group_row_index_translator <- function(index) {
  index <- standardize_header_input(index)
  index$start <- cumsum(c(1, index$colspan))[1:length(index$colspan)]
  index$end <- cumsum(index$colspan)
  index$header <- trimws(index$header)
  index <- index[index$header != "", ]
  return(index)
}

group_rows_html <- function(kable_input, group_label, start_row, end_row,
                            label_row_css, escape, colnum) {
  kable_attrs <- attributes(kable_input)
  kable_xml <- read_kable_as_xml(kable_input)
  kable_tbody <- xml_tpart(kable_xml, "tbody")

  if (escape) {
    group_label <- escape_html(group_label)
  }

  group_header_rows <- attr(kable_input, "group_header_rows")
  group_seq <- seq(start_row, end_row)
  if (!is.null(group_header_rows)) {
    group_seq <- positions_corrector(group_seq, group_header_rows,
                                     length(xml_children(kable_tbody)))
  }

  # Insert a group header row
  starting_node <- xml_child(kable_tbody, group_seq[1])
  kable_ncol <- ifelse(is.null(colnum),
                       length(xml_children(starting_node)),
                       colnum)
  group_header_row_text <- paste0(
    '<tr groupLength="', length(group_seq), '"><td colspan="', kable_ncol,
    '" style="', label_row_css, '"><strong>', group_label,
    "</strong></td></tr>"
  )
  group_header_row <- read_xml(group_header_row_text, options = "COMPACT")
  xml_add_sibling(starting_node, group_header_row, .where = "before")

  # add indentations to items
  out <- as_kable_xml(kable_xml)
  attributes(out) <- kable_attrs
  attr(out, "group_header_rows") <- c(attr(out, "group_header_rows"), group_seq[1])
  out <- add_indent_html(out, positions = seq(start_row, end_row))
  return(out)
}

group_rows_latex <- function(kable_input, group_label, start_row, end_row,
                             gap_space, escape, latex_align, colnum,
                             bold = T, italic = F, hline_before = F ,hline_after = F,
                             extra_latex_after = NULL) {
  table_info <- magic_mirror(kable_input)
  out <- solve_enc(kable_input)

  if (table_info$duplicated_rows) {
    dup_fx_out <- fix_duplicated_rows_latex(out, table_info)
    out <- dup_fx_out[[1]]
    table_info <- dup_fx_out[[2]]
  }

  if (escape) {
    group_label <- input_escape(group_label, latex_align)
  }

  if (bold) {
    group_label <- paste0("\\\\textbf{", group_label, "}")
  }
  if (italic) group_label <- paste0("\\\\textit{", group_label, "}")
  # Add group label
  rowtext <- table_info$contents[start_row + 1]
  if (table_info$booktabs) {
    pre_rowtext <- paste0(
      "\\\\addlinespace[", gap_space, "]\n",
      ifelse(hline_before,"\\\\hline\n", ""),
      "\\\\multicolumn{", ifelse(is.null(colnum),
                                 table_info$ncol,
                                 colnum),
      "}{", latex_align, "}{", group_label,
      "}\\\\\\\\\n", ifelse(hline_after, "\\\\hline\n", '')
    )
  } else {
    rowtext <- paste0("\\\\hline\n", rowtext)
    pre_rowtext <- paste0(
      "\\\\hline\n\\\\multicolumn{", table_info$ncol, "}{", latex_align,"}{",
      group_label, "}\\\\\\\\\n"
    )
  }
  if(!is.null(extra_latex_after)){
    pre_rowtext <- paste0(pre_rowtext,
                      regex_escape(extra_latex_after, double_backslash = TRUE))
  }
  new_rowtext <- paste0(pre_rowtext, rowtext)
  out <- sub(rowtext, new_rowtext, out)
  out <- gsub("\\\\addlinespace\n", "", out)
  out <- structure(out, format = "latex", class = "knitr_kable")
  table_info$group_rows_used <- TRUE
  attr(out, "kable_meta") <- table_info
  out <- add_indent_latex(out, seq(start_row, end_row))
  return(out)
}