blob: c01ba97f3abd624a6b21e533e3cf8c094d747f6b [file] [log] [blame]
Hao Zhud4f54982020-10-07 16:26:35 -04001#' Separate table headers and add additional header rows based on grouping
2#'
3#' @description When you create a summary table for either model or basic
4#' summary stats in R, you usually end up having column names in the form of
5#' "a_mean", "a_sd", "b_mean" and "b_sd". This function streamlines the process
6#' of renaming these column names and adding extra header rows using
7#' `add_header_above`.
8#'
9#' @param kable_input Output of `knitr::kable()` with `format` specified
10#' @param sep A regular expression separator between groups. The default value
11#' is a regular expression that matches any sequence of non-alphanumeric values.
12#'
13#' @export
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010014header_separate <- function(kable_input, sep = "[^[:alnum:]]+", ...) {
Hao Zhud4f54982020-10-07 16:26:35 -040015 kable_format <- attr(kable_input, "format")
16 if (!kable_format %in% c("html", "latex")) {
17 warning("Please specify format in kable. kableExtra can customize either ",
18 "HTML or LaTeX outputs. See https://haozhu233.github.io/kableExtra/ ",
19 "for details.")
20 return(kable_input)
21 }
22 if (kable_format == "html") {
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010023 return(do.call(header_separate_html, list(
24 kable_input = kable_input,
25 sep = sep,
26 ...
27 )))
Hao Zhud4f54982020-10-07 16:26:35 -040028 }
29 if (kable_format == "latex") {
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010030 return(do.call(header_separate_latex, list(
31 kable_input = kable_input,
32 sep = sep,
33 ...
34 )))
Hao Zhud4f54982020-10-07 16:26:35 -040035 }
36}
37
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010038header_separate_html <- function(kable_input, sep, ...) {
Hao Zhud4f54982020-10-07 16:26:35 -040039 kable_attrs <- attributes(kable_input)
40 kable_xml <- kable_as_xml(kable_input)
41
42 kable_thead <- xml_tpart(kable_xml, "thead")
43 thead_depth <- length(xml_children(kable_thead))
44
45 if (thead_depth > 1) {
46 warning("Your table already has more than 1 rows of thead. header_separate ",
47 "won't work in this case and is returning the original input. ")
48 return(kable_input)
49 }
50
51 original_header_row <- xml_child(kable_thead, thead_depth)
52 original_header_cells <- lapply(
53 xml_children(original_header_row),
54 function(x) trimws(as.character(xml2::xml_contents(x)))
55 )
56
57 header_sep <- stringr::str_split(original_header_cells, sep)
58 header_layers <- process_header_sep(header_sep)
59 new_header_row_one <- lapply(header_layers[[1]], function(x) {
60 paste0("<th>", x, "</th>")
61 })
62
63 # Fix the original header row
64 for (i in seq(length(header_sep))) {
65 new_header_row_one[[i]] <- xml2::read_html(new_header_row_one[[i]])
66 xml2::xml_attrs(new_header_row_one[[i]]) <-
67 xml2::xml_attrs(xml_child(original_header_row, i))
68 xml2::xml_replace(xml_child(original_header_row, i),
69 new_header_row_one[[i]])
70 }
71
72 out <- as_kable_xml(kable_xml)
73 attributes(out) <- kable_attrs
74 if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
75
76 for (l in seq(2, length(header_layers))) {
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010077 out <- do.call(
78 kableExtra::add_header_above,
79 list(
80 kable_input = out,
81 kableExtra::auto_index(header_layers[[l]]),
82 ...
Hao Zhud4f54982020-10-07 16:26:35 -040083 )
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +010084 )
Hao Zhud4f54982020-10-07 16:26:35 -040085 }
86 return(out)
87}
88
89process_header_sep <- function(header_sep) {
90 max_depth <- max(unlist(lapply(header_sep, length)))
91 header_layers <- list()
92 for (i in seq(max_depth)) {
93 header_layers[[i]] <- list()
94 for (j in seq(1, length(header_sep))) {
95 layer_length <- length(header_sep[[j]])
96 if (layer_length > 0) {
97 header_layers[[i]][[j]] <- header_sep[[j]][layer_length]
98 header_sep[[j]] <- header_sep[[j]][-layer_length]
99 } else {
100 header_layers[[i]][[j]] <- " "
101 }
102 }
103 }
104 header_layers <- lapply(header_layers, unlist)
105 return(header_layers)
106}
107
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +0100108header_separate_latex <- function(kable_input, sep, ...) {
Hao Zhud4f54982020-10-07 16:26:35 -0400109 table_info <- magic_mirror(kable_input)
110 out <- solve_enc(kable_input)
111
112 if (table_info$duplicated_rows) {
113 dup_fx_out <- fix_duplicated_rows_latex(out, table_info)
114 out <- dup_fx_out[[1]]
115 table_info <- dup_fx_out[[2]]
116 }
117
118 if (!is.null(table_info$new_header_row)) {
119 warning("Your table already has more than 1 rows of thead. header_separate ",
120 "won't work in this case and is returning the original input. ")
121 return(kable_input)
122 }
123
124 original_header_cells <- str_split(table_info$contents[1], " & ")[[1]]
125
126 header_sep <- stringr::str_split(original_header_cells, sep)
127 header_layers <- process_header_sep(header_sep)
128
129 # Fix the original header row
130 new_header_row_one <- paste0(header_layers[[1]], collapse = ' & ')
131
132 out <- stringr::str_replace(out, paste0(table_info$contents[1], "\\\\\\\\"),
133 paste0(new_header_row_one, "\\\\\\\\"))
134 table_info$contents[1] <- new_header_row_one
135
136 out <- structure(out, format = "latex", class = "knitr_kable")
137 attr(out, "kable_meta") <- table_info
138
139 for (l in seq(2, length(header_layers))) {
Óscar Gómez Alcañiz912ab552021-12-15 16:18:31 +0100140 out <- do.call(
141 kableExtra::add_header_above,
142 list(
143 kable_input = out,
144 kableExtra::auto_index(header_layers[[l]]),
145 ...
146 )
Hao Zhud4f54982020-10-07 16:26:35 -0400147 )
148 }
149
150 return(out)
151}
152
153