Protect the code in case

xml_tpart() calls return NULL.  This should never happen for the "tbody"
calls, but can happen for "thead" when tables are produced from a list of dataframes.

R/add_header_above.R

@@ -140,8 +140,12 @@ htmlTable_add_header_above <- function(kable_input, header, bold, italic,
 
     # To check the number of columns in the new header, compare it to body
     kable_xml_tbody <- xml_tpart(kable_xml, 'tbody')
-    body_rows <- xml_children(kable_xml_tbody)
-    kable_ncol <- max(xml_length(body_rows))
+    if (is.null(kable_xml_tbody))
+      body_rows <- kable_ncol <- 0
+    else {
+      body_rows <- xml_children(kable_xml_tbody)
+      kable_ncol <- max(xml_length(body_rows))
+    }
   } else {
     header_rows <- xml_children(kable_xml_thead)
     bottom_header_row <- header_rows[[length(header_rows)]]

R/add_indent.R

@@ -106,7 +106,8 @@ add_indent_html <- function(kable_input, positions,
 
   kable_xml <- kable_as_xml(kable_input)
   kable_tbody <- xml_tpart(kable_xml, "tbody")
-
+  if (is.null(kable_tbody))
+    return(kable_input)
   group_header_rows <- attr(kable_input, "group_header_rows")
   if (!is.null(group_header_rows)) {
     positions <- positions_corrector(positions, group_header_rows,

R/collapse_rows.R

@@ -90,7 +90,8 @@ collapse_rows_html <- function(kable_input, columns, valign, target) {
   kable_attrs <- attributes(kable_input)
   kable_xml <- kable_as_xml(kable_input)
   kable_tbody <- xml_tpart(kable_xml, "tbody")
-
+  if (is.null(kable_tbody))
+    return(kable_input)
   kable_dt <- read_table_data_from_xml(kable_xml)
   if (is.null(columns)) {
     columns <- seq(1, ncol(kable_dt))

R/column_spec.R

@@ -122,6 +122,8 @@ column_spec_html <- function(kable_input, column, width,
   kable_attrs <- attributes(kable_input)
   kable_xml <- kable_as_xml(kable_input)
   kable_tbody <- xml_tpart(kable_xml, "tbody")
+  if (is.null(kable_tbody))
+    return(kable_input)
 
   group_header_rows <- attr(kable_input, "group_header_rows")
   all_contents_rows <- seq(1, length(xml_children(kable_tbody)))
@@ -143,39 +145,41 @@ column_spec_html <- function(kable_input, column, width,
     border_right <- T
   }
 
+  off <- 0
   if (include_thead) {
-    nrows <- length(all_contents_rows) + 1
-    off <- 1
-
-    bold <- ensure_len_html(bold, nrows, "bold")
-    italic <- ensure_len_html(italic, nrows, "italic")
-    monospace <- ensure_len_html(monospace, nrows, "monospace")
-    underline <- ensure_len_html(underline, nrows, "underline")
-    strikeout <- ensure_len_html(strikeout, nrows, "strikeout")
-    color <- ensure_len_html(color, nrows, "color")
-    background <- ensure_len_html(background, nrows,"background")
-    link <- ensure_len_html(link, nrows, "link")
-    new_tab <- ensure_len_html(new_tab, nrows, "new_tab")
-    tooltip <- ensure_len_html(tooltip, nrows, "tooltip")
-    popover <- ensure_len_html(popover, nrows, "popover")
-    image <- ensure_len_html(image, nrows, "image")
-
     kable_thead <- xml_tpart(kable_xml, "thead")
-    nrow_thead <- length(xml_children(kable_thead))
-    for (j in column) {
-      target_cell <- xml_child(xml_child(kable_thead, nrow_thead), j)
-      column_spec_html_cell(
-        target_cell, width, width_min, width_max,
-        bold[1], italic[1], monospace[1], underline[1], strikeout[1],
-        color[1], background[1], border_left, border_right,
-        border_l_css, border_r_css,
-        extra_css,
-        link[1], new_tab[1], tooltip[1], popover[1], image[1]
-      )
+    if (!is.null(kable_thead)) {
+      nrows <- length(all_contents_rows) + 1
+      off <- 1
+
+      bold <- ensure_len_html(bold, nrows, "bold")
+      italic <- ensure_len_html(italic, nrows, "italic")
+      monospace <- ensure_len_html(monospace, nrows, "monospace")
+      underline <- ensure_len_html(underline, nrows, "underline")
+      strikeout <- ensure_len_html(strikeout, nrows, "strikeout")
+      color <- ensure_len_html(color, nrows, "color")
+      background <- ensure_len_html(background, nrows,"background")
+      link <- ensure_len_html(link, nrows, "link")
+      new_tab <- ensure_len_html(new_tab, nrows, "new_tab")
+      tooltip <- ensure_len_html(tooltip, nrows, "tooltip")
+      popover <- ensure_len_html(popover, nrows, "popover")
+      image <- ensure_len_html(image, nrows, "image")
+
+      nrow_thead <- length(xml_children(kable_thead))
+      for (j in column) {
+        target_cell <- xml_child(xml_child(kable_thead, nrow_thead), j)
+        column_spec_html_cell(
+          target_cell, width, width_min, width_max,
+          bold[1], italic[1], monospace[1], underline[1], strikeout[1],
+          color[1], background[1], border_left, border_right,
+          border_l_css, border_r_css,
+          extra_css,
+          link[1], new_tab[1], tooltip[1], popover[1], image[1]
+        )
+      }
     }
   } else {
     nrows <- length(all_contents_rows)
-    off <- 0
 
     bold <- ensure_len_html(bold, nrows, "bold")
     italic <- ensure_len_html(italic, nrows, "italic")

R/group_rows.R

@@ -145,7 +145,8 @@ group_rows_html <- function(kable_input, group_label, start_row, end_row,
   kable_attrs <- attributes(kable_input)
   kable_xml <- read_kable_as_xml(kable_input)
   kable_tbody <- xml_tpart(kable_xml, "tbody")
-
+  if (is.null(kable_tbody))
+    return(kable_input)
   if (escape) {
     group_label <- escape_html(group_label)
   }

R/header_separate.R

@@ -45,6 +45,9 @@ header_separate_html <- function(kable_input, sep, ...) {
   kable_xml <- kable_as_xml(kable_input)
 
   kable_thead <- xml_tpart(kable_xml, "thead")
+  if (is.null(kable_thead))
+    return(kable_input)
+
   thead_depth <- length(xml_children(kable_thead))
 
   if (thead_depth > 1) {

R/remove_column.R

@@ -36,6 +36,8 @@ remove_column_html <- function (kable_input, columns) {
     kable_attrs <- attributes(kable_input)
     kable_xml <- kable_as_xml(kable_input)
     kable_tbody <- xml_tpart(kable_xml, "tbody")
+    if (is.null(kable_tbody))
+      return(kable_input)
     kable_thead <- xml_tpart(kable_xml, "thead")
 
     group_header_rows <- attr(kable_input, "group_header_rows")
@@ -55,11 +57,11 @@ remove_column_html <- function (kable_input, columns) {
                                                 names(collapse_matrix))))
         collapse_columns_origin <- collapse_columns
     }
-
     while (length(columns) > 0) {
-        xml2::xml_remove(xml2::xml_child(
+        if (!is.null(kable_thead))
+          xml2::xml_remove(xml2::xml_child(
             xml2::xml_child(kable_thead, xml2::xml_length(kable_thead)),
-            columns[1]))
+              columns[1]))
         if (length(collapse_columns) != 0 && collapse_columns[1] <= columns[1]){
             if (columns[1] %in% collapse_columns) {
                 column_span <- collapse_matrix[[paste0('x', columns[1])]]

R/row_spec.R

@@ -90,32 +90,39 @@ row_spec_html <- function(kable_input, row, bold, italic, monospace,
 
   if (0 %in% row) {
     kable_thead <- xml_tpart(kable_xml, "thead")
-    original_header_row <- xml_child(kable_thead, length(xml_children(kable_thead)))
-    for (theader_i in 1:length(xml_children(original_header_row))) {
-      target_header_cell <- xml_child(original_header_row, theader_i)
-      xml_cell_style(target_header_cell, bold, italic, monospace,
-                     underline, strikeout, color, background,
-                     align, font_size, angle, extra_css)
+    if (is.null(kable_thead))
+      warning("No row 0 found.")
+    else {
+      original_header_row <- xml_child(kable_thead, length(xml_children(kable_thead)))
+      for (theader_i in 1:length(xml_children(original_header_row))) {
+        target_header_cell <- xml_child(original_header_row, theader_i)
+        xml_cell_style(target_header_cell, bold, italic, monospace,
+                       underline, strikeout, color, background,
+                       align, font_size, angle, extra_css)
+      }
     }
     row <- row[row != 0]
   }
 
   if (length(row) != 0) {
     kable_tbody <- xml_tpart(kable_xml, "tbody")
+    if (is.null(kable_tbody))
+      warning("No table body found")
+    else {
+      group_header_rows <- attr(kable_input, "group_header_rows")
+      if (!is.null(group_header_rows)) {
+        row <- positions_corrector(row, group_header_rows,
+                                   length(xml_children(kable_tbody)))
+      }
 
-    group_header_rows <- attr(kable_input, "group_header_rows")
-    if (!is.null(group_header_rows)) {
-      row <- positions_corrector(row, group_header_rows,
-                                 length(xml_children(kable_tbody)))
-    }
-
-    for (j in row) {
-      target_row <- xml_child(kable_tbody, j)
-      for (i in 1:length(xml_children(target_row))) {
-        target_cell <- xml_child(target_row, i)
-        xml_cell_style(target_cell, bold, italic, monospace,
-                       underline, strikeout, color, background,
-                       align, font_size, angle, extra_css)
+      for (j in row) {
+        target_row <- xml_child(kable_tbody, j)
+        for (i in 1:length(xml_children(target_row))) {
+          target_cell <- xml_child(target_row, i)
+          xml_cell_style(target_cell, bold, italic, monospace,
+                         underline, strikeout, color, background,
+                         align, font_size, angle, extra_css)
+        }
       }
     }
   }

R/util.R

@@ -156,6 +156,8 @@ get_xml_text <- function(xml_node) {
 read_table_data_from_xml <- function(kable_xml) {
   thead <- xml_tpart(kable_xml, "thead")
   tbody <- xml_tpart(kable_xml, "tbody")
+  if (is.null(thead) || is.null(tbody))
+    return(NULL)
 
   # Header part
   n_header_rows <- xml2::xml_length(thead)