Fix #809

R/add_header_above.R

@@ -125,7 +125,9 @@ htmlTable_add_header_above <- function(kable_input, header, bold, italic,
                                        angle, escape, line, line_sep,
                                        extra_css, include_empty) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- read_kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   kable_xml_thead <- xml_tpart(kable_xml, "thead")
 
   if (escape) {
@@ -159,7 +161,7 @@ htmlTable_add_header_above <- function(kable_input, header, bold, italic,
     include_empty, attr(kable_input, 'lightable_class')
   )
   xml_add_child(kable_xml_thead, new_header_row, .where = 0)
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   if (is.null(kable_attrs$header_above)) {
     kable_attrs$header_above <- 1
   } else {

R/add_indent.R

@@ -109,7 +109,9 @@ add_indent_html <- function(kable_input, positions,
                             target_cols = 1) {
   kable_attrs <- attributes(kable_input)
 
-  kable_xml <- kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   kable_tbody <- xml_tpart(kable_xml, "tbody")
 
   group_header_rows <- attr(kable_input, "group_header_rows")
@@ -143,7 +145,7 @@ add_indent_html <- function(kable_input, positions,
       }
     }
   }
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
   return(out)

R/collapse_rows.R

@@ -88,7 +88,9 @@ collapse_rows <- function(kable_input, columns = NULL,
 
 collapse_rows_html <- function(kable_input, columns, valign, target) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   kable_tbody <- xml_tpart(kable_xml, "tbody")
 
   kable_dt <- read_table_data_from_xml(kable_xml)
@@ -123,7 +125,7 @@ collapse_rows_html <- function(kable_input, columns, valign, target) {
     }
   }
 
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   kable_attrs$collapse_matrix <- collapse_matrix
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))

R/column_spec.R

@@ -120,7 +120,9 @@ column_spec_html <- function(kable_input, column, width,
                              extra_css, include_thead,
                              link, new_tab, tooltip, popover, image) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   kable_tbody <- xml_tpart(kable_xml, "tbody")
 
   group_header_rows <- attr(kable_input, "group_header_rows")
@@ -206,7 +208,7 @@ column_spec_html <- function(kable_input, column, width,
     }
   }
 
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
   return(out)

R/footnote.R

@@ -210,14 +210,16 @@ footnote_table_maker <- function(format, footnote_titles, footnote_contents,
 # HTML
 footnote_html <- function(kable_input, footnote_table, footnote_as_chunk) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- read_kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
 
   new_html_footnote <- html_tfoot_maker(footnote_table, footnote_as_chunk)
   xml_add_child(kable_xml, new_html_footnote)
   xml2::xml_set_attr(kable_xml, "style",
                      paste0(xml2::xml_attr(kable_xml, "style"),
                             "border-bottom: 0;"))
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
   return(out)

R/group_rows.R

@@ -143,7 +143,9 @@ group_rows_html <- function(kable_input, group_label, start_row, end_row,
                             bold, italic, monospace, underline, strikeout,
                             color, background) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- read_kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   kable_tbody <- xml_tpart(kable_xml, "tbody")
 
   if (escape) {
@@ -214,7 +216,7 @@ group_rows_html <- function(kable_input, group_label, start_row, end_row,
   xml_add_sibling(starting_node, group_header_row, .where = "before")
 
   # add indentations to items
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   attr(out, "group_header_rows") <- c(attr(out, "group_header_rows"), group_seq[1])
   if (indent) {

R/header_separate.R

@@ -42,7 +42,9 @@ header_separate <- function(kable_input, sep = "[^[:alnum:]]+", ...) {
 
 header_separate_html <- function(kable_input, sep, ...) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
 
   kable_thead <- xml_tpart(kable_xml, "thead")
   thead_depth <- length(xml_children(kable_thead))
@@ -74,7 +76,7 @@ header_separate_html <- function(kable_input, sep, ...) {
                       new_header_row_one[[i]])
   }
 
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
 

R/kable_styling.R

@@ -217,9 +217,10 @@ htmlTable_styling <- function(kable_input,
     kable_input <- extract_latex_from_kable(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")
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
+
   # Modify class
   bootstrap_options <- match.arg(
     bootstrap_options,
@@ -309,7 +310,7 @@ htmlTable_styling <- function(kable_input,
     }
   }
 
-  out <- as_kable_xml(kable_xml, pre, post)
+  out <- as_kable_xml(body_node)
   if (protect_latex) {
     out <- replace_latex_in_kable(out, kable_attrs$extracted_latex)
     kable_attrs$extracted_latex <- NULL

R/kable_xml.R

@@ -6,7 +6,7 @@
 #'
 #' @export
 kable_as_xml <- function(x) {
-  read_kable_as_xml(x)
+  read_kable_as_xml(x)$table
 }
 
 #' Convert XML back to kable

R/magic_mirror.R

@@ -132,7 +132,9 @@ extra_header_to_header_df_ <- function(x) {
 # Magic Mirror for html table --------
 magic_mirror_html <- function(kable_input){
   table_info <- list()
-  kable_xml <- read_kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
   # Caption
   table_info$caption <- xml_text(xml_child(kable_xml, "caption"))
   # colnames

R/remove_column.R

@@ -34,7 +34,9 @@ remove_column <- function (kable_input, columns) {
 
 remove_column_html <- function (kable_input, columns) {
     kable_attrs <- attributes(kable_input)
-    kable_xml <- kable_as_xml(kable_input)
+    important_nodes <- read_kable_as_xml(kable_input)
+    body_node <- important_nodes$body
+    kable_xml <- important_nodes$table
     kable_tbody <- xml_tpart(kable_xml, "tbody")
     kable_thead <- xml_tpart(kable_xml, "thead")
 
@@ -93,7 +95,7 @@ remove_column_html <- function (kable_input, columns) {
         # not very efficient but for finite task it's probably okay
         columns <- (columns - 1)[-1]
     }
-    out <- as_kable_xml(kable_xml)
+    out <- as_kable_xml(body_node)
     attributes(out) <- kable_attrs
     if (!"kableExtra" %in% class(out))
         class(out) <- c("kableExtra", class(out))

R/row_spec.R

@@ -80,7 +80,9 @@ row_spec_html <- function(kable_input, row, bold, italic, monospace,
                           color, background, align, font_size, angle,
                           extra_css) {
   kable_attrs <- attributes(kable_input)
-  kable_xml <- read_kable_as_xml(kable_input)
+  important_nodes <- read_kable_as_xml(kable_input)
+  body_node <- important_nodes$body
+  kable_xml <- important_nodes$table
 
   if (!is.null(align)) {
     if (align %in% c("l", "c", "r")) {
@@ -120,7 +122,7 @@ row_spec_html <- function(kable_input, row, bold, italic, monospace,
     }
   }
 
-  out <- as_kable_xml(kable_xml)
+  out <- as_kable_xml(body_node)
   attributes(out) <- kable_attrs
   if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
   return(out)

R/scroll_box.R

@@ -44,7 +44,9 @@ scroll_box <- function(kable_input, height = NULL, width = NULL,
 
   if (fixed_thead$enabled) {
     box_css = "border: 1px solid #ddd; padding: 0px; "
-    kable_xml <- read_kable_as_xml(kable_input)
+    important_nodes <- read_kable_as_xml(kable_input)
+    body_node <- important_nodes$body
+    kable_xml <- important_nodes$table
     all_header_cells <- xml2::xml_find_all(kable_xml, "//thead//th")
     if (is.null(fixed_thead$background))  fixed_thead$background <- "#FFFFFF"
     for (i in seq(length(all_header_cells))) {
@@ -54,7 +56,7 @@ scroll_box <- function(kable_input, height = NULL, width = NULL,
         fixed_thead$background, ";"
       )
     }
-    out <- as.character(as_kable_xml(kable_xml))
+    out <- as.character(as_kable_xml(body_node))
   } else {
     out <- as.character(kable_input)
   }

R/util.R

@@ -108,17 +108,12 @@ regex_escape <- function(x, double_backslash = FALSE) {
   return(x)
 }
 
-as_kable_xml <- function(x, pre = NULL, post = NULL) {
-  out <- structure(paste(c(pre, as.character(x), post), collapse = "\n"),
+as_kable_xml <- function(bodynode) {
+  out <- structure(as.character(bodynode),
                    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)
@@ -129,24 +124,26 @@ child_to_character <- function(x) {
   result
 }
 
-read_kable_as_xml <- function(x) {
-  kable_html <- read_html(as.character(x), options = c("RECOVER", "NOERROR"))
-  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;
+dfs <- function(node, node_name='table') {
+  if (is.null(node)) return(NULL)
+  if (xml_name(node) == node_name) return(node)
+  for (child in xml_children(node)) {
+    found <- dfs(child, node_name)
+    if (!is.null(found)) {
+      return(found)
     }
   }
-  structure(result, pre = pre, post = post)
+  return(NULL)
+}
+
+read_kable_as_xml <- function(x) {
+  source_node <- read_html(as.character(x), options = c("RECOVER", "NOERROR"))
+  body_node <- xml_children(dfs(source_node, 'body'))
+  table_node <- dfs(source_node, 'table')
+  if (is.null(table_node)) {
+    stop('Did not find a HTML table tag in the provided HTML. ')
+  }
+  return(list(body=body_node, table=table_node))
 }
 
 get_xml_text <- function(xml_node) {