blob: fc2b805a45e8fafaa9de37d0ca329e855e75222a [file] [log] [blame]
Hao Zhuf7994dd2017-02-27 16:58:42 -05001#' Add a header row on top of current header
2#'
3#' @description Tables with multiple rows of header rows are extremely useful
4#' to demonstrate grouped data. This function takes the output of a `kable()`
Hao Zhue7c8f702017-10-10 13:22:59 -04005#' function and adds an header row on top of it.
Hao Zhuf7994dd2017-02-27 16:58:42 -05006#'
7#' @param kable_input Output of `knitr::kable()` with `format` specified
8#' @param header A (named) character vector with `colspan` as values. For
9#' example, `c(" " = 1, "title" = 2)` can be used to create a new header row
10#' for a 3-column table with "title" spanning across column 2 and 3. For
11#' convenience, when `colspan` equals to 1, users can drop the ` = 1` part.
12#' As a result, `c(" ", "title" = 2)` is the same as `c(" " = 1, "title" = 2)`.
Hao Zhu32f43f72017-06-20 18:24:54 -040013#' @param bold A T/F value to control whether the text should be bolded.
14#' @param italic A T/F value to control whether the text should to be emphasized.
Hao Zhuac7e70f2017-08-02 00:18:36 -040015#' @param monospace A T/F value to control whether the text of the selected column
16#' need to be monospaced (verbatim)
17#' @param escape A T/F value showing whether special characters should be
18#' escaped.
Salzer6bc84f82018-02-11 13:18:01 -050019#' @param line A T/F value to control whether a line will appear underneath the
20#' header
Hao Zhuf7994dd2017-02-27 16:58:42 -050021#'
Hao Zhu78e61222017-05-24 20:53:35 -040022#' @examples x <- knitr::kable(head(mtcars), "html")
23#' # Add a row of header with 3 columns on the top of the table. The column
24#' # span for the 2nd and 3rd one are 5 & 6.
25#' add_header_above(x, c(" ", "Group 1" = 5, "Group 2" = 6))
26#'
Hao Zhuc1f38412017-02-23 12:13:48 -050027#' @export
Hao Zhuac7e70f2017-08-02 00:18:36 -040028add_header_above <- function(kable_input, header = NULL,
29 bold = FALSE, italic = FALSE,
Salzer6bc84f82018-02-11 13:18:01 -050030 monospace = FALSE, escape = TRUE,line = TRUE) {
Hao Zhuc1f38412017-02-23 12:13:48 -050031 kable_format <- attr(kable_input, "format")
32 if (!kable_format %in% c("html", "latex")) {
Hao Zhu401ebd82018-01-14 17:10:20 -050033 warning("Please specify format in kable. kableExtra can customize either ",
34 "HTML or LaTeX outputs. See https://haozhu233.github.io/kableExtra/ ",
35 "for details.")
36 return(kable_input)
Hao Zhuc1f38412017-02-23 12:13:48 -050037 }
38 if (kable_format == "html") {
Hao Zhuac7e70f2017-08-02 00:18:36 -040039 return(htmlTable_add_header_above(kable_input, header,
Salzer6bc84f82018-02-11 13:18:01 -050040 bold, italic, monospace, escape,line))
Hao Zhuc1f38412017-02-23 12:13:48 -050041 }
42 if (kable_format == "latex") {
Hao Zhuac7e70f2017-08-02 00:18:36 -040043 return(pdfTable_add_header_above(kable_input, header,
Salzer6bc84f82018-02-11 13:18:01 -050044 bold, italic, monospace, escape,line))
Hao Zhuc1f38412017-02-23 12:13:48 -050045 }
46}
47
48# HTML
Hao Zhuac7e70f2017-08-02 00:18:36 -040049htmlTable_add_header_above <- function(kable_input, header,
Salzer6bc84f82018-02-11 13:18:01 -050050 bold, italic, monospace, escape,line) {
Hao Zhuc1f38412017-02-23 12:13:48 -050051 if (is.null(header)) return(kable_input)
Hao Zhu909ea382017-06-12 15:43:47 -040052 kable_attrs <- attributes(kable_input)
Hao Zhu558c72f2017-07-24 15:12:00 -040053 kable_xml <- read_kable_as_xml(kable_input)
Hao Zhu62cdde52017-05-20 22:16:03 -040054 kable_xml_thead <- xml_tpart(kable_xml, "thead")
Hao Zhuc1f38412017-02-23 12:13:48 -050055
56 header <- standardize_header_input(header)
57
Hao Zhuac7e70f2017-08-02 00:18:36 -040058 if (escape) {
59 header$header <- escape_html(header$header)
60 }
61
Hao Zhuc1f38412017-02-23 12:13:48 -050062 header_rows <- xml_children(kable_xml_thead)
63 bottom_header_row <- header_rows[[length(header_rows)]]
64 kable_ncol <- length(xml_children(bottom_header_row))
65 if (sum(header$colspan) != kable_ncol) {
66 stop("The new header row you provided has a different total number of ",
67 "columns with the original kable output.")
68 }
69
Hao Zhuac7e70f2017-08-02 00:18:36 -040070 new_header_row <- htmlTable_new_header_generator(header,
Salzer6bc84f82018-02-11 13:18:01 -050071 bold, italic, monospace,line)
Hao Zhuc1f38412017-02-23 12:13:48 -050072 xml_add_child(kable_xml_thead, new_header_row, .where = 0)
Hao Zhuf2dfd142017-07-24 14:43:28 -040073 out <- as_kable_xml(kable_xml)
Hao Zhu909ea382017-06-12 15:43:47 -040074 attributes(out) <- kable_attrs
Hao Zhuf2100832018-01-11 16:20:29 -050075 if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
Hao Zhu6a076462017-03-01 12:59:01 -050076 return(out)
Hao Zhuc1f38412017-02-23 12:13:48 -050077}
78
79standardize_header_input <- function(header) {
80 header_names <- names(header)
81
82 if (is.null(header_names)) {
83 return(data.frame(header = header, colspan = 1, row.names = NULL))
84 }
85
86 names(header)[header_names == ""] <- header[header_names == ""]
87 header[header_names == ""] <- 1
88 header_names <- names(header)
89 header <- as.numeric(header)
90 names(header) <- header_names
91 return(data.frame(header = names(header), colspan = header, row.names = NULL))
92}
93
Salzer6bc84f82018-02-11 13:18:01 -050094htmlTable_new_header_generator <- function(header_df, bold, italic, monospace,line) {
Hao Zhu32f43f72017-06-20 18:24:54 -040095 row_style <- paste0(
96 ifelse(bold, "font-weight: bold; ", ""),
Hao Zhuac7e70f2017-08-02 00:18:36 -040097 ifelse(italic, "font-style: italic; ", ""),
98 ifelse(monospace, "font-family: monospace; ", "")
Hao Zhu32f43f72017-06-20 18:24:54 -040099 )
Hao Zhuc1f38412017-02-23 12:13:48 -0500100 header_items <- apply(header_df, 1, function(x) {
Hao Zhuacc7ceb2017-05-26 10:50:25 -0700101 if (trimws(x[1]) == "") {
Hao Zhu7f7293e2017-10-27 11:36:18 -0400102 paste0('<th style="border-bottom:hidden" colspan="', x[2], '"></th>')
Hao Zhu6d2faa12017-05-24 02:16:45 -0400103 } else {
Hao Zhuacc7ceb2017-05-26 10:50:25 -0700104 paste0('<th style="text-align:center; border-bottom:hidden; ',
Hao Zhu32f43f72017-06-20 18:24:54 -0400105 'padding-bottom:0; padding-left:3px;padding-right:3px;',
106 row_style,
107 '" colspan="',
Salzer6bc84f82018-02-11 13:18:01 -0500108 x[2], '"><div style="',
109 ifelse(line,'border-bottom: 1px solid #ddd; padding-bottom: 5px;">','">'),
Hao Zhuacc7ceb2017-05-26 10:50:25 -0700110 x[1], '</div></th>')
Hao Zhu6d2faa12017-05-24 02:16:45 -0400111 }
Hao Zhuc1f38412017-02-23 12:13:48 -0500112 })
113 header_text <- paste(c("<tr>", header_items, "</tr>"), collapse = "")
114 header_xml <- read_xml(header_text, options = c("COMPACT"))
115 return(header_xml)
116}
117
118# Add an extra header row above the current header in a LaTeX table ------
Hao Zhuac7e70f2017-08-02 00:18:36 -0400119pdfTable_add_header_above <- function(kable_input, header,
Salzer6bc84f82018-02-11 13:18:01 -0500120 bold, italic, monospace, escape, line) {
Hao Zhuc1f38412017-02-23 12:13:48 -0500121 table_info <- magic_mirror(kable_input)
122 header <- standardize_header_input(header)
Hao Zhuac7e70f2017-08-02 00:18:36 -0400123 if (escape) {
124 header$header <- escape_latex(header$header)
125 header$header <- gsub("\\\\", "\\\\\\\\", header$header)
126 }
Hao Zhuc1f38412017-02-23 12:13:48 -0500127 hline_type <- switch(table_info$booktabs + 1, "\\\\hline", "\\\\toprule")
Hao Zhu32f43f72017-06-20 18:24:54 -0400128 new_header_split <- pdfTable_new_header_generator(header, table_info$booktabs,
Hao Zhuac7e70f2017-08-02 00:18:36 -0400129 bold, italic, monospace)
Salzer6bc84f82018-02-11 13:18:01 -0500130 if(line){
131 new_header <- paste0(new_header_split[1], "\n", new_header_split[2])
132 } else {
133 new_header <- new_header_split[1]
134 }
Hao Zhub2b41992017-10-03 12:50:03 -0400135 out <- str_replace(enc2utf8(as.character(kable_input)),
136 hline_type,
137 paste0(hline_type, "\n", new_header))
Hao Zhuc1f38412017-02-23 12:13:48 -0500138 out <- structure(out, format = "latex", class = "knitr_kable")
Hao Zhu2ce42b92017-06-15 17:15:33 -0400139 # new_header_row <- latex_contents_escape(new_header_split[1])
140 if (is.null(table_info$new_header_row)) {
141 table_info$new_header_row <- new_header_split[1]
142 table_info$header_df <- list(header)
143 } else {
144 table_info$new_header_row <- c(table_info$new_header_row, new_header_split[1])
145 table_info$header_df[[length(table_info$header_df) + 1]] <- header
146 }
Hao Zhu32f43f72017-06-20 18:24:54 -0400147 attr(out, "kable_meta") <- table_info
Hao Zhuc1f38412017-02-23 12:13:48 -0500148 return(out)
149}
150
Hao Zhu32f43f72017-06-20 18:24:54 -0400151pdfTable_new_header_generator <- function(header_df, booktabs = FALSE,
Hao Zhuac7e70f2017-08-02 00:18:36 -0400152 bold, italic, monospace) {
Hao Zhuc1f38412017-02-23 12:13:48 -0500153 if (booktabs) {
154 header_df$align <- "c"
155 } else {
156 header_df$align <- "|c|"
157 header_df$align[1] <- "c|"
158 header_df$align[nrow(header_df)] <- "|c"
159 }
160 header_items <- apply(header_df, 1, function(x) {
161 # if(x[2] == 1) return(x[1])
Hao Zhu32f43f72017-06-20 18:24:54 -0400162 paste0('\\\\multicolumn{', x[2], '}{', x[3], '}{',
163 ifelse(bold, "\\\\bfseries ", ""),
164 ifelse(italic, "\\\\em ", ""),
Hao Zhuac7e70f2017-08-02 00:18:36 -0400165 ifelse(monospace, "\\\\ttfamily ", ""),
166 x[1],
167 "}")
Hao Zhuc1f38412017-02-23 12:13:48 -0500168 })
169 header_text <- paste(paste(header_items, collapse = " & "), "\\\\\\\\")
Hao Zhu2ce42b92017-06-15 17:15:33 -0400170 cline <- cline_gen(header_df, booktabs)
171 return(c(header_text, cline))
172}
173
174cline_gen <- function(header_df, booktabs) {
Hao Zhuc1f38412017-02-23 12:13:48 -0500175 cline_end <- cumsum(header_df$colspan)
176 cline_start <- c(0, cline_end) + 1
177 cline_start <- cline_start[-length(cline_start)]
Hao Zhuc05e1812017-02-25 01:45:35 -0500178 cline_type <- switch(booktabs + 1,
179 "\\\\cline{",
180 "\\\\cmidrule(l{2pt}r{2pt}){")
Hao Zhuc1f38412017-02-23 12:13:48 -0500181 cline <- paste0(cline_type, cline_start, "-", cline_end, "}")
182 cline <- cline[trimws(header_df$header) != ""]
183 cline <- paste(cline, collapse = " ")
Hao Zhu2ce42b92017-06-15 17:15:33 -0400184 return(cline)
Hao Zhuc1f38412017-02-23 12:13:48 -0500185}
Hao Zhu2ce42b92017-06-15 17:15:33 -0400186
187