quick demo
diff --git a/R/html_add_header_above.R b/R/html_add_header_above.R
index 3acb2e1..c9b153e 100644
--- a/R/html_add_header_above.R
+++ b/R/html_add_header_above.R
@@ -1,16 +1,51 @@
#' Add an extra header row above the current header
#' @export
htmlTable_add_header_above <- function(kable_input, header = NULL) {
- if (is.null(header)) return(kable_input)
+ # if (is.null(header)) return(kable_input)
kable_xml <- read_xml(as.character(kable_input), options = c("COMPACT"))
- kable_xml_thead <- xml_child(kable_xml, "thead")
+ # somehow xml2 cannot directly search by name here (it will result in a crash)
+ kable_xml_thead <- xml_child(kable_xml, 1)
+ if (xml_name(kable_xml_thead) != "thead") {
+ kable_xml_thead <- xml_child(kable_xml, 2)
+ }
+ header <- standardize_header_input(header)
- x <- read_xml("<parent><child>1</child><child>2<child>3</child></child></parent>")
- children <- xml_children(x)
- t1 <- children[[1]]
- t2 <- children[[2]]
- t3 <- xml_children(children[[2]])[[1]]
+ header_rows <- xml_children(kable_xml_thead)
+ bottom_header_row <- header_rows[[length(header_rows)]]
+ kable_ncol <- length(xml_children(bottom_header_row))
+ if (sum(header$colspan) != kable_ncol) {
+ stop("The new header row you provided has a different total number of ",
+ "columns with the original kable output.")
+ }
+ new_header_row <- new_header_generator(header)
+ xml_add_child(kable_xml_thead, new_header_row, .where = 0)
+ return(structure(as.character(kable_xml), format = "html",
+ class = "knitr_kable"))
+}
+standardize_header_input <- function(header) {
+ header_names <- names(header)
+
+ if (is.null(header_names)) {
+ return(data.frame(header = header, colspan = 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
+ return(data.frame(header = names(header), colspan = header, row.names = NULL))
+}
+
+new_header_generator <- function(header_vector) {
+ header_items <- apply(header_vector, 1, function(x) {
+ paste0('<th style="text-align:center;" colspan="', x[2], '">',
+ x[1], '</th>')
+ })
+ header_text <- paste(c("<tr>", header_items, "</tr>"), collapse = "")
+ header_xml <- read_xml(header_text, options = c("COMPACT"))
+ return(header_xml)
}
diff --git a/R/kableExtra-package.R b/R/kableExtra-package.R
index cd0bbe8..6f7fa7e 100644
--- a/R/kableExtra-package.R
+++ b/R/kableExtra-package.R
@@ -2,6 +2,7 @@
#'
#' @importFrom stringr str_count
#' @importFrom xml2 read_xml xml_attr xml_has_attr xml_attr<- read_html
+#' xml_child xml_children xml_name xml_add_sibling xml_add_child
#' @importFrom rvest html_table
#' @importFrom knitr kable
#' @name kableExtra-package