Change htmlTable_styling to a pipable function
diff --git a/R/htmlTable_styling.R b/R/htmlTable_styling.R
index 98da798..dcd0c96 100644
--- a/R/htmlTable_styling.R
+++ b/R/htmlTable_styling.R
@@ -1,12 +1,13 @@
#' HTML table attributes
#'
-#' @description This function provides a set of shortcuts to common HTML table
-#' formats
+#' @description This function provides a cleaner approach to modify the style
+#' of HTML tables other than using the `table.attr` option in `knitr::kable()`.
+#' Currenly, it assumes the HTML document has boot
#'
#' @param bootstrap_options A character vector for bootstrap table options. For
#' detailed information, please check the package vignette or visit the
#' w3schools' \href{https://www.w3schools.com/bootstrap/bootstrap_tables.asp}{Bootstrap Page}
-#' . Possible options include "bs-table", "striped", "bordered", "hover",
+#' . Possible options include "basic", "striped", "bordered", "hover",
#' "condensed" and "responsive".
#' @param full_width A `TRUE` or `FALSE` variable controlling whether the HTML
#' table should have 100\% width.
@@ -15,47 +16,59 @@
#' @param font_size A numeric input for table font size
#'
#' @export
-htmlTable_styling <- function(bootstrap_options = "bs-table",
- full_width = T,
- float = c("center", "left", "right"),
- font_size = NULL) {
+htmlTable_styling <- function(kable_input,
+ bootstrap_options = "basic",
+ full_width = T,
+ float = c("center", "left", "right"),
+ font_size = NULL) {
+ kable_xml <- read_xml(as.character(kable_input), options = c("COMPACT"))
+
+ # Modify class
bootstrap_options <- match.arg(
bootstrap_options,
- c("bs-table", "striped", "bordered", "hover", "condensed", "responsive"),
+ c("basic", "striped", "bordered", "hover", "condensed", "responsive"),
several.ok = T
)
- table_attr_class <- character()
- if (length(bootstrap_options) == 1 && bootstrap_options == "bs-table") {
- table_attr_class <- "class='table'"
- } else {
- bootstrap_options <- bootstrap_options[bootstrap_options != "bs-table"]
- bootstrap_options <- paste0("table-", bootstrap_options)
- table_attr_class <- paste0("class='table ",
- paste0(bootstrap_options, collapse = " "), "'")
+ kable_xml_class <- NULL
+ if (xml_has_attr(kable_xml, "class")) {
+ kable_xml_class <- xml_attr(kable_xml, "class")
}
+ if (length(bootstrap_options) == 1 && bootstrap_options == "basic") {
+ bootstrap_options <- "table"
+ } else {
+ bootstrap_options <- bootstrap_options[bootstrap_options != "basic"]
+ bootstrap_options <- paste0("table-", bootstrap_options)
+ bootstrap_options <- c("table", bootstrap_options)
+ }
+ xml_attr(kable_xml, "class") <- paste(c(kable_xml_class, bootstrap_options),
+ collapse = " ")
- table_attr_style <- c()
+ # Modify style
+ kable_xml_style <- NULL
+ if (xml_has_attr(kable_xml, "style")) {
+ kable_xml_style <- xml_attr(kable_xml, "style")
+ }
if (!is.null(font_size)) {
- table_attr_style <- c(table_attr_style,
+ kable_xml_style <- c(kable_xml_style,
paste0("font-size: ", font_size, "px;"))
}
if (!full_width) {
- table_attr_style <- c(table_attr_style, "width: auto !important;")
+ kable_xml_style <- c(kable_xml_style, "width: auto !important;")
}
float <- match.arg(float)
if (float == "center") {
- table_attr_style <- c(table_attr_style,
+ kable_xml_style <- c(kable_xml_style,
"margin-left:auto; margin-right:auto;")
}
if (float == "right") {
- table_attr_style <- c(table_attr_style,
+ kable_xml_style <- c(kable_xml_style,
"float: right;")
}
- if (length(table_attr_style) != 0) {
- table_attr_style <- paste0("style = '",
- paste0(table_attr_style, collapse = " "), "'")
+ if (length(kable_xml_style) != 0) {
+ xml_attr(kable_xml, "style") <- paste(kable_xml_style, collapse = " ")
}
- return(paste(table_attr_class, table_attr_style))
+ return(structure(as.character(kable_xml), format = "html",
+ class = "knitr_kable"))
}
diff --git a/R/html_add_header_above.R b/R/html_add_header_above.R
new file mode 100644
index 0000000..3acb2e1
--- /dev/null
+++ b/R/html_add_header_above.R
@@ -0,0 +1,16 @@
+#' 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)
+ kable_xml <- read_xml(as.character(kable_input), options = c("COMPACT"))
+ kable_xml_thead <- xml_child(kable_xml, "thead")
+
+
+ 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]]
+
+
+}
diff --git a/R/kableExtra-package.R b/R/kableExtra-package.R
index b87d0cc..cd0bbe8 100644
--- a/R/kableExtra-package.R
+++ b/R/kableExtra-package.R
@@ -1,8 +1,14 @@
#' kableExtra
#'
#' @importFrom stringr str_count
+#' @importFrom xml2 read_xml xml_attr xml_has_attr xml_attr<- read_html
+#' @importFrom rvest html_table
+#' @importFrom knitr kable
#' @name kableExtra-package
#' @aliases kableExtra
#' @docType package
#' @keywords package
NULL
+
+#' @export
+magrittr::`%>%`
diff --git a/R/magic_mirror.R b/R/magic_mirror.R
index 9995180..6502296 100644
--- a/R/magic_mirror.R
+++ b/R/magic_mirror.R
@@ -1,7 +1,6 @@
#' Magic mirror that returns kable's attributes
#'
#' @param input The output of kable
-#' @importFrom knitr kable
#' @import stringr
#' @export
@@ -62,13 +61,11 @@
#' Magic Mirror for html table --------
#'
#' @param input The output of kable
-#'
-#' @importFrom XML readHTMLTable
magic_mirror_html <- function(input){
kable_info <- list(table.attr = NULL, align = NULL,
ncol=NULL, nrow=NULL, colnames = NULL, rownames = NULL,
caption = NULL, contents = NULL)
- kable_data <- readHTMLTable(input[1])
+ kable_data <- html_table(read_html(input))
# Caption
kable_info$caption <- names(kable_data)
# Contents
@@ -98,6 +95,5 @@
return(kable_info)
}
-#' @export
-magrittr::`%>%`
+