| #' HTML table attributes |
| #' |
| #' @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 "basic", "striped", "bordered", "hover", |
| #' "condensed" and "responsive". |
| #' @param full_width A `TRUE` or `FALSE` variable controlling whether the HTML |
| #' table should have 100\% width. |
| #' @param position A character string determining whether and how the HTML table |
| #' should float on the page. Values could be "left", "center", "right" |
| #' @param font_size A numeric input for table font size |
| #' |
| #' @export |
| kable_styling <- function(kable_input, |
| bootstrap_options = "basic", |
| latex_options = "basic", |
| full_width = NULL, |
| position = c("center", "left", "right", |
| "float_left", "float_right"), |
| font_size = NULL) { |
| 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") { |
| if (is.null(full_width)) full_width <- T |
| return(htmlTable_styling(kable_input, |
| bootstrap_options = bootstrap_options, |
| full_width = full_width, |
| position = position, |
| font_size = font_size)) |
| } |
| if (kable_format == "latex") { |
| if (is.null(full_width)) full_width <- F |
| return(pdfTable_styling(kable_input, |
| latex_options = latex_options, |
| full_width = full_width, |
| position = position, |
| font_size = font_size)) |
| } |
| } |
| |
| # htmlTable Styling ------------ |
| htmlTable_styling <- function(kable_input, |
| bootstrap_options = "basic", |
| full_width = T, |
| position = c("center", "left", "right", |
| "float_left", "float_right"), |
| font_size = NULL) { |
| |
| kable_xml <- read_xml(as.character(kable_input), options = c("COMPACT")) |
| |
| # Modify class |
| bootstrap_options <- match.arg( |
| bootstrap_options, |
| c("basic", "striped", "bordered", "hover", "condensed", "responsive"), |
| several.ok = T |
| ) |
| |
| 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 = " ") |
| |
| # 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)) { |
| kable_xml_style <- c(kable_xml_style, |
| paste0("font-size: ", font_size, "px;")) |
| } |
| if (!full_width) { |
| kable_xml_style <- c(kable_xml_style, "width: auto !important;") |
| } |
| |
| position <- match.arg(position) |
| position_style <- switch( |
| position, |
| center = "margin-left: auto; margin-right: auto;", |
| left = "text-align: right;", |
| right = "margin-right: 0; margin-left: auto", |
| float_left = "float: left; margin-right: 10px;", |
| float_right = "float: right; margin-left: 10px;" |
| ) |
| kable_xml_style <- c(kable_xml_style, position_style) |
| |
| if (length(kable_xml_style) != 0) { |
| xml_attr(kable_xml, "style") <- paste(kable_xml_style, collapse = " ") |
| } |
| return(structure(as.character(kable_xml), format = "html", |
| class = "knitr_kable")) |
| } |
| |
| # LaTeX table style |
| pdfTable_styling <- function(kable_input, |
| latex_options = "basic", |
| full_width = F, |
| position = c("center", "left", "right", |
| "float_left", "float_right"), |
| font_size = NULL) { |
| |
| latex_options <- match.arg( |
| latex_options, |
| c("basic", "striped", "hold_position", "scale_down"), |
| several.ok = T |
| ) |
| |
| out <- NULL |
| out <- as.character(kable_input) |
| table_info <- magic_mirror(kable_input) |
| table_info$valign2 <- sub("\\[", "\\\\[", table_info$valign) |
| table_info$valign2 <- sub("\\]", "\\\\]", table_info$valign2) |
| table_info$valign3 <- sub("\\[", "", table_info$valign) |
| table_info$valign3 <- sub("\\]", "", table_info$valign3) |
| table_info$begin_tabular <- paste0("\\\\begin\\{", table_info$tabular, "\\}", |
| table_info$valign2) |
| table_info$end_tabular <- paste0("\\\\end\\{", table_info$tabular, "\\}") |
| |
| |
| if ("striped" %in% latex_options) { |
| out <- styling_latex_striped(out) |
| } |
| |
| # hold_position is only meaningful in a table environment |
| if ("hold_position" %in% latex_options & table_info$table_env) { |
| out <- styling_latex_hold_position(out) |
| } |
| |
| if ("scale_down" %in% latex_options) { |
| out <- styling_latex_scale_down(out, table_info) |
| } |
| |
| if (full_width) { |
| out <- styling_latex_full_width(out, table_info) |
| } |
| |
| if (!is.null(font_size)) { |
| out <- styling_latex_font_size(out, table_info, font_size) |
| } |
| |
| position <- match.arg(position) |
| out <- styling_latex_position(out, table_info, position, latex_options) |
| |
| out <- structure(out, format = "latex", class = "knitr_kable") |
| return(out) |
| } |
| |
| styling_latex_striped <- function(x) { |
| usepackage_latex("xcolor", "table") |
| paste0( |
| # gray!6 is the same as shadecolor ({RGB}{248, 248, 248}) in pdf_document |
| "\\rowcolors{2}{gray!6}{white}\n", x, "\n\\rowcolors{2}{white}{white}") |
| } |
| |
| styling_latex_hold_position <- function(x) { |
| sub("\\\\begin\\{table\\}", "\\\\begin\\{table\\}[!h]", x) |
| } |
| |
| styling_latex_scale_down <- function(x, table_info) { |
| # You cannot put longtable in a resizebox |
| # http://tex.stackexchange.com/questions/83457/how-to-resize-or-scale-a-longtable-revised |
| if (table_info$tabular == "longtable") { |
| warning("Longtable cannot be resized.") |
| return(x) |
| } |
| x <- sub(table_info$begin_tabular, |
| paste0("\\\\resizebox\\{\\\\textwidth\\}\\{\\!\\}\\{", |
| table_info$begin_tabular), |
| x) |
| sub(table_info$end_tabular, paste0(table_info$end_tabular, "\\}"), x) |
| } |
| |
| styling_latex_full_width <- function(x, table_info) { |
| size_matrix <- sapply(sapply(table_info$contents, str_split, " & "), nchar) |
| col_max_length <- apply(size_matrix, 1, max) + 4 |
| col_ratio <- round(col_max_length / sum(col_max_length), 2) |
| col_align <- paste0("p{\\\\dimexpr", col_ratio, |
| "\\\\linewidth-2\\\\tabcolsep}") |
| col_align <- paste0("{", paste(col_align, collapse = ""), "}") |
| x <- sub(paste0(table_info$begin_tabular, "\\{[^\\\\n]*\\}"), |
| table_info$begin_tabular, x) |
| sub(table_info$begin_tabular, |
| paste0(table_info$begin_tabular, col_align), x) |
| } |
| |
| styling_latex_position <- function(x, table_info, position, latex_options) { |
| hold_position <- "hold_position" %in% latex_options |
| switch( |
| position, |
| center = styling_latex_position_center(x, table_info, hold_position), |
| left = styling_latex_position_left(x, table_info), |
| right = styling_latex_position_right(x, table_info, hold_position), |
| float_left = styling_latex_position_float(x, table_info, "l"), |
| float_right = styling_latex_position_float(x, table_info, "r") |
| ) |
| } |
| |
| styling_latex_position_center <- function(x, table_info, hold_position) { |
| if (!table_info$table_env & table_info$tabular == "tabular") { |
| table_env_setup <- "\\begin{table}" |
| if (hold_position) { |
| table_env_setup <- paste0(table_env_setup, "[!h]") |
| } |
| return(paste0(table_env_setup, "\n\\centering", x, "\n\\end{table}")) |
| } |
| return(x) |
| } |
| |
| styling_latex_position_left <- function(x, table_info) { |
| if (table_info$tabular != "longtable") return(sub("\\\\centering\\n", "", x)) |
| longtable_option <- "\\[l\\]" |
| sub(paste0("\\\\begin\\{longtable\\}", table_info$valign2), |
| paste0("\\\\begin\\{longtable\\}", longtable_option), x) |
| } |
| |
| styling_latex_position_right <- function(x, table_info, hold_position) { |
| warning("Position = right is only supported for longtable in LaTeX. ", |
| "Setting back to center...") |
| styling_latex_position_center(x, table_info, hold_position) |
| } |
| |
| styling_latex_position_float <- function(x, table_info, option) { |
| if (table_info$tabular == "longtable") { |
| warning("wraptable is not supported for longtable.") |
| if (option == "l") return(styling_latex_position_left(x, table_info)) |
| if (option == "r") return(styling_latex_position_right(x, table_info, F)) |
| } |
| if (table_info$table_env) { |
| usepackage_latex("wrapfig") |
| size_matrix <- sapply(sapply(table_info$contents, str_split, " & "), nchar) |
| col_max_length <- apply(size_matrix, 1, max) + 4 |
| option <- sprintf("\\\\begin\\{wraptable\\}\\{%s\\}", option) |
| option <- paste0(option, "\\{",sum(col_max_length) * 0.15, "cm\\}") |
| x <- sub("\\\\begin\\{table\\}\\[\\!h\\]", "\\\\begin\\{table\\}", x) |
| x <- sub("\\\\begin\\{table\\}", option, x) |
| x <- sub("\\\\end\\{table\\}", "\\\\end\\{wraptable\\}", x) |
| return(x) |
| } |
| } |
| |
| styling_latex_font_size <- function(x, table_info, font_size) { |
| row_height <- font_size + 2 |
| if (table_info$tabular == "tabular" & table_info$table_env) { |
| return(sub(table_info$begin_tabular, |
| paste0("\\\\fontsize\\{", font_size, "\\}\\{", row_height, |
| "\\}\\\\selectfont\n", table_info$begin_tabular), |
| x)) |
| } |
| # For longtable and tabular without table environment. Simple wrap around |
| # fontsize is good enough |
| return(paste0( |
| "\\begingroup\\fontsize{", font_size, "}{", row_height, "}\\selectfont\n", x, |
| "\\endgroup" |
| )) |
| } |