From 5ae172fc56c8d84f90775a561afb7cc74e933da0 Mon Sep 17 00:00:00 2001
From: Duncan Murdoch <murdoch.duncan@gmail.com>
Date: Wed, 8 Feb 2023 16:19:18 -0500
Subject: [PATCH] Handle HTML kable object that includes extra stuff, such as a
 style block.

---
 R/kableExtra-package.R |  2 +-
 R/kable_styling.R      |  5 +++--
 R/util.R               | 37 ++++++++++++++++++++++++++++++++++---
 3 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/R/kableExtra-package.R b/R/kableExtra-package.R
index 87921a0..f63a3e0 100644
--- a/R/kableExtra-package.R
+++ b/R/kableExtra-package.R
@@ -58,7 +58,7 @@
 #' @importFrom stringr fixed str_count str_split str_match str_detect str_match_all
 #' str_extract str_replace_all str_trim str_extract_all str_sub str_replace
 #' @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 xml_text
+#' xml_child xml_children xml_name xml_add_sibling xml_add_child xml_text xml_length
 #' xml_remove write_xml xml_text<- xml_length
 #' @importFrom rvest html_table
 #' @importFrom knitr knit_meta_add include_graphics knit_print asis_output kable
diff --git a/R/kable_styling.R b/R/kable_styling.R
index 0d41372..594b915 100644
--- a/R/kable_styling.R
+++ b/R/kable_styling.R
@@ -214,7 +214,8 @@ htmlTable_styling <- function(kable_input,
   }
   kable_attrs <- attributes(kable_input)
   kable_xml <- read_kable_as_xml(kable_input)
-
+  pre <- attr(kable_xml, "pre")
+  post <- attr(kable_xml, "post")
   # Modify class
   bootstrap_options <- match.arg(
     bootstrap_options,
@@ -296,7 +297,7 @@ htmlTable_styling <- function(kable_input,
     }
   }
 
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(kable_xml, pre, post)
   if (protect_latex) {
     out <- replace_latex_in_kable(out, kable_attrs$extracted_latex)
     kable_attrs$extracted_latex <- NULL
diff --git a/R/util.R b/R/util.R
index 9d4eb14..639faf1 100644
--- a/R/util.R
+++ b/R/util.R
@@ -67,14 +67,45 @@ regex_escape <- function(x, double_backslash = FALSE) {
   return(x)
 }
 
-as_kable_xml <- function(x) {
-  out <- structure(as.character(x), format = "html", class = "knitr_kable")
+as_kable_xml <- function(x, pre = NULL, post = NULL) {
+  out <- structure(paste(c(pre, as.character(x), post), collapse = "\n"),
+                   format = "html", class = "knitr_kable")
   return(out)
 }
 
+is_html_table <- function(x) {
+  xml_length(x) == 1 &&
+    xml_name(xml_child(x, 1)) == "table"
+}
+
+child_to_character <- function(x) {
+  result <- character()
+  n <- xml_length(x)
+  for (i in seq_len(n)) {
+    if (xml_name(xml_child(x, i)) != "meta")
+      result <- c(result, as.character(xml_child(x, i)))
+  }
+  result
+}
+
 read_kable_as_xml <- function(x) {
   kable_html <- read_html(as.character(x), options = c("RECOVER", "NOERROR"))
-  xml_child(xml_child(kable_html, 1), 1)
+  children <- lapply(seq_len(xml_length(kable_html)),
+                     function(num) xml_child(kable_html, num))
+  pre <- character(0)
+  post <- character(0)
+  result <- list()
+  for (i in seq_along(children)) {
+    if (!is_html_table(children[[i]]))
+      pre <- c(pre, child_to_character(children[[i]]))
+    else {
+      result <- xml_child(children[[i]], 1)
+      for (j in seq_along(children)[-seq_len(i)])
+        post <- c(post, child_to_character(children[[i]]))
+      break;
+    }
+  }
+  structure(result, pre = pre, post = post)
 }
 
 #' LaTeX Packages