Hao Zhu | f7994dd | 2017-02-27 16:58:42 -0500 | [diff] [blame] | 1 | #' 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 Zhu | e7c8f70 | 2017-10-10 13:22:59 -0400 | [diff] [blame] | 5 | #' function and adds an header row on top of it. |
Hao Zhu | f7994dd | 2017-02-27 16:58:42 -0500 | [diff] [blame] | 6 | #' |
| 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 Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 13 | #' @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 Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 15 | #' @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. |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 19 | #' @param line A T/F value to control whether a line will appear underneath the |
| 20 | #' header |
Hao Zhu | f7994dd | 2017-02-27 16:58:42 -0500 | [diff] [blame] | 21 | #' |
Hao Zhu | 78e6122 | 2017-05-24 20:53:35 -0400 | [diff] [blame] | 22 | #' @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 Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 27 | #' @export |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 28 | add_header_above <- function(kable_input, header = NULL, |
| 29 | bold = FALSE, italic = FALSE, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 30 | monospace = FALSE, escape = TRUE,line = TRUE) { |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 31 | kable_format <- attr(kable_input, "format") |
| 32 | if (!kable_format %in% c("html", "latex")) { |
Hao Zhu | 401ebd8 | 2018-01-14 17:10:20 -0500 | [diff] [blame] | 33 | 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 Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 37 | } |
| 38 | if (kable_format == "html") { |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 39 | return(htmlTable_add_header_above(kable_input, header, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 40 | bold, italic, monospace, escape,line)) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 41 | } |
| 42 | if (kable_format == "latex") { |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 43 | return(pdfTable_add_header_above(kable_input, header, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 44 | bold, italic, monospace, escape,line)) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 45 | } |
| 46 | } |
| 47 | |
| 48 | # HTML |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 49 | htmlTable_add_header_above <- function(kable_input, header, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 50 | bold, italic, monospace, escape,line) { |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 51 | if (is.null(header)) return(kable_input) |
Hao Zhu | 909ea38 | 2017-06-12 15:43:47 -0400 | [diff] [blame] | 52 | kable_attrs <- attributes(kable_input) |
Hao Zhu | 558c72f | 2017-07-24 15:12:00 -0400 | [diff] [blame] | 53 | kable_xml <- read_kable_as_xml(kable_input) |
Hao Zhu | 62cdde5 | 2017-05-20 22:16:03 -0400 | [diff] [blame] | 54 | kable_xml_thead <- xml_tpart(kable_xml, "thead") |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 55 | |
| 56 | header <- standardize_header_input(header) |
| 57 | |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 58 | if (escape) { |
| 59 | header$header <- escape_html(header$header) |
| 60 | } |
| 61 | |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 62 | 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 Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 70 | new_header_row <- htmlTable_new_header_generator(header, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 71 | bold, italic, monospace,line) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 72 | xml_add_child(kable_xml_thead, new_header_row, .where = 0) |
Hao Zhu | f2dfd14 | 2017-07-24 14:43:28 -0400 | [diff] [blame] | 73 | out <- as_kable_xml(kable_xml) |
Hao Zhu | 909ea38 | 2017-06-12 15:43:47 -0400 | [diff] [blame] | 74 | attributes(out) <- kable_attrs |
Hao Zhu | f210083 | 2018-01-11 16:20:29 -0500 | [diff] [blame] | 75 | if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out)) |
Hao Zhu | 6a07646 | 2017-03-01 12:59:01 -0500 | [diff] [blame] | 76 | return(out) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 77 | } |
| 78 | |
| 79 | standardize_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 | |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 94 | htmlTable_new_header_generator <- function(header_df, bold, italic, monospace,line) { |
Hao Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 95 | row_style <- paste0( |
| 96 | ifelse(bold, "font-weight: bold; ", ""), |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 97 | ifelse(italic, "font-style: italic; ", ""), |
| 98 | ifelse(monospace, "font-family: monospace; ", "") |
Hao Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 99 | ) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 100 | header_items <- apply(header_df, 1, function(x) { |
Hao Zhu | acc7ceb | 2017-05-26 10:50:25 -0700 | [diff] [blame] | 101 | if (trimws(x[1]) == "") { |
Hao Zhu | 7f7293e | 2017-10-27 11:36:18 -0400 | [diff] [blame] | 102 | paste0('<th style="border-bottom:hidden" colspan="', x[2], '"></th>') |
Hao Zhu | 6d2faa1 | 2017-05-24 02:16:45 -0400 | [diff] [blame] | 103 | } else { |
Hao Zhu | acc7ceb | 2017-05-26 10:50:25 -0700 | [diff] [blame] | 104 | paste0('<th style="text-align:center; border-bottom:hidden; ', |
Hao Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 105 | 'padding-bottom:0; padding-left:3px;padding-right:3px;', |
| 106 | row_style, |
| 107 | '" colspan="', |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 108 | x[2], '"><div style="', |
| 109 | ifelse(line,'border-bottom: 1px solid #ddd; padding-bottom: 5px;">','">'), |
Hao Zhu | acc7ceb | 2017-05-26 10:50:25 -0700 | [diff] [blame] | 110 | x[1], '</div></th>') |
Hao Zhu | 6d2faa1 | 2017-05-24 02:16:45 -0400 | [diff] [blame] | 111 | } |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 112 | }) |
| 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 Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 119 | pdfTable_add_header_above <- function(kable_input, header, |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 120 | bold, italic, monospace, escape, line) { |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 121 | table_info <- magic_mirror(kable_input) |
| 122 | header <- standardize_header_input(header) |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 123 | if (escape) { |
| 124 | header$header <- escape_latex(header$header) |
| 125 | header$header <- gsub("\\\\", "\\\\\\\\", header$header) |
| 126 | } |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 127 | hline_type <- switch(table_info$booktabs + 1, "\\\\hline", "\\\\toprule") |
Hao Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 128 | new_header_split <- pdfTable_new_header_generator(header, table_info$booktabs, |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 129 | bold, italic, monospace) |
Salzer | 6bc84f8 | 2018-02-11 13:18:01 -0500 | [diff] [blame] | 130 | 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 Zhu | b2b4199 | 2017-10-03 12:50:03 -0400 | [diff] [blame] | 135 | out <- str_replace(enc2utf8(as.character(kable_input)), |
| 136 | hline_type, |
| 137 | paste0(hline_type, "\n", new_header)) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 138 | out <- structure(out, format = "latex", class = "knitr_kable") |
Hao Zhu | 2ce42b9 | 2017-06-15 17:15:33 -0400 | [diff] [blame] | 139 | # 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 Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 147 | attr(out, "kable_meta") <- table_info |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 148 | return(out) |
| 149 | } |
| 150 | |
Hao Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 151 | pdfTable_new_header_generator <- function(header_df, booktabs = FALSE, |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 152 | bold, italic, monospace) { |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 153 | 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 Zhu | 32f43f7 | 2017-06-20 18:24:54 -0400 | [diff] [blame] | 162 | paste0('\\\\multicolumn{', x[2], '}{', x[3], '}{', |
| 163 | ifelse(bold, "\\\\bfseries ", ""), |
| 164 | ifelse(italic, "\\\\em ", ""), |
Hao Zhu | ac7e70f | 2017-08-02 00:18:36 -0400 | [diff] [blame] | 165 | ifelse(monospace, "\\\\ttfamily ", ""), |
| 166 | x[1], |
| 167 | "}") |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 168 | }) |
| 169 | header_text <- paste(paste(header_items, collapse = " & "), "\\\\\\\\") |
Hao Zhu | 2ce42b9 | 2017-06-15 17:15:33 -0400 | [diff] [blame] | 170 | cline <- cline_gen(header_df, booktabs) |
| 171 | return(c(header_text, cline)) |
| 172 | } |
| 173 | |
| 174 | cline_gen <- function(header_df, booktabs) { |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 175 | cline_end <- cumsum(header_df$colspan) |
| 176 | cline_start <- c(0, cline_end) + 1 |
| 177 | cline_start <- cline_start[-length(cline_start)] |
Hao Zhu | c05e181 | 2017-02-25 01:45:35 -0500 | [diff] [blame] | 178 | cline_type <- switch(booktabs + 1, |
| 179 | "\\\\cline{", |
| 180 | "\\\\cmidrule(l{2pt}r{2pt}){") |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 181 | cline <- paste0(cline_type, cline_start, "-", cline_end, "}") |
| 182 | cline <- cline[trimws(header_df$header) != ""] |
| 183 | cline <- paste(cline, collapse = " ") |
Hao Zhu | 2ce42b9 | 2017-06-15 17:15:33 -0400 | [diff] [blame] | 184 | return(cline) |
Hao Zhu | c1f3841 | 2017-02-23 12:13:48 -0500 | [diff] [blame] | 185 | } |
Hao Zhu | 2ce42b9 | 2017-06-15 17:15:33 -0400 | [diff] [blame] | 186 | |
| 187 | |