Add add_header_left html
diff --git a/NAMESPACE b/NAMESPACE
index 905a515..961edc0 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -3,6 +3,7 @@
export("%>%")
export(add_footnote)
export(add_header_above)
+export(add_header_left)
export(add_indent)
export(collapse_rows)
export(column_spec)
diff --git a/R/add_header_left.R b/R/add_header_left.R
new file mode 100644
index 0000000..b91a38c
--- /dev/null
+++ b/R/add_header_left.R
@@ -0,0 +1,76 @@
+#' Add a header column
+#'
+#' @description Experimenting. Please don't use it in production
+#'
+#' @export
+add_header_left <- function(kable_input, header = NULL, header_name = "") {
+ if (is.null(header)) return(kable_input)
+ kable_format <- attr(kable_input, "format")
+ if (!kable_format %in% c("html", "latex")) {
+ stop("Please specify output format in your kable function. Currently ",
+ "generic markdown table using pandoc is not supported.")
+ }
+ if (kable_format == "html") {
+ return(add_header_left_html(kable_input, header, header_name))
+ }
+ if (kable_format == "latex") {
+ return(add_header_left_latex(kable_input, header, header_name))
+ }
+}
+
+# HTML
+add_header_left_html <- function(kable_input, header, header_name) {
+ kable_attrs <- attributes(kable_input)
+ kable_xml <- read_xml(as.character(kable_input), options = "COMPACT")
+ kable_thead <- xml_tpart(kable_xml, "thead")
+ kable_tbody <- xml_tpart(kable_xml, "tbody")
+
+ new_header <- paste0(
+ '<th style="text-align:center;" rowspan="',
+ length(xml_children(kable_thead)), '">', header_name, '</th>'
+ )
+ new_header <- read_xml(new_header, options = c("COMPACT"))
+ xml_add_child(xml_child(kable_thead, 1), new_header, .where = 0)
+
+ header <- standardize_rowheader_input(header, length(xml_children(kable_tbody)))
+ for (i in 1:nrow(header)) {
+ new_row_item <- paste0(
+ '<td style="text-align:center; vertical-align: middle;" rowspan="',
+ header$rowspan[i], '">', header$header[i], '</td>')
+ new_row_item <- read_xml(new_row_item, options = "COMPACT")
+ target_row <- xml_child(kable_tbody, header$row[i])
+ xml_add_child(target_row, new_row_item, .where = 0)
+ }
+
+ out <- structure(as.character(kable_xml), format = "html",
+ class = "knitr_kable")
+ attributes(out) <- kable_attrs
+ return(out)
+}
+
+standardize_rowheader_input <- function(header, n_row) {
+ header_names <- names(header)
+
+ if (is.null(header_names)) {
+ return(data.frame(header = header, row = 1:length(header),
+ rowspan = 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
+ if (sum(header) < n_row) {
+ header <- c(header, " " = n_row - sum(header))
+ }
+ row_pos <- c(1, cumsum(header)[-length(header)] + 1)
+ return(data.frame(
+ header = names(header),
+ row = row_pos, rowspan = header, row.names = NULL
+ ))
+}
+
+add_header_left_latex <- function(kable_input, header, header_name) {
+ return(kable_input)
+}
diff --git a/R/util.R b/R/util.R
index 3f5c470..a500879 100644
--- a/R/util.R
+++ b/R/util.R
@@ -67,3 +67,5 @@
mapping_matrix <- data.frame(mapping_matrix)
return(mapping_matrix)
}
+
+
diff --git a/man/add_header_left.Rd b/man/add_header_left.Rd
new file mode 100644
index 0000000..d16834a
--- /dev/null
+++ b/man/add_header_left.Rd
@@ -0,0 +1,11 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/add_header_left.R
+\name{add_header_left}
+\alias{add_header_left}
+\title{Add a header column}
+\usage{
+add_header_left(kable_input, header = NULL, header_name = "")
+}
+\description{
+Experimenting. Please don't use it in production
+}
diff --git a/tests/visual_tests/add_header_left_html.Rmd b/tests/visual_tests/add_header_left_html.Rmd
new file mode 100644
index 0000000..2fe83de
--- /dev/null
+++ b/tests/visual_tests/add_header_left_html.Rmd
@@ -0,0 +1,15 @@
+---
+title: "add_header_left"
+output: html_document
+---
+
+```{r}
+library(knitr)
+library(kableExtra)
+
+mtcars[1:10, 1:6] %>%
+ kable("html") %>%
+ kable_styling() %>%
+ add_header_above(c(" ", "a" = 3, "b" = 3)) %>%
+ add_header_left(c("a" = 2, "b" = 3))
+```