Merge branch 'master' into master
diff --git a/R/add_header_above.R b/R/add_header_above.R
index 1ff5f1e..48fbc3f 100644
--- a/R/add_header_above.R
+++ b/R/add_header_above.R
@@ -10,6 +10,10 @@
#' for a 3-column table with "title" spanning across column 2 and 3. For
#' convenience, when `colspan` equals to 1, users can drop the ` = 1` part.
#' As a result, `c(" ", "title" = 2)` is the same as `c(" " = 1, "title" = 2)`.
+#' Alternatively, a data frame with two columns can be provided: The first
+#' column should contain the header names (character vector) and the second
+#' column should contain the colspan (numeric vector). This input can be used
+#' if there are problems with unicode characters in the headers.
#' @param bold A T/F value to control whether the text should be bolded.
#' @param italic A T/F value to control whether the text should to be emphasized.
#' @param monospace A T/F value to control whether the text of the selected column
@@ -41,6 +45,8 @@
#' td cell.
#' @param include_empty Whether empty cells in HTML should also be styled.
#' Default is FALSE.
+#' @param border_left T/F option for border on the left side in latex.
+#' @param border_right T/F option for border on the right side in latex.
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' # Add a row of header with 3 columns on the top of the table. The column
@@ -54,7 +60,10 @@
align = "c", color = NULL, background = NULL,
font_size = NULL, angle = NULL,
escape = TRUE, line = TRUE, line_sep = 3,
- extra_css = NULL, include_empty = FALSE) {
+ extra_css = NULL, include_empty = FALSE,
+ border_left = FALSE, border_right = FALSE) {
+ if (is.null(header)) return(kable_input)
+
kable_format <- attr(kable_input, "format")
if (!kable_format %in% c("html", "latex")) {
warning("Please specify format in kable. kableExtra can customize either ",
@@ -62,6 +71,31 @@
"for details.")
return(kable_input)
}
+ if ((length(align) != 1L) & (length(align) != length(header))) {
+ warning("Length of align vector supplied to add_header_above must either be 1 ",
+ "or the same length as the header supplied. The length of the align ",
+ sprintf("vector supplied is %i and the header length is %i.",
+ length(align), length(header)),
+ "Using default of centering each element of row.")
+ align <- 'c'
+ }
+ if (is.null(header)) return(kable_input)
+ if (is.data.frame(header)){
+ if(ncol(header) == 2 & is.character(header[[1]]) & is.numeric(header[[2]])){
+ header <- data.frame(header = header[[1]], colspan = header[[2]],
+ stringsAsFactors = FALSE)
+ }
+ else {
+ stop("If header input is provided as a data frame instead of a named",
+ "vector it must consist of only two columns: ",
+ "The first should be a character vector with ",
+ "header names and the second should be a numeric vector with ",
+ "the number of columns the header should span.")
+ }
+ }
+ else {
+ header <- standardize_header_input(header)
+ }
if (kable_format == "html") {
return(htmlTable_add_header_above(
kable_input, header, bold, italic, monospace, underline, strikeout,
@@ -72,7 +106,8 @@
if (kable_format == "latex") {
return(pdfTable_add_header_above(
kable_input, header, bold, italic, monospace, underline, strikeout,
- align, color, background, font_size, angle, escape, line, line_sep))
+ align, color, background, font_size, angle, escape, line, line_sep,
+ border_left, border_right))
}
}
@@ -82,20 +117,30 @@
align, color, background, font_size,
angle, escape, line, line_sep,
extra_css, include_empty) {
- if (is.null(header)) return(kable_input)
kable_attrs <- attributes(kable_input)
kable_xml <- read_kable_as_xml(kable_input)
kable_xml_thead <- xml_tpart(kable_xml, "thead")
- header <- standardize_header_input(header)
-
if (escape) {
header$header <- escape_html(header$header)
}
- header_rows <- xml_children(kable_xml_thead)
- bottom_header_row <- header_rows[[length(header_rows)]]
- kable_ncol <- length(xml_children(bottom_header_row))
+ # If there is no existing header, add one
+ if (is.null(kable_xml_thead)) {
+ # Add thead node as first child
+ xml_add_child(kable_xml, 'thead', .where = 0)
+ kable_xml_thead <- xml_tpart(kable_xml, 'thead')
+
+ # 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))
+ } else {
+ header_rows <- xml_children(kable_xml_thead)
+ bottom_header_row <- header_rows[[length(header_rows)]]
+ kable_ncol <- length(xml_children(bottom_header_row))
+ }
+
if (sum(header$colspan) != kable_ncol) {
stop("The new header row you provided has a different total number of ",
"columns with the original kable output.")
@@ -103,7 +148,8 @@
new_header_row <- htmlTable_new_header_generator(
header, bold, italic, monospace, underline, strikeout, align,
- color, background, font_size, angle, line, line_sep, extra_css, include_empty
+ color, background, font_size, angle, line, line_sep, extra_css,
+ include_empty, attr(kable_input, 'lightable_class')
)
xml_add_child(kable_xml_thead, new_header_row, .where = 0)
out <- as_kable_xml(kable_xml)
@@ -129,19 +175,18 @@
header_names <- names(header)
header <- as.numeric(header)
names(header) <- header_names
- return(data.frame(header = names(header), colspan = header, row.names = NULL))
+ return(data.frame(header = names(header), colspan = header, row.names = NULL, stringsAsFactors = F))
}
htmlTable_new_header_generator <- function(header_df, bold, italic, monospace,
underline, strikeout, align,
color, background, font_size,
angle, line, line_sep, extra_css,
- include_empty) {
- if (align %in% c("l", "c", "r")) {
- align <- switch(align, r = "right", c = "center", l = "left")
- }
+ include_empty, lightable_class) {
+ align <- vapply(align, switch_align, 'x', USE.NAMES = FALSE)
+
row_style <- paste0(
- paste0("text-align: ", align, "; "),
+ "text-align: %s; ",
ifelse(bold, "font-weight: bold; ", ""),
ifelse(italic, "font-style: italic; ", ""),
ifelse(monospace, "font-family: monospace; ", ""),
@@ -149,13 +194,13 @@
ifelse(strikeout, "text-decoration: line-through; ", "")
)
if (!is.null(color)) {
- row_style <- paste0(row_style, "color: ", html_color(color), ";")
+ row_style <- paste0(row_style, "color: ", html_color(color), " !important;")
}
if (!is.null(background)) {
row_style <- paste0(
row_style,
"padding-right: 4px; padding-left: 4px; ",
- "background-color: ", html_color(background), ";"
+ "background-color: ", html_color(background), " !important;"
)
}
if (!is.null(font_size)) {
@@ -173,29 +218,52 @@
"deg); -o-transform: rotate(", angle,
"deg); transform: rotate(", angle,
"deg); display: inline-block; ")
- if (include_empty) {
- header_df$header <- paste0('<span style="', angle, '">',
- header_df$header, '</span>')
- } else {
header_df$header <- ifelse(
- trimws(header_df$header) == "",
+ trimws(header_df$header) == "" | include_empty,
header_df$header,
paste0('<span style="', angle, '">', header_df$header, '</span>')
)
+ }
+
+ if (is.null(lightable_class)) {
+ border_hidden <- 'border-bottom:hidden;'
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 1px solid #ddd; padding-bottom: 5px; ", "")
+ } else {
+ border_hidden <- ''
+ if (lightable_class %in% c("lightable-classic", "lightable-classic-2")) {
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 1px solid #111111; margin-bottom: -1px; ", "")
+ }
+ if (lightable_class %in% c("lightable-minimal")) {
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 2px solid #00000050; ", "")
+ }
+ if (lightable_class %in% c("lightable-paper")) {
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 1px solid #00000020; padding-bottom: 5px; ", "")
+ }
+ if (lightable_class %in% c("lightable-material")) {
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 1px solid #eee; padding-bottom: 16px; padding-top: 16px; height: 56px;", "")
+ }
+ if (lightable_class %in% c("lightable-material-dark")) {
+ line <- ifelse(ez_rep(line, nrow(header_df)),
+ "border-bottom: 1px solid #FFFFFF12; padding-bottom: 16px; padding-top: 16px; height: 56px;", "")
}
}
- line <- ifelse(ez_rep(line, nrow(header_df)),
- "border-bottom: 1px solid #ddd; padding-bottom: 5px; ", "")
line_sep <- ez_rep(line_sep, nrow(header_df))
line_sep <- glue::glue('padding-left:{line_sep}px;padding-right:{line_sep}px;')
+ row_style <- sprintf(row_style, align)
+
header_items <- ifelse(
- trimws(header_df$header) == "",
- paste0('<th style="border-bottom:hidden" colspan="', header_df$colspan,
+ trimws(header_df$header) == "" | include_empty,
+ paste0('<th style="empty-cells: hide;', border_hidden, '" colspan="', header_df$colspan,
'"></th>'),
paste0(
- '<th style="border-bottom:hidden; padding-bottom:0; ',
+ '<th style="', border_hidden, 'padding-bottom:0; ',
line_sep, row_style, '" colspan="',
header_df$colspan, '"><div style="', line, '">', header_df$header,
'</div></th>')
@@ -209,20 +277,38 @@
pdfTable_add_header_above <- function(kable_input, header, bold, italic,
monospace, underline, strikeout, align,
color, background, font_size, angle,
- escape, line, line_sep) {
+ escape, line, line_sep,
+ border_left, border_right) {
table_info <- magic_mirror(kable_input)
- header <- standardize_header_input(header)
+
+ if (is.data.frame(header)){
+ if(ncol(header) == 2 & is.character(header[[1]]) & is.numeric(header[[2]])){
+ header <- data.frame(header = header[[1]], colspan = header[[2]],
+ stringsAsFactors = FALSE)
+ }
+ else {
+ stop("If header input is provided as a data frame instead of a named vector ",
+ "it must consist of only two columns: ",
+ "The first should be a character vector with ",
+ "header names and the second should be a numeric vector with ",
+ "the number of columns the header should span.")
+ }
+ }
+ else {
+ header <- standardize_header_input(header)
+ }
if (escape) {
header$header <- input_escape(header$header, align)
}
- align <- match.arg(align, c("c", "l", "r"))
+ align <- vapply(align, match.arg, 'a', choices = c("l", "c", "r"))
hline_type <- switch(table_info$booktabs + 1, "\\\\hline", "\\\\toprule")
new_header_split <- pdfTable_new_header_generator(
header, table_info$booktabs, bold, italic, monospace, underline, strikeout,
- align, color, background, font_size, angle, line_sep)
+ align, color, background, font_size, angle, line_sep,
+ border_left, border_right)
if (line) {
new_header <- paste0(new_header_split[1], "\n", new_header_split[2])
} else {
@@ -254,7 +340,7 @@
bold, italic, monospace,
underline, strikeout, align,
color, background, font_size, angle,
- line_sep) {
+ line_sep, border_left, border_right) {
n <- nrow(header_df)
bold <- ez_rep(bold, n)
italic <- ez_rep(italic, n)
@@ -266,9 +352,16 @@
background <- ez_rep(background, n)
font_size <- ez_rep(font_size, n)
angle <- ez_rep(angle, n)
- if (!booktabs) {
- align[1:(nrow(header_df) - 1)] <- paste0(align, "|")
+ if (!booktabs & n != 1) {
+ align[1:(n - 1)] <- paste0(align[1:(n - 1)], "|")
}
+ if (border_left) {
+ align[1] <- paste0("|", align[1])
+ }
+ if (border_right) {
+ align[n] <- paste0(align[n], "|")
+ }
+
header <- header_df$header
colspan <- header_df$colspan
@@ -317,4 +410,10 @@
return(cline)
}
+switch_align <- function(x) {
+ if (x %in% c('l', 'c', 'r')) {
+ return(switch(x, l = 'left', c = 'center', r = 'right'))
+ }
+ return(x)
+}
diff --git a/R/add_indent.R b/R/add_indent.R
index 44ea7cd..b433d9d 100644
--- a/R/add_indent.R
+++ b/R/add_indent.R
@@ -3,13 +3,17 @@
#' @param kable_input Output of `knitr::kable()` with `format` specified
#' @param positions A vector of numeric row numbers for the rows that need to
#' be indented.
+#' @param level_of_indent a numeric value for the indent level. Default is 1.
+#' @param all_cols T/F whether to apply indentation to all columns
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' # Add indentations to the 2nd & 4th row
-#' add_indent(x, c(2, 4))
+#' add_indent(x, c(2, 4), level_of_indent = 1)
#'
#' @export
-add_indent <- function(kable_input, positions) {
+add_indent <- function(kable_input, positions,
+ level_of_indent = 1, all_cols = FALSE) {
+
if (!is.numeric(positions)) {
stop("Positions can only take numeric row numbers (excluding header rows).")
}
@@ -21,17 +25,19 @@
return(kable_input)
}
if (kable_format == "html") {
- return(add_indent_html(kable_input, positions))
+ return(add_indent_html(kable_input, positions, level_of_indent, all_cols))
}
if (kable_format == "latex") {
- return(add_indent_latex(kable_input, positions))
+ return(add_indent_latex(kable_input, positions, level_of_indent, all_cols))
}
}
# Add indentation for LaTeX
-add_indent_latex <- function(kable_input, positions) {
+add_indent_latex <- function(kable_input, positions,
+ level_of_indent = 1, all_cols = FALSE) {
table_info <- magic_mirror(kable_input)
out <- solve_enc(kable_input)
+ level_of_indent<-as.numeric(level_of_indent)
if (table_info$duplicated_rows) {
dup_fx_out <- fix_duplicated_rows_latex(out, table_info)
@@ -48,25 +54,39 @@
for (i in positions + table_info$position_offset) {
rowtext <- table_info$contents[i]
+ if (all_cols) {
+ new_rowtext <- latex_row_cells(rowtext)
+ new_rowtext <- lapply(new_rowtext, function(x) {
+ paste0("\\\\hspace\\{", level_of_indent ,"em\\}", x)
+ })
+ new_rowtext <- paste(unlist(new_rowtext), collapse = " & ")
+ } else {
+ new_rowtext <- latex_indent_unit(rowtext, level_of_indent)
+ }
out <- sub(paste0(rowtext, "(\\\\\\\\\\*?(\\[.*\\])?\n)"),
- paste0(latex_indent_unit(rowtext), "\\1"),
+ paste0(new_rowtext, "\\1"),
out, perl = TRUE)
- table_info$contents[i] <- latex_indent_unit(rowtext)
+ table_info$contents[i] <- new_rowtext
}
out <- structure(out, format = "latex", class = "knitr_kable")
attr(out, "kable_meta") <- table_info
return(out)
+
+
}
-latex_indent_unit <- function(rowtext) {
- paste0("\\\\hspace\\{1em\\}", rowtext)
+latex_indent_unit <- function(rowtext, level_of_indent) {
+ paste0("\\\\hspace\\{", level_of_indent ,"em\\}", rowtext)
}
+
+
# Add indentation for HTML
-add_indent_html <- function(kable_input, positions) {
+add_indent_html <- function(kable_input, positions,
+ level_of_indent = 1, all_cols = FALSE) {
kable_attrs <- attributes(kable_input)
- kable_xml <- read_kable_as_xml(kable_input)
+ kable_xml <- kable_as_xml(kable_input)
kable_tbody <- xml_tpart(kable_xml, "tbody")
group_header_rows <- attr(kable_input, "group_header_rows")
@@ -76,20 +96,29 @@
}
for (i in positions) {
- node_to_edit <- xml_child(xml_children(kable_tbody)[[i]], 1)
- if (!xml_has_attr(node_to_edit, "indentlevel")) {
- xml_attr(node_to_edit, "style") <- paste(
- xml_attr(node_to_edit, "style"), "padding-left: 2em;"
- )
- xml_attr(node_to_edit, "indentlevel") <- 1
+ row_to_edit = xml_children(kable_tbody)[[i]]
+ if (all_cols) {
+ target_cols = 1:xml2::xml_length(row_to_edit)
} else {
- indentLevel <- as.numeric(xml_attr(node_to_edit, "indentlevel"))
- xml_attr(node_to_edit, "style") <- sub(
- paste0("padding-left: ", indentLevel * 2, "em;"),
- paste0("padding-left: ", (indentLevel + 1) * 2, "em;"),
- xml_attr(node_to_edit, "style")
- )
- xml_attr(node_to_edit, "indentlevel") <- indentLevel + 1
+ target_cols = 1
+ }
+
+ for (j in target_cols) {
+ node_to_edit <- xml_child(row_to_edit, j)
+ if (!xml_has_attr(node_to_edit, "indentlevel")) {
+ xml_attr(node_to_edit, "style") <- paste(
+ xml_attr(node_to_edit, "style"), "padding-left: ",paste0(level_of_indent*2,"em;")
+ )
+ xml_attr(node_to_edit, "indentlevel") <- 1
+ } else {
+ indentLevel <- as.numeric(xml_attr(node_to_edit, "indentlevel"))
+ xml_attr(node_to_edit, "style") <- sub(
+ paste0("padding-left: ", indentLevel * 2, "em;"),
+ paste0("padding-left: ", (indentLevel + 1) * 2, "em;"),
+ xml_attr(node_to_edit, "style")
+ )
+ xml_attr(node_to_edit, "indentlevel") <- indentLevel + 1
+ }
}
}
out <- as_kable_xml(kable_xml)
diff --git a/R/as_image.R b/R/as_image.R
new file mode 100644
index 0000000..4b797bc
--- /dev/null
+++ b/R/as_image.R
@@ -0,0 +1,59 @@
+#' Render the table as an format-independent image and use it in rmarkdown
+#'
+#' @description This function generates a temporary png file using `save_kable`
+#' and then try to put it in an rmarkdown document using
+#' `knitr::include_graphics`.
+#'
+#' @param x kable input. Either HTML or LaTeX
+#' @param width Image width in inches. (1 inch = 2.54 cm)
+#' @param height Image height in inches. (1 inch = 2.54 cm)
+#' @param file By default, as_image saves to an temp file, which works for
+#' normal rmarkdown. However if you are using things like xaringan, which can't
+#' be a standalone html, you can specify this file be the path you need, eg.
+#' "img/something.png"
+#'
+#' @param ... Additional arguments passed to save_kable.
+#'
+#' @examples
+#' \dontrun{
+#' library(kableExtra)
+#'
+#' kable(mtcars, "latex", booktabs = T) %>%
+#' kable_styling(latex_options = c("striped", "scale_down")) %>%
+#' row_spec(1, color = "red") %>%
+#' as_image()
+#' }
+#' @export
+as_image <- function(x, width = NULL, height = NULL, file = NULL, ...) {
+ if (is.null(width) + is.null(height) == 0) {
+ message("Both width and height were defined. Use width only by default. ")
+ height <- NULL
+ }
+
+ if (is.null(file)) {
+ temp_png <- tempfile(fileext = ".png")
+ } else {
+ temp_png <- file
+ }
+
+
+ temp_img <- save_kable(x = x, file = temp_png, ...)
+
+ img_dpi <- 300
+
+ if (is.null(width) + is.null(height) <= 1 & is.null(attr(temp_img, "info"))) {
+ warning("You need to install magick in order to use width/height in ",
+ "as_image. ")
+ } else {
+ if (!is.null(width)) {
+ img_dpi <- attr(temp_img, "info")$width / width
+ }
+ if (!is.null(height)) {
+ img_dpi <- attr(temp_img, "info")$height / height
+ }
+ }
+
+ include_graphics(temp_png, dpi = img_dpi)
+}
+
+
diff --git a/R/cell_spec.R b/R/cell_spec.R
index 498cae7..8a69c1f 100644
--- a/R/cell_spec.R
+++ b/R/cell_spec.R
@@ -36,6 +36,7 @@
#' bootstrap module manually. Read the package vignette to see how.
#' @param link A vector of strings for url links. Can be used together with
#' tooltip and popover.
+#' @param new_tab T/F for whether to open up the new link in new tab.
#' @param extra_css Extra css text to be passed into the cell
#' @param escape T/F value showing whether special characters should be escaped.
#' @param background_as_tile T/F value indicating if you want to have round
@@ -52,23 +53,22 @@
color = NULL, background = NULL,
align = NULL, font_size = NULL, angle = NULL,
tooltip = NULL, popover = NULL, link = NULL,
- extra_css = NULL,
+ new_tab = FALSE, extra_css = NULL,
escape = TRUE,
background_as_tile = TRUE,
latex_background_in_cell = TRUE) {
if (missing(format) || is.null(format)) {
- format <- getOption('knitr.table.format')
+ if (knitr::is_latex_output()) {
+ format <- "latex"
+ } else {
+ format <- "html"
+ }
}
- if (is.null(format)) {
- message("Setting cell_spec format as html")
- format <- "html"
- }
-
if (tolower(format) == "html") {
return(cell_spec_html(x, bold, italic, monospace, underline, strikeout,
color, background, align, font_size, angle,
- tooltip, popover, link, extra_css,
+ tooltip, popover, link, new_tab, extra_css,
escape, background_as_tile))
}
if (tolower(format) == "latex") {
@@ -80,7 +80,7 @@
cell_spec_html <- function(x, bold, italic, monospace, underline, strikeout,
color, background, align, font_size, angle,
- tooltip, popover, link, extra_css,
+ tooltip, popover, link, new_tab, extra_css,
escape, background_as_tile) {
if (escape) x <- escape_html(x)
cell_style <- NULL
@@ -93,14 +93,15 @@
cell_style <- paste(cell_style,
ifelse(strikeout, "text-decoration: line-through;", ""))
if (!is.null(color)) {
- cell_style <- paste0(cell_style, "color: ", html_color(color), ";")
+ cell_style <- paste0(cell_style, "color: ", html_color(color),
+ " !important;")
}
if (!is.null(background)) {
cell_style <- paste0(
cell_style,
ifelse(background_as_tile, "border-radius: 4px; ", ""),
"padding-right: 4px; padding-left: 4px; ",
- "background-color: ", html_color(background), ";"
+ "background-color: ", html_color(background), " !important;"
)
}
if (!is.null(extra_css)) {
@@ -126,7 +127,12 @@
}
if (!is.null(link)) {
- x <- paste0('<a href="', link, '" style="', cell_style, '" ',
+ if (new_tab) {
+ target_blank = 'target="_blank" '
+ } else {
+ target_blank = NULL
+ }
+ x <- paste0('<a href="', link, '" style="', cell_style, '" ', target_blank,
tooltip_n_popover, '>', x, '</a>')
} else {
x <- paste0('<span style="', cell_style, '" ',
@@ -167,11 +173,11 @@
x <- sprintf(ifelse(underline, "\\underline{%s}", "%s"), x)
x <- sprintf(ifelse(strikeout, "\\sout{%s}", "%s"), x)
if (!is.null(color)) {
- color <- latex_color(color)
+ color <- latex_color(color, escape = FALSE)
x <- paste0("\\textcolor", color, "{", x, "}")
}
if (!is.null(background)) {
- background <- latex_color(background)
+ background <- latex_color(background, escape = FALSE)
background_env <- ifelse(latex_background_in_cell, "cellcolor", "colorbox")
x <- paste0("\\", background_env, background, "{", x, "}")
}
@@ -192,13 +198,13 @@
color = NULL, background = NULL,
align = NULL, font_size = NULL, angle = NULL,
tooltip = NULL, popover = NULL, link = NULL,
- extra_css = NULL,
+ new_tab = FALSE, extra_css = NULL,
escape = TRUE,
background_as_tile = TRUE,
latex_background_in_cell = FALSE) {
cell_spec(x, format, bold, italic, monospace, underline, strikeout,
color, background, align,
- font_size, angle, tooltip, popover, link,
+ font_size, angle, tooltip, popover, link, new_tab,
extra_css, escape, background_as_tile,
latex_background_in_cell)
}
diff --git a/R/collapse_rows.R b/R/collapse_rows.R
index 4ae0145..66349c8 100644
--- a/R/collapse_rows.R
+++ b/R/collapse_rows.R
@@ -7,13 +7,14 @@
#' specify column styles, you should use `column_spec` before `collapse_rows`.
#'
#' @param kable_input Output of `knitr::kable()` with `format` specified
-#' @param columns A numeric value or vector indicating in which column(s) rows
+#' @param columns A numeric value or vector indicating in which column(s) rows
#' need to be collapsed.
#' @param valign Select from "top", "middle"(default), "bottom". The reason why
#' "top" is not default is that the multirow package on CRAN win-builder is
#' not up to date.
#' @param latex_hline Option controlling the behavior of adding hlines to table.
-#' Choose from `full`, `major`, `none`, `custom`.
+#' Choose from `major`, `full`, `none`, `custom` and `linespace`. We changed the default from
+#' `full` to `major` in version 1.2.
#' @param custom_latex_hline Numeric column positions whose collapsed rows will
#' be separated by hlines.
#' @param row_group_label_position Option controlling positions of row group
@@ -23,6 +24,16 @@
#' `row_group_label_position` is `stack`
#' @param headers_to_remove Numeric column positions where headers should be
#' removed when they are stacked.
+#' @param target If multiple columns are selected to do collapsing and a target
+#' column is specified, this target column will be used to collapse other
+#' columns based on the groups of this target column.
+#' @param col_names T/F. A LaTeX specific option. If you set `col.names` be
+#' `NULL` in your `kable` call, you need to set this option false to let
+#' everything work properly.
+#' @param longtable_clean_cut T/F with default T. Multirow cell sometimes are
+#' displayed incorrectly around pagebreak. This option forces groups to cut
+#' before the end of a page. If you have a group that is longer than 1 page,
+#' you need to turn off this option.
#'
#' @examples dt <- data.frame(a = c(1, 1, 2, 2), b = c("a", "a", "a", "b"))
#' x <- knitr::kable(dt, "html")
@@ -31,11 +42,14 @@
#' @export
collapse_rows <- function(kable_input, columns = NULL,
valign = c("middle", "top", "bottom"),
- latex_hline = c("full", "major", "none", "custom"),
+ latex_hline = c("major", "full", "none", "custom"),
row_group_label_position = c('identity', 'stack'),
custom_latex_hline = NULL,
row_group_label_fonts = NULL,
- headers_to_remove = NULL) {
+ headers_to_remove = NULL,
+ target = NULL,
+ col_names = TRUE,
+ longtable_clean_cut = TRUE) {
kable_format <- attr(kable_input, "format")
if (!kable_format %in% c("html", "latex")) {
warning("Please specify format in kable. kableExtra can customize either ",
@@ -43,36 +57,45 @@
"for details.")
return(kable_input)
}
- valign <- match.arg(valign, c("middle", "top", "bottom"))
+ valign <- match.arg(valign)
+ if (!is.null(target)) {
+ if (length(target) > 1 && is.integer(target)) {
+ stop("target can only be a length 1 integer")
+ }
+ }
if (kable_format == "html") {
- return(collapse_rows_html(kable_input, columns, valign))
+ return(collapse_rows_html(kable_input, columns, valign, target))
}
if (kable_format == "latex") {
- latex_hline <- match.arg(latex_hline, c("full", "major", "none", "custom"))
+ latex_hline <- match.arg(latex_hline)
row_group_label_position <- match.arg(row_group_label_position,
c('identity', 'stack'))
return(collapse_rows_latex(kable_input, columns, latex_hline, valign,
row_group_label_position, row_group_label_fonts, custom_latex_hline,
- headers_to_remove))
+ headers_to_remove, target, col_names, longtable_clean_cut))
}
}
-collapse_rows_html <- function(kable_input, columns, valign) {
+collapse_rows_html <- function(kable_input, columns, valign, target) {
kable_attrs <- attributes(kable_input)
- kable_xml <- read_kable_as_xml(kable_input)
+ kable_xml <- kable_as_xml(kable_input)
kable_tbody <- xml_tpart(kable_xml, "tbody")
kable_dt <- rvest::html_table(xml2::read_html(as.character(kable_input)))[[1]]
if (is.null(columns)) {
columns <- seq(1, ncol(kable_dt))
}
+ if (!is.null(target)) {
+ if (!target %in% columns) {
+ stop("target has to be within the range of columns")
+ }
+ }
if (!is.null(kable_attrs$header_above)) {
kable_dt_col_names <- unlist(kable_dt[kable_attrs$header_above, ])
kable_dt <- kable_dt[-(1:kable_attrs$header_above),]
names(kable_dt) <- kable_dt_col_names
}
- kable_dt$row_id <- seq(nrow(kable_dt))
- collapse_matrix <- collapse_row_matrix(kable_dt, columns)
+ collapse_matrix <- collapse_row_matrix(kable_dt, columns, target = target)
for (i in 1:nrow(collapse_matrix)) {
matrix_row <- collapse_matrix[i, ]
@@ -96,31 +119,51 @@
}
out <- as_kable_xml(kable_xml)
+ kable_attrs$collapse_matrix <- collapse_matrix
attributes(out) <- kable_attrs
if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
return(out)
}
-collapse_row_matrix <- function(kable_dt, columns, html = T) {
+split_factor <- function(x) {
+ group_idx <- seq(1, length(x))
+ return(factor(unlist(lapply(group_idx, function(i) {rep(i, x[i])}))))
+}
+
+collapse_row_matrix <- function(kable_dt, columns, html = T, target = NULL) {
if (html) {
column_block <- function(x) c(x, rep(0, x - 1))
} else {
column_block <- function(x) c(rep(0, x - 1), x)
}
mapping_matrix <- list()
- for (i in columns) {
- mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
- rle(kable_dt[, i])$lengths, column_block))
+ if (is.null(target)) {
+ for (i in columns) {
+ mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
+ rle(kable_dt[, i])$lengths, column_block))
+ }
+ } else {
+ target_group = split_factor(rle(kable_dt[, target])$lengths)
+ for (i in columns) {
+ column_split = split(kable_dt[, i], target_group)
+ mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
+ column_split, function(sp) {
+ lapply(rle(sp)$length, column_block)
+ }))
+ }
}
+
mapping_matrix <- data.frame(mapping_matrix)
return(mapping_matrix)
}
collapse_rows_latex <- function(kable_input, columns, latex_hline, valign,
row_group_label_position, row_group_label_fonts,
- custom_latex_hline, headers_to_remove) {
+ custom_latex_hline, headers_to_remove, target,
+ col_names, longtable_clean_cut) {
table_info <- magic_mirror(kable_input)
out <- solve_enc(kable_input)
+ out <- gsub("\\\\addlinespace\n", "", out)
valign <- switch(
valign,
@@ -134,10 +177,12 @@
}
contents <- table_info$contents
- kable_dt <- kable_dt_latex(contents)
+ kable_dt <- kable_dt_latex(contents, col_names)
- collapse_matrix_rev <- collapse_row_matrix(kable_dt, columns, html = TRUE)
- collapse_matrix <- collapse_row_matrix(kable_dt, columns, html = FALSE)
+ collapse_matrix_rev <- collapse_row_matrix(kable_dt, columns, html = TRUE,
+ target)
+ collapse_matrix <- collapse_row_matrix(kable_dt, columns, html = FALSE,
+ target)
new_kable_dt <- kable_dt
for (j in seq_along(columns)) {
@@ -160,7 +205,7 @@
}
midrule_matrix <- collapse_row_matrix(kable_dt, seq(1, table_info$ncol),
- html = F)
+ html = FALSE, target)
midrule_matrix[setdiff(seq(1, table_info$ncol), columns)] <- 1
ex_bottom <- length(contents) - 1
@@ -191,8 +236,13 @@
row_midrule <- switch(
latex_hline,
"none" = "",
- "full" = midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
- table_info$booktabs),
+ "full" = ifelse(
+ sum(as.numeric(midrule_matrix[i, ]) > 0) == ncol(midrule_matrix),
+ midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
+ table_info$booktabs),
+ midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
+ FALSE)
+ ),
"major" = ifelse(
sum(as.numeric(midrule_matrix[i, ]) > 0) == ncol(midrule_matrix),
midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
@@ -204,16 +254,36 @@
midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
table_info$booktabs),
""
- )
+ ),
+ "linespace"= ifelse(
+ sum(as.numeric(midrule_matrix[i, ]) > 0) == ncol(midrule_matrix),
+ "\\\\addlinespace\n",
+ ""
+ )
)
new_contents[i] <- paste0(new_contents[i], "\\\\\\\\\n", row_midrule)
}
- out <- sub(contents[i + 1], new_contents[i], out)
+ out <- sub(contents[i + 1], new_contents[i], out, perl=TRUE)
}
- out <- gsub("\\\\addlinespace\n", "", out)
+ if (table_info$tabular == "longtable" & longtable_clean_cut) {
+ if (max(collapse_matrix) > 50) {
+ warning("It seems that you have a group larger than 50 rows and span ",
+ "over a page. You probably want to set longtable_clean_cut to ",
+ "be FALSE.")
+ }
+ if (latex_hline == "full") {
+ warning("kableExtra 1.2 adds a clean_cut feature to provide better page",
+ " breaking in collapse_rows. It only works when latex_hline = ",
+ "'major'. It looks like you have longtable_clean_cut = T while ",
+ "latex_hline = 'full'. Please change either one of them.")
+ }
+ out <- gsub("\\\\\\\\($|\n)", "\\\\\\\\\\\\nopagebreak\\1", out)
+ out <- gsub("(\\\\cmidrule[{][^}]*[}])", "\\1\\\\pagebreak[0]", out)
+ }
out <- structure(out, format = "latex", class = "knitr_kable")
table_info$collapse_rows <- TRUE
+ table_info$collapse_matrix <- collapse_matrix
attr(out, "kable_meta") <- table_info
if(row_group_label_position == 'stack'){
group_row_index_list <- collapse_rows_index(kable_dt, head(columns, -1))
@@ -222,8 +292,11 @@
return(out)
}
-kable_dt_latex <- function(x) {
- data.frame(do.call(rbind, str_split(x[-1], " & ")), stringsAsFactors = FALSE)
+kable_dt_latex <- function(x, col_names) {
+ if (col_names) {
+ x <- x[-1]
+ }
+ data.frame(do.call(rbind, str_split(x, " & ")), stringsAsFactors = FALSE)
}
collapse_new_dt_item <- function(x, span, width = NULL, align, valign) {
@@ -256,6 +329,16 @@
return(out)
}
+linespace_groups <- function(x) {
+ diffs <- c(1, diff(x))
+ start_indexes <- c(1, which(diffs > 1))
+ end_indexes <- c(start_indexes - 1, length(x))
+ ranges <- paste0(x[start_indexes], "-", x[end_indexes])
+ out <- paste0("\\\\addlinespace")
+ out <- paste0(out, collapse = "\n")
+ return(out)
+}
+
collapse_rows_index <- function(kable_dt, columns) {
format_to_row_index <- function(x){
diff --git a/R/column_spec.R b/R/column_spec.R
index ae9edff..bd9a425 100644
--- a/R/column_spec.R
+++ b/R/column_spec.R
@@ -7,19 +7,19 @@
#' @param column A numeric value or vector indicating which column(s) to be selected.
#' @param width A character string telling HTML & LaTeX how wide the column
#' needs to be, e.g. "10cm", "3in" or "30em".
-#' @param bold A T/F value to control whether the text of the selected column
-#' need to be bolded.
-#' @param italic A T/F value to control whether the text of the selected column
-#' need to be emphasized.
-#' @param monospace A T/F value to control whether the text of the selected column
-#' need to be monospaced (verbatim)
-#' @param underline A T/F value to control whether the text of the selected row
-#' need to be underlined
-#' @param strikeout A T/F value to control whether the text of the selected row
-#' need to be stricked out.
-#' @param color A character string for column text color. Here please pay
-#' attention to the differences in color codes between HTML and LaTeX.
-#' @param background A character string for column background color. Here please
+#' @param bold T/F value or vector to control whether the text of the selected
+#' column need to be bolded.
+#' @param italic T/F value or vector to control whether the text of the
+#' selected column need to be emphasized.
+#' @param monospace T/F value or vector to control whether the text of the
+#' selected column need to be monospaced (verbatim)
+#' @param underline T/F value or vector to control whether the text of the
+#' selected row need to be underlined
+#' @param strikeout T/F value or vector to control whether the text of the
+#' selected row need to be striked out.
+#' @param color A character string or vector for column text color. Here please
+#' pay attention to the differences in color codes between HTML and LaTeX.
+#' @param background A character string or vector for column background color. Here please
#' pay attention to the differences in color codes between HTML and LaTeX.
#' @param border_left A logical variable indicating whether there should be a
#' border line on the left of the selected column. In HTML, you can also pass
@@ -33,14 +33,33 @@
#' window is not wide enough.
#' @param width_max Only for HTML table. `width_max` defines the maximum width
#' of table columns.
-#' @param extra_css Extra css text to be passed into the cells of the row. Note
-#' that it's not for the whole column but to each individual cells
+#' @param extra_css A vector of extra css text to be passed into the cells of
+#' the column.
#' @param include_thead T/F. A HTML only feature to contoll whether the
#' header row will be manipulated. Default is `FALSE`.
+#' @param latex_column_spec Only for LaTeX tables. Code to replace the column
+#' specification. If not `NULL`, will override all other arguments.
+#' @param latex_valign vertical alignment. Only works when you specified column
+#' width. Choose among `p`, `m`, `b`.
+#' @param link A vector of strings for url links.
+#' @param new_tab T/F for whether to open up the new link in new tab
+#' @param tooltip A vector of strings to be displayed as tooltip.
+#' Obviously, this feature is only available in HTML. Read the package
+#' vignette to see how to use bootstrap tooltip css to improve the loading
+#' speed and look.
+#' @param popover Similar with tooltip but can hold more contents. The best way
+#' to build a popover is through `spec_popover()`. If you only provide a text
+#' string, it will be used as content. Note that You have to enable this
+#' bootstrap module manually. Read the package vignette to see how.
+#'
+#' @details Use `latex_column_spec` in a LaTeX table to change or
+#' customize the column specification. Because of the way it is handled
+#' internally, any backslashes must be escaped.
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' column_spec(x, 1:2, width = "20em", bold = TRUE, italic = TRUE)
-#'
+#' x <- knitr::kable(head(mtcars), "latex", booktabs = TRUE)
+#' column_spec(x, 1, latex_column_spec = ">{\\\\color{red}}c")
#' @export
column_spec <- function(kable_input, column,
width = NULL, bold = FALSE, italic = FALSE,
@@ -48,7 +67,10 @@
color = NULL, background = NULL,
border_left = FALSE, border_right = FALSE,
width_min = NULL, width_max = NULL,
- extra_css = NULL, include_thead = FALSE) {
+ extra_css = NULL, include_thead = FALSE,
+ latex_column_spec = NULL, latex_valign = 'p',
+ link = NULL, new_tab = TRUE,
+ tooltip = NULL, popover = NULL) {
if (!is.numeric(column)) {
stop("column must be numeric. ")
}
@@ -66,14 +88,17 @@
color, background,
border_left, border_right,
width_min, width_max,
- extra_css, include_thead))
+ extra_css, include_thead,
+ link, new_tab, tooltip, popover))
}
if (kable_format == "latex") {
return(column_spec_latex(kable_input, column, width,
bold, italic, monospace,
underline, strikeout,
color, background,
- border_left, border_right))
+ border_left, border_right,
+ latex_column_spec, latex_valign, include_thead,
+ link))
}
}
@@ -83,7 +108,8 @@
color, background,
border_left, border_right,
width_min, width_max,
- extra_css, include_thead) {
+ extra_css, include_thead,
+ link, new_tab, tooltip, popover) {
kable_attrs <- attributes(kable_input)
kable_xml <- read_kable_as_xml(kable_input)
kable_tbody <- xml_tpart(kable_xml, "tbody")
@@ -108,19 +134,6 @@
border_right <- T
}
- for (i in all_contents_rows) {
- for (j in column) {
- target_cell <- xml_child(xml_child(kable_tbody, i), j)
- column_spec_html_cell(
- target_cell, width, width_min, width_max,
- bold, italic, monospace, underline, strikeout,
- color, background, border_left, border_right,
- border_l_css, border_r_css,
- extra_css
- )
- }
- }
-
if (include_thead) {
kable_thead <- xml_tpart(kable_xml, "thead")
nrow_thead <- length(xml_children(kable_thead))
@@ -128,10 +141,39 @@
target_cell <- xml_child(xml_child(kable_thead, nrow_thead), j)
column_spec_html_cell(
target_cell, width, width_min, width_max,
- bold, italic, monospace, underline, strikeout,
- color, background, border_left, border_right,
+ 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
+ extra_css[1], link[1], new_tab[1], tooltip[1], popover[1]
+ )
+ }
+ }
+
+ nrows <- length(all_contents_rows)
+ off <- 0
+
+ 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")
+
+ for (i in all_contents_rows) {
+ for (j in column) {
+ target_cell <- xml_child(xml_child(kable_tbody, i), j)
+ column_spec_html_cell(
+ target_cell, width, width_min, width_max,
+ bold[i], italic[i], monospace[i], underline[i], strikeout[i],
+ color[i], background[i], border_left, border_right,
+ border_l_css, border_r_css,
+ extra_css,
+ link[i], new_tab[i], tooltip[i], popover[i]
)
}
}
@@ -142,12 +184,22 @@
return(out)
}
+ensure_len_html <- function(x, l, name) {
+ if (is.null(x)) return(NULL)
+ if (length(x) == 1) return(rep(x, l))
+ if (length(x) == l) return(x)
+ warning("The number of provided values in ", name, " does not equal to the ",
+ "number of rows. ")
+ return(rep(x, ceiling(l / length(x)))[seq(1, l)])
+}
+
column_spec_html_cell <- function(target_cell, width, width_min, width_max,
bold, italic, monospace, underline, strikeout,
color, background,
border_left, border_right,
border_l_css, border_r_css,
- extra_css) {
+ extra_css,
+ link, new_tab, tooltip, popover) {
if (is.na(xml_attr(target_cell, "style"))) {
xml_attr(target_cell, "style") <- ""
}
@@ -185,12 +237,14 @@
}
if (!is.null(color)) {
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
- "color: ", color, ";")
+ "color: ", html_color(color),
+ " !important;")
}
if (!is.null(background)) {
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
"background-color: ",
- background, ";")
+ html_color(background),
+ " !important;")
}
if (border_left) {
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
@@ -204,33 +258,86 @@
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
extra_css)
}
+
+ # favor popover over tooltip
+ if (!is.null(popover)) {
+ if (class(popover) != "ke_popover") popover <- spec_popover(popover)
+ popover_list <- attr(popover, 'list')
+ for (p in names(popover_list)) {
+ xml_attr(target_cell, p) <- popover_list[p]
+ }
+ } else if (!is.null(tooltip)) {
+ if (class(tooltip) != "ke_tooltip") tooltip <- spec_tooltip(tooltip)
+ tooltip_list <- attr(tooltip, 'list')
+ for (t in names(tooltip_list)) {
+ xml_attr(target_cell, t) <- tooltip_list[t]
+ }
+ }
+ # if (!is.null(popover)) {
+ # if (class(popover) != "ke_popover") popover <- spec_popover(popover)
+ # popover_list <- attr(popover, 'list')
+ # span_node <- xml2::read_xml(paste0(
+ # '<span>', xml_text(target_cell), '</span>'
+ # ))
+ # for (p in names(popover_list)) {
+ # xml_attr(span_node, p) <- popover_list[p]
+ # }
+ # xml_add_child(target_cell, span_node)
+ # xml_text(target_cell) <- ""
+ # } else if (!is.null(tooltip)) {
+ # if (class(tooltip) != "ke_tooltip") tooltip <- spec_tooltip(tooltip)
+ # tooltip_list <- attr(tooltip, 'list')
+ # span_node <- xml2::read_xml(paste0(
+ # '<span>', xml_text(target_cell), '</span>'
+ # ))
+ # for (t in names(tooltip_list)) {
+ # xml_attr(span_node, t) <- tooltip_list[t]
+ # }
+ # xml_add_child(target_cell, span_node)
+ # xml_text(target_cell) <- ""
+ # }
+
+ if (!is.null(link)) {
+ href_node <- xml2::read_xml(paste0(
+ '<a href="', link, '">', xml_text(target_cell), '</a>'
+ ))
+ if (!is.null(color)) {
+ xml_attr(href_node, "style") <- paste0("color: ", html_color(color),
+ " !important;")
+ }
+ xml_add_child(target_cell, href_node)
+ xml_text(target_cell) <- ""
+ }
}
column_spec_latex <- function(kable_input, column, width,
bold, italic, monospace,
underline, strikeout,
color, background,
- border_left, border_right) {
+ border_left, border_right,
+ latex_column_spec, latex_valign, include_thead,
+ link) {
table_info <- magic_mirror(kable_input)
if (!is.null(table_info$collapse_rows)) {
message("Usually it is recommended to use column_spec before collapse_rows,",
" especially in LaTeX, to get a desired result. ")
}
- align_collapse <- ifelse(table_info$booktabs, "", "\\|")
+ align_collapse <- ifelse(table_info$booktabs | !is.null(table_info$xtable),
+ "", "\\|")
kable_align_old <- paste(table_info$align_vector, collapse = align_collapse)
table_info$align_vector[column] <- unlist(lapply(
table_info$align_vector_origin[column],
function(x) {
latex_column_align_builder(
- x, width, bold, italic, monospace, underline, strikeout,
- color, background, border_left, border_right)
+ x, width, border_left, border_right, latex_column_spec, latex_valign)
}
))
kable_align_new <- paste(table_info$align_vector, collapse = align_collapse)
- out <- sub(kable_align_old, kable_align_new,
+ out <- sub(paste0("\\{", kable_align_old, "\\}"),
+ paste0("\\{", kable_align_new, "\\}"),
solve_enc(kable_input),
perl = T)
@@ -240,6 +347,49 @@
table_info <- fix_newline[[2]]
}
+ if (table_info$duplicated_rows) {
+ dup_fx_out <- fix_duplicated_rows_latex(out, table_info)
+ out <- dup_fx_out[[1]]
+ table_info <- dup_fx_out[[2]]
+ }
+
+ nrows <- length(table_info$contents)
+ off <- table_info$position_offset
+
+ bold <- ensure_len_latex(bold, nrows, off, include_thead, FALSE, "bold")
+ italic <- ensure_len_latex(italic, nrows, off, include_thead, FALSE, "italic")
+ monospace <- ensure_len_latex(monospace, nrows, off, include_thead, FALSE,
+ "monospace")
+ underline <- ensure_len_latex(underline, nrows, off, include_thead, FALSE,
+ "underline")
+ strikeout <- ensure_len_latex(strikeout, nrows, off, include_thead, FALSE,
+ "strikeout")
+ color <- ensure_len_latex(color, nrows, off, include_thead, "black", "color")
+ background <- ensure_len_latex(background, nrows, off, include_thead, "white",
+ "background")
+ link <- ensure_len_latex(link, nrows, off, include_thead, "#", "link")
+
+ if (include_thead) {
+ rows <- seq(1, nrows)
+ } else {
+ rows <- seq(1 + off, nrows)
+ }
+
+ for (i in rows) {
+ target_row <- table_info$contents[i]
+ new_row <- latex_cell_builder(
+ target_row, column, table_info,
+ bold[i], italic[i], monospace[i], underline[i],
+ strikeout[i], color[i], background[i], link[i]
+ # font_size, angle
+ )
+ temp_sub <- ifelse(i == 1 & (table_info$tabular == "longtable" |
+ !is.null(table_info$repeat_header_latex)),
+ gsub, sub)
+ out <- temp_sub(target_row, new_row, out, perl = T)
+ table_info$contents[i] <- new_row
+ }
+
out <- structure(out, format = "latex", class = "knitr_kable")
if (!is.null(width)) {
if (is.null(table_info$column_width)) {
@@ -253,42 +403,59 @@
return(out)
}
-latex_column_align_builder <- function(x, width, bold, italic, monospace,
- underline, strikeout,
- color, background,
- border_left, border_right) {
+ensure_len_latex <- function(x, l, off, include_thead, def, name) {
+ if (is.null(x)) return(NULL)
+ if (length(x) == 1) return(rep(x, l))
+ if (include_thead) {
+ if (length(x) == l) return(x)
+ warning("The number of provided values in ", name, " does not equal to the ",
+ "number of rows. ")
+ return(rep(x, ceiling(l / length(x)))[seq(1, l)])
+ } else {
+ l_ = l - off
+ if (length(x) == l_) return(c(def, x))
+ warning("The number of provided values in ", name, " does not equal to the ",
+ "number of rows. ")
+ return(c(def, rep(x, ceiling(l_ / length(x)))[seq(1, l_)]))
+ }
+}
+
+latex_column_align_builder <- function(x, width,
+ border_left, border_right,
+ latex_column_spec, latex_valign) {
extra_align <- ""
if (!is.null(width)) {
extra_align <- switch(x,
"l" = "\\\\raggedright\\\\arraybackslash",
"c" = "\\\\centering\\\\arraybackslash",
"r" = "\\\\raggedleft\\\\arraybackslash")
- x <- paste0("p\\{", width, "\\}")
+ x <- paste0(latex_valign, "\\{", width, "\\}")
}
-
- if (!is.null(color)) {
- color <- paste0("\\\\leavevmode\\\\color", latex_color(color))
- }
-
- if (!is.null(background)) {
- background <- paste0("\\\\columncolor", latex_color(background))
- }
-
- latex_array_options <- c("\\\\bfseries", "\\\\em", "\\\\ttfamily",
- "\\\\underline", "\\\\sout")[
- c(bold, italic, monospace, underline, strikeout)]
- latex_array_options <- c(latex_array_options, extra_align,
- color, background)
- latex_array_options <- paste0(
- "\\>\\{", paste(latex_array_options, collapse = ""), "\\}"
- )
- x <- paste0(latex_array_options, x)
+ # if (!is.null(color)) {
+ # color <- paste0("\\\\leavevmode\\\\color", latex_color(color))
+ # }
+ #
+ # if (!is.null(background)) {
+ # background <- paste0("\\\\columncolor", latex_color(background))
+ # }
+ #
+ # latex_array_options <- c("\\\\bfseries", "\\\\em", "\\\\ttfamily",
+ # "\\\\underline", "\\\\sout")[
+ # c(bold, italic, monospace, underline, strikeout)]
+ # latex_array_options <- c(latex_array_options, extra_align,
+ # color, background)
+ # latex_array_options <- paste0(
+ # "\\>\\{", paste(latex_array_options, collapse = ""), "\\}"
+ # )
+ # x <- paste0(latex_array_options, x)
if (border_left) {
x <- paste0("\\|", x)
}
if (border_right) {
x <- paste0(x, "\\|")
}
+ if (!is.null(latex_column_spec))
+ x <- latex_column_spec
return(x)
}
@@ -296,8 +463,8 @@
replace_makecell_with_newline <- function(kable_input, table_info, column) {
if (!str_detect(kable_input, "makecell")) return(list(kable_input, table_info))
contents_table <- data.frame(sapply(table_info$contents,
- function(x) {str_split(x, " \\& ")[[1]]}),
- stringsAsFactors = F)
+ function(x) {str_split(x, " \\& ")[[1]]}),
+ stringsAsFactors = F)
names(contents_table) <- paste0("x", 1:table_info$nrow)
rows_check_makecell <- str_detect(contents_table[column, ], "makecell")
if (sum(rows_check_makecell) == 0) return(list(kable_input, table_info))
@@ -325,3 +492,55 @@
return(list(kable_input, table_info))
}
+
+latex_cell_builder <- function(target_row, column, table_info,
+ bold, italic, monospace,
+ underline, strikeout,
+ color, background, link
+ # font_size, angle
+ ) {
+ new_row <- latex_row_cells(target_row)[[1]]
+ if (bold) {
+ new_row[column] <- paste0("\\\\textbf\\{", new_row[column], "\\}")
+ }
+ if (italic) {
+ new_row[column] <- paste0("\\\\em\\{", new_row[column], "\\}")
+ }
+ if (monospace) {
+ new_row[column] <- paste0("\\\\ttfamily\\{", new_row[column], "\\}")
+ }
+ if (underline) {
+ new_row[column] <- paste0("\\\\underline\\{", new_row[column], "\\}")
+ }
+ if (strikeout) {
+ new_row[column] <- paste0("\\\\sout\\{", new_row[column], "\\}")
+ }
+ if (!is.null(color)) {
+ clean_columns <- unlist(lapply(new_row[column], clear_color_latex))
+ new_row[column] <- paste0("\\\\textcolor", latex_color(color), "\\{",
+ clean_columns, "\\}")
+ }
+ # if (!is.null(font_size)) {
+ # new_row[column] <- paste0("\\\\begingroup\\\\fontsize\\{", font_size, "\\}\\{",
+ # as.numeric(font_size) + 2,
+ # "\\}\\\\selectfont ", new_row[column], "\\\\endgroup")
+ # }
+ # if (!is.null(angle)) {
+ # new_row[column] <- paste0("\\\\rotatebox\\{", angle, "\\}\\{",
+ # new_row[column], "\\}")
+ # }
+ if (!is.null(background)) {
+ clean_columns <- unlist(lapply(new_row[column], clear_color_latex, TRUE))
+ new_row[column] <- paste0("\\\\cellcolor", latex_color(background), "\\{",
+ clean_columns, "\\}")
+ }
+
+ if (!is.null(link)) {
+ new_row[column] <- paste0("\\\\href\\{", escape_latex(link), "\\}\\{",
+ new_row[column], "\\}")
+ }
+
+ new_row <- paste(new_row, collapse = " & ")
+
+ return(new_row)
+}
diff --git a/R/footnote.R b/R/footnote.R
index 61d36f4..59478c3 100644
--- a/R/footnote.R
+++ b/R/footnote.R
@@ -24,6 +24,9 @@
#' threeparttable. Threeparttable will force the width of caption and
#' footnotes be the width of the original table. It's useful when you have
#' long paragraph of footnotes.
+#' @param fixed_small_size T/F When you want to keep the footnote small after
+#' specifying large font size with the kable_styling() (e.g. ideal font for headers
+#' and table content with small font in footnotes).
#' @param general_title Section header for general footnotes. Default is
#' "Note: ".
#' @param number_title Section header for number footnotes. Default is "".
@@ -48,6 +51,7 @@
footnote_as_chunk = FALSE,
escape = TRUE,
threeparttable = FALSE,
+ fixed_small_size = FALSE,
general_title = "Note: ",
number_title = "",
alphabet_title = "",
@@ -107,7 +111,7 @@
}
if (kable_format == "latex") {
return(footnote_latex(kable_input, footnote_table, footnote_as_chunk,
- threeparttable))
+ threeparttable, fixed_small_size))
}
}
@@ -241,7 +245,7 @@
# LaTeX
footnote_latex <- function(kable_input, footnote_table, footnote_as_chunk,
- threeparttable) {
+ threeparttable, fixed_small_size) {
table_info <- magic_mirror(kable_input)
out <- solve_enc(kable_input)
@@ -252,7 +256,7 @@
out <- sub(paste0("\\\\begin\\{", table_info$tabular, "\\}"),
paste0("\\\\begin{ThreePartTable}\n\\\\begin{TableNotes}",
ifelse(footnote_as_chunk, "[para]", ""),
- "\n", footnote_text,
+ ifelse(fixed_small_size,"\n\\\\small\n","\n"), footnote_text,
"\n\\\\end{TableNotes}\n\\\\begin{",
table_info$tabular, "}"),
out)
@@ -280,7 +284,7 @@
paste0("\\\\end{", table_info$tabular,
"}\n\\\\begin{tablenotes}",
ifelse(footnote_as_chunk, "[para]", ""),
- "\n", footnote_text,
+ ifelse(fixed_small_size,"\n\\\\small\n","\n"), footnote_text,
"\n\\\\end{tablenotes}\n\\\\end{threeparttable}"),
out)
}
@@ -335,11 +339,11 @@
}
if (!ft_chunk) {
footnote_text <- paste0(
- '\\\\multicolumn{', ncol, '}{l}{', footnote_text, '}\\\\\\\\'
+ '\\\\multicolumn{', ncol, '}{l}{\\\\rule{0pt}{1em}', footnote_text, '}\\\\\\\\'
)
} else {
footnote_text <- paste0(
- '\\\\multicolumn{', ncol, '}{l}{',
+ '\\\\multicolumn{', ncol, '}{l}{\\\\rule{0pt}{1em}',
paste0(footnote_text, collapse = " "),
'}\\\\\\\\'
)
diff --git a/R/group_rows.R b/R/group_rows.R
index 5017159..f5b4864 100644
--- a/R/group_rows.R
+++ b/R/group_rows.R
@@ -23,6 +23,9 @@
#' centered on row, "r" for right justification, or "l" for left justification. Default
#' Value is "l" If using html, the alignment can be set by using the label_row_css
#' parameter.
+#' @param latex_wrap_text T/F for wrapping long text. Default is off. Whenever
+#' it is turned on, the table will take up the entire line. It's recommended
+#' to use this with full_width in kable_styling.
#' @param colnum A numeric that determines how many columns the text should span.
#' The default setting will have the text span the entire length.
#' @param bold A T/F value to control whether the text should be bolded.
@@ -32,11 +35,11 @@
#' @param hline_after A replicate of `hline.after` in xtable. It
#' addes a hline after the row
#' @param extra_latex_after Extra LaTeX text to be added after the row.
-#' @param indent A T?F value to control whether list items are indented.
+#' @param indent A T/F value to control whether list items are indented.
#'
#' @examples x <- knitr::kable(head(mtcars), "html")
#' # Put Row 2 to Row 5 into a Group and label it as "Group A"
-#' group_rows(x, "Group A", 2, 5)
+#' pack_rows(x, "Group A", 2, 5)
#'
#' @export
group_rows <- function(kable_input, group_label = NULL,
@@ -44,7 +47,9 @@
index = NULL,
label_row_css = "border-bottom: 1px solid;",
latex_gap_space = "0.3em",
- escape = TRUE, latex_align = "l", colnum = NULL,
+ escape = TRUE, latex_align = "l",
+ latex_wrap_text = FALSE,
+ colnum = NULL,
bold = TRUE,
italic = FALSE,
hline_before = FALSE,
@@ -59,29 +64,32 @@
"for details.")
return(kable_input)
}
+
if (is.null(index)) {
if (kable_format == "html") {
- if(!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
+ if (!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
use label_row_css instead.")
return(group_rows_html(kable_input, group_label, start_row, end_row,
- label_row_css, escape, colnum, indent))
+ label_row_css, escape, colnum, indent,
+ bold, italic))
}
if (kable_format == "latex") {
return(group_rows_latex(kable_input, group_label, start_row, end_row,
latex_gap_space, escape, latex_align, colnum,
bold, italic, hline_before, hline_after,
- extra_latex_after, indent))
+ extra_latex_after, indent, latex_wrap_text))
}
} else {
index <- group_row_index_translator(index)
out <- kable_input
if (kable_format == "html") {
for (i in 1:nrow(index)) {
- if(!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
+ if (!missing(latex_align)) warning("latex_align parameter is not used in HTML Mode,
use label_row_css instead.")
out <- group_rows_html(out, index$header[i],
index$start[i], index$end[i],
- label_row_css, escape, colnum, indent)
+ label_row_css, escape, colnum, indent,
+ bold, italic)
}
}
if (kable_format == "latex") {
@@ -90,7 +98,7 @@
index$start[i], index$end[i],
latex_gap_space, escape, latex_align, colnum,
bold, italic, hline_before, hline_after,
- extra_latex_after, indent)
+ extra_latex_after, indent, latex_wrap_text)
}
}
return(out)
@@ -107,7 +115,8 @@
}
group_rows_html <- function(kable_input, group_label, start_row, end_row,
- label_row_css, escape, colnum, indent) {
+ label_row_css, escape, colnum, indent,
+ bold = TRUE, italic = FALSE) {
kable_attrs <- attributes(kable_input)
kable_xml <- read_kable_as_xml(kable_input)
kable_tbody <- xml_tpart(kable_xml, "tbody")
@@ -121,6 +130,10 @@
if (!is.null(group_header_rows)) {
group_seq <- positions_corrector(group_seq, group_header_rows,
length(xml_children(kable_tbody)))
+ # Update the old group_header_rows attribute with their new positions
+ kable_attrs$group_header_rows <- ifelse(kable_attrs$group_header_rows > group_seq[1],
+ kable_attrs$group_header_rows+1,
+ kable_attrs$group_header_rows)
}
# Insert a group header row
@@ -128,11 +141,33 @@
kable_ncol <- ifelse(is.null(colnum),
length(xml_children(starting_node)),
colnum)
+
+ if (bold) group_label <- paste0("<strong>", group_label, "</strong>")
+ if (italic) group_label <- paste0("<em>", group_label, "</em>")
+
+ if (label_row_css == "border-bottom: 1px solid;") {
+ if (!is.null(attr(kable_input, "lightable_class"))) {
+ lightable_class <- attr(kable_input, "lightable_class")
+ if (lightable_class %in% c(
+ "lightable-classic", "lightable-classic-2", "lightable-minimal")) {
+ label_row_css <- "border-bottom: 0;"
+ }
+ if (lightable_class %in% c("lightable-paper")) {
+ label_row_css <- "border-bottom: 1px solid #00000020;"
+ }
+ if (lightable_class %in% c("lightable-material")) {
+ label_row_css <- "border-bottom: 1px solid #eee; "
+ }
+ if (lightable_class %in% c("lightable-material-dark")) {
+ label_row_css <- "border-bottom: 1px solid #FFFFFF12; color: #FFFFFF60;"
+ }
+ }
+ }
+
group_header_row_text <- paste0(
'<tr groupLength="', length(group_seq), '"><td colspan="', kable_ncol,
- '" style="', label_row_css, '"><strong>', group_label,
- "</strong></td></tr>"
- )
+ '" style="', label_row_css, '">', group_label, "</td></tr>")
+
group_header_row <- read_xml(group_header_row_text, options = "COMPACT")
xml_add_sibling(starting_node, group_header_row, .where = "before")
@@ -148,8 +183,8 @@
group_rows_latex <- function(kable_input, group_label, start_row, end_row,
gap_space, escape, latex_align, colnum,
- bold = T, italic = F, hline_before = F ,hline_after = F,
- extra_latex_after = NULL, indent) {
+ bold = T, italic = F, hline_before = F, hline_after = F,
+ extra_latex_after = NULL, indent, latex_wrap_text = F) {
table_info <- magic_mirror(kable_input)
out <- solve_enc(kable_input)
@@ -166,8 +201,19 @@
if (bold) {
group_label <- paste0("\\\\textbf{", group_label, "}")
}
+
if (italic) group_label <- paste0("\\\\textit{", group_label, "}")
# Add group label
+ if (latex_wrap_text) {
+ latex_align <- switch(
+ latex_align,
+ "l" = "p{\\\\linewidth}",
+ "c" = ">{\\\\centering\\\\arraybackslash}p{\\\\linewidth}",
+ "r" = ">{\\\\centering\\\\arraybackslash}p{\\\\linewidth}"
+ )
+ }
+
+
if (table_info$booktabs) {
rowtext <- table_info$contents[start_row + table_info$position_offset]
pre_rowtext <- paste0(
@@ -192,9 +238,17 @@
regex_escape(extra_latex_after, double_backslash = TRUE))
}
new_rowtext <- paste0(pre_rowtext, rowtext)
- out <- sub(paste0(rowtext, "\\\\\\\\\n"),
- paste0(new_rowtext, "\\\\\\\\\n"),
- out)
+ if (start_row + 1 == table_info$nrow &
+ !is.null(table_info$repeat_header_latex)) {
+ out <- sub(paste0(rowtext, "\\\\\\\\\\*\n"),
+ paste0(new_rowtext, "\\\\\\\\\\*\n"),
+ out)
+ } else {
+ out <- sub(paste0(rowtext, "\\\\\\\\\n"),
+ paste0(new_rowtext, "\\\\\\\\\n"),
+ out)
+ }
+
out <- gsub("\\\\addlinespace\n", "", out)
out <- structure(out, format = "latex", class = "knitr_kable")
table_info$group_rows_used <- TRUE
@@ -220,3 +274,7 @@
names(index) <- x_rle$values
return(index)
}
+
+#' @rdname group_rows
+#' @export
+pack_rows <- group_rows
diff --git a/R/kableExtra-package.R b/R/kableExtra-package.R
index a06fbcf..c01f058 100644
--- a/R/kableExtra-package.R
+++ b/R/kableExtra-package.R
@@ -55,11 +55,11 @@
#' vanilla rmarkdown. For customized rmarkdown templates, it is recommended to
#' load related LaTeX packages manually.
#'
-#' @importFrom stringr str_count str_split str_match str_detect str_match_all
+#' @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_remove write_xml xml_text<-
+#' xml_remove write_xml xml_text<- xml_length
#' @importFrom rvest html_table
#' @importFrom knitr knit_meta_add include_graphics knit_print asis_output kable
#' @importFrom rmarkdown latex_dependency html_dependency_bootstrap
@@ -75,6 +75,7 @@
#' @importFrom glue glue
#' @importFrom tools file_ext file_path_sans_ext
#' @importFrom webshot webshot
+#' @importFrom digest digest
#' @import htmltools
#' @name kableExtra-package
#' @aliases kableExtra
diff --git a/R/kable_as_image.R b/R/kable_as_image.R
index 46dbcbc..ffe18be 100644
--- a/R/kable_as_image.R
+++ b/R/kable_as_image.R
@@ -1,23 +1,6 @@
-#' Convert a LaTeX table to an image and place it in a rmarkdown document
+#' Deprecated
#'
-#' @description This is a LaTeX-only function. This function will render the
-#' raw LaTeX code (could be codes generated by other table packages like
-#' `xtable`) to generate a table, convert it to an image and put it back to a
-#' rmarkdown environment. It is a "better than nothing" solution to print high
-#' quality tables in rmarkdown Word document. By using this, you need to take
-#' the responsibility of explaining to your collaborators why they can't make
-#' edits to the tables in Word.
-#'
-#' Also, if a filename is provided, user has the option to "save" the table to
-#' an image file like `ggplot2::ggsave()`.
-#'
-#' Note that, if you are using this function on a Windows computer, you need
-#' to install Ghostscript before you can use this feature. It is essential for
-#' magick to read PDFs on Windows. Website for Ghostscript: https://ghostscript.com/
-#'
-#' The idea of this function was coming from [this StackOverflow question](https://stackoverflow.com/questions/44711313/save-rmarkdowns-report-tables-and-figures-to-file).
-#' The approach was learned and adopted from the [texpreview](https://github.com/metrumresearchgroup/texPreview)
-#' package, which allows you to preview the results of TeX code in the Viewer panel.
+#' @description deprecated
#'
#' @param kable_input Raw LaTeX code to generate a table. It doesn't have to
#' came from `kable` or `kableExtra`.
@@ -45,6 +28,8 @@
keep_pdf = FALSE,
density = 300,
keep_tex = FALSE) {
+ message('kable_as_image is deprecated. Please use save_kable or as_image ',
+ 'instead.')
if (!requireNamespace("magick", quietly = TRUE)) {
stop('kable_as_image requires the magick package, which is not available ',
'on all platforms. Please get it installed ',
diff --git a/R/kable_styling.R b/R/kable_styling.R
index b7a343b..9be4bcc 100644
--- a/R/kable_styling.R
+++ b/R/kable_styling.R
@@ -10,7 +10,7 @@
#' Please see package vignette or visit the w3schools'
#' \href{https://www.w3schools.com/bootstrap/bootstrap_tables.asp}{Bootstrap Page}
#' for more information. Possible options include `basic`, `striped`,
-#' `bordered`, `hover`, `condensed` and `responsive`.
+#' `bordered`, `hover`, `condensed`, `responsive` and `none`.
#' @param latex_options A character vector for LaTeX table options. Please see
#' package vignette for more information. Possible options include
#' `basic`, `striped`, `hold_position`, `HOLD_position`, `scale_down` & `repeat_header`.
@@ -35,24 +35,52 @@
#' a `LaTeX` table, if `float_*` is selected, `LaTeX` package `wrapfig` will be
#' imported.
#' @param font_size A numeric input for table font size
-#' @param row_label_position A character string determining the justification of the row
-#' labels in a table. Possible values inclued `l` for left, `c` for center, and `r` for
-#' right. The default value is `l` for left justifcation.
-#' @param ... extra options for HTML or LaTeX. See `details`.
-#'
-#' @details For LaTeX, extra options includes:
-#' - `repeat_header_method` can either be `append`(default) or `replace`
-#' - `repeat_header_text` is just a text string you want to append on or
-#' replace the caption.
-#' - `stripe_color` allows users to pick a different color for their strip lines.
-#' - `latex_table_env` character string to define customized table environment
-#' such as tabu or tabularx.You shouldn't expect all features could be
-#' supported in self-defined environments.
+#' @param row_label_position A character string determining the justification
+#' of the row labels in a table. Possible values inclued `l` for left, `c` for
+#' center, and `r` for right. The default value is `l` for left justifcation.
+#' @param repeat_header_text LaTeX option. A text string you want to append on
+#' or replace the caption.
+#' @param repeat_header_method LaTeX option, can either be `append`(default) or
+#' `replace`
+#' @param repeat_header_continued T/F or a text string. Whether or not to put
+#' a continued mark on the second page of longtable. If you put in text, we will
+#' use this text as the "continued" mark.
+#' @param stripe_color LaTeX option allowing users to pick a different color
+#' for their strip lines. This option is not available in HTML
+#' @param stripe_index LaTeX option allowing users to customize which rows
+#' should have stripe color.
+#' @param latex_table_env LaTeX option. A character string to define customized
+#' table environment such as tabu or tabularx.You shouldn't expect all features
+#' could be supported in self-defined environments.
+#' @param protect_latex If `TRUE`, LaTeX code embedded between dollar signs
+#' will be protected from HTML escaping.
+#' @param table.envir LaTeX floating table environment. `kable_style` will put
+#' a plain no-caption table in a `table` environment in order to center the
+#' table. You can specify this option to things like `table*` or `float*` based
+#' on your need.
+#' @param fixed_thead HTML table option so table header row is fixed at top.
+#' Values can be either T/F or `list(enabled = T/F, background = "anycolor")`.
+#' @param htmltable_class Options to use the in-house lightable themes.
+#' Choices include `lightable-minimal`, `lightable-classic`,
+#' `lightable-classic-2`, `lightable-material`, `lightable-striped` and
+#' `lightable-hover`. If you have your customized style sheet loaded which
+#' defines your own table class, you can also load it here.
+#' @param html_font A string for HTML css font. For example,
+#' `html_font = '"Arial Narrow", arial, helvetica, sans-serif'`.
+#' @param wraptable_width Width of the wraptable area if you specify
+#' "float_left/right" for latex table. Default is "0pt" for automated
+#' determination but you may specify it manually.
#'
#' @details For LaTeX, if you use other than English environment
#' - all tables are converted to 'UTF-8'. If you use, for example, Hungarian
#' characters on a Windows machine, make sure to use
#' Sys.setlocale("LC_ALL","Hungarian") to avoid unexpected conversions.
+#' - `protect_latex = TRUE` has no effect.
+#'
+#' For HTML,
+#' - `protect_latex = TRUE` is for including complicated math in HTML output.
+#' The LaTeX may not include dollar signs even if they are escaped.
+#' Pandoc's rules for recognizing embedded LaTeX are used.
#'
#' @examples x_html <- knitr::kable(head(mtcars), "html")
#' kable_styling(x_html, "striped", position = "left", font_size = 7)
@@ -68,7 +96,18 @@
position = "center",
font_size = NULL,
row_label_position = "l",
- ...) {
+ repeat_header_text = "\\textit{(continued)}",
+ repeat_header_method = c("append", "replace"),
+ repeat_header_continued = FALSE,
+ stripe_color = "gray!6",
+ stripe_index = NULL,
+ latex_table_env = NULL,
+ protect_latex = TRUE,
+ table.envir = "table",
+ fixed_thead = FALSE,
+ htmltable_class = NULL,
+ html_font = NULL,
+ wraptable_width = '0pt') {
if (length(bootstrap_options) == 1 && bootstrap_options == "basic") {
bootstrap_options <- getOption("kable_styling_bootstrap_options", "basic")
@@ -97,43 +136,87 @@
if (is.null(full_width)) {
full_width <- getOption("kable_styling_full_width", T)
}
- if(!missing(row_label_position)) {
- warning("'row_label_position' is not active for HTML tables yet and parameter will not be used.")
- }
return(htmlTable_styling(kable_input,
bootstrap_options = bootstrap_options,
full_width = full_width,
position = position,
- font_size = font_size, ...))
+ font_size = font_size,
+ protect_latex = protect_latex,
+ fixed_thead = fixed_thead,
+ htmltable_class = htmltable_class,
+ html_font = html_font))
}
if (kable_format == "latex") {
if (is.null(full_width)) {
full_width <- getOption("kable_styling_full_width", F)
}
+ repeat_header_method <- match.arg(repeat_header_method)
return(pdfTable_styling(kable_input,
latex_options = latex_options,
full_width = full_width,
position = position,
font_size = font_size,
row_label_position = row_label_position,
- ...))
+ repeat_header_text = repeat_header_text,
+ repeat_header_method = repeat_header_method,
+ repeat_header_continued = repeat_header_continued,
+ stripe_color = stripe_color,
+ stripe_index = stripe_index,
+ latex_table_env = latex_table_env,
+ table.envir = table.envir,
+ wraptable_width = wraptable_width))
}
}
+extract_latex_from_kable <- function(kable_input) {
+ kable_attrs <- attributes(kable_input)
+ regexp <- paste0("(?<!\\e)", # Not escaped
+ "([$]{1}(?![ ])[^$]+(?<![$\\\\ ])[$]{1}", # $...$
+ "|[$]{2}(?![ ])[^$]+(?<![$\\\\ ])[$]{2})", # $$...$$
+ "(?!\\d)") # Not followed by digit
+ latex <- character()
+ while (str_detect(kable_input, regexp)) {
+ block <- str_extract(kable_input, regexp)
+ name <- paste0("latex", digest(block))
+ latex[name] <- block
+ kable_input <- str_replace(kable_input, regexp, name)
+ }
+ kable_attrs$extracted_latex <- latex
+ attributes(kable_input) <- kable_attrs
+ kable_input
+}
+
+replace_latex_in_kable <- function(kable_input, latex) {
+ kable_attrs <- attributes(kable_input)
+ for (n in names(latex)) {
+ kable_input <- str_replace_all(kable_input, fixed(n), latex[n])
+ }
+ attributes(kable_input) <- kable_attrs
+ kable_input
+}
+
# 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) {
+ font_size = NULL,
+ protect_latex = TRUE,
+ fixed_thead = FALSE,
+ htmltable_class = NULL,
+ html_font = NULL) {
+ if (protect_latex) {
+ kable_input <- extract_latex_from_kable(kable_input)
+ }
kable_attrs <- attributes(kable_input)
kable_xml <- read_kable_as_xml(kable_input)
# Modify class
bootstrap_options <- match.arg(
bootstrap_options,
- c("basic", "striped", "bordered", "hover", "condensed", "responsive"),
+ c("basic", "striped", "bordered", "hover", "condensed", "responsive",
+ "none"),
several.ok = T
)
@@ -141,15 +224,24 @@
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)
+
+ if (!is.null(htmltable_class)) {
+ bootstrap_options <- "none"
+ xml_attr(kable_xml, "class") <- paste(kable_xml_class, htmltable_class)
}
- xml_attr(kable_xml, "class") <- paste(c(kable_xml_class, bootstrap_options),
- collapse = " ")
+
+ if (length(bootstrap_options) == 1 && bootstrap_options == "none") {
+ }else {
+ 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
@@ -164,6 +256,11 @@
xml_attr(kable_caption_node, "style") <- "font-size: initial !important;"
}
}
+ if (!is.null(html_font)) {
+ kable_xml_style <- c(kable_xml_style, paste0(
+ 'font-family: ', html_font, ';'
+ ))
+ }
if (!full_width) {
kable_xml_style <- c(kable_xml_style, "width: auto !important;")
}
@@ -183,25 +280,44 @@
xml_attr(kable_xml, "style") <- paste(kable_xml_style, collapse = " ")
}
+ fixed_thead <- get_fixed_thead(fixed_thead)
+ if (fixed_thead$enabled) {
+ 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))) {
+ xml_attr(all_header_cells[i], "style") <- paste0(
+ xml_attr(all_header_cells[i], "style"),
+ "position: sticky; top:0; background-color: ",
+ fixed_thead$background, ";"
+ )
+ }
+ }
+
out <- as_kable_xml(kable_xml)
+ if (protect_latex) {
+ out <- replace_latex_in_kable(out, kable_attrs$extracted_latex)
+ kable_attrs$extracted_latex <- NULL
+ }
attributes(out) <- kable_attrs
if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
return(out)
}
-# LaTeX table style
+# 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,
- repeat_header_text = "\\textit{(continued)}",
- repeat_header_method = c("append", "replace"),
- repeat_header_continued = FALSE,
- stripe_color = "gray!6",
- latex_table_env = NULL,
- row_label_position) {
+ full_width = FALSE,
+ position,
+ font_size,
+ row_label_position,
+ repeat_header_text,
+ repeat_header_method,
+ repeat_header_continued,
+ stripe_color,
+ stripe_index,
+ latex_table_env,
+ table.envir,
+ wraptable_width) {
latex_options <- match.arg(
latex_options,
@@ -209,15 +325,13 @@
several.ok = T
)
- repeat_header_method <- match.arg(repeat_header_method)
-
out <- NULL
out <- solve_enc(kable_input)
table_info <- magic_mirror(kable_input)
if ("striped" %in% latex_options) {
- out <- styling_latex_striped(out, table_info, stripe_color)
+ out <- styling_latex_striped(out, table_info, stripe_color, stripe_index)
}
# hold_position is only meaningful in a table environment
@@ -237,6 +351,7 @@
if ("repeat_header" %in% latex_options & table_info$tabular == "longtable") {
out <- styling_latex_repeat_header(out, table_info, repeat_header_text,
repeat_header_method, repeat_header_continued)
+ table_info$repeat_header_latex <- TRUE
}
if (full_width) {
@@ -260,14 +375,14 @@
table_info$end_tabular)
}
- position <- match.arg(position)
- out <- styling_latex_position(out, table_info, position, latex_options)
+ out <- styling_latex_position(out, table_info, position, latex_options,
+ table.envir, wraptable_width)
out <- structure(out, format = "latex", class = "knitr_kable")
attr(out, "kable_meta") <- table_info
if (row_label_position != "l") {
- if(table_info$tabular=="longtable") {
+ if (table_info$tabular == "longtable") {
out <- sub("\\\\begin\\{longtable\\}\\{l",
paste0("\\\\begin\\{longtable\\}\\{",
row_label_position),
@@ -283,43 +398,11 @@
return(out)
}
-styling_latex_striped <- function(x, table_info, color) {
- # gray!6 is the same as shadecolor ({RGB}{248, 248, 248}) in pdf_document
- if (table_info$tabular == "longtable" & !is.na(table_info$caption)) {
- row_color <- sprintf("\\rowcolors{%s}{white}{%s}",
- 1 + table_info$position_offset, color)
- } else {
- if (table_info$position_offset == 0) {
- row_color <- sprintf("\\rowcolors{1}{white}{%s}", color)
- } else {
- row_color <- sprintf("\\rowcolors{2}{%s}{white}", color)
- }
+styling_latex_striped <- function(x, table_info, color, stripe_index) {
+ if (is.null(stripe_index)) {
+ stripe_index <- seq(1, table_info$nrow - table_info$position_offset, 2)
}
-
- x <- read_lines(x)
- if (table_info$booktabs) {
- header_rows_start <- which(trimws(x) == "\\toprule")[1]
- if (is.null(table_info$colnames)) {
- header_rows_end <- header_rows_start
- } else {
- header_rows_end <- which(trimws(x) == "\\midrule")[1]
- }
- } else {
- header_rows_start <- which(trimws(x) == "\\hline")[1]
- header_rows_end <- which(trimws(x) == "\\hline")[2]
- }
-
- x <- c(
- row_color,
- x[1:(header_rows_start - 1)],
- "\\hiderowcolors",
- x[header_rows_start:header_rows_end],
- "\\showrowcolors",
- x[(header_rows_end + 1):length(x)],
- "\\rowcolors{2}{white}{white}"
- )
- x <- paste0(x, collapse = "\n")
- return(x)
+ row_spec(x, stripe_index, background = color)
}
styling_latex_hold_position <- function(x) {
@@ -389,7 +472,7 @@
x[index_bottomrule - 1] <- paste0(x[index_bottomrule - 1], "*")
if (repeat_header_continued == FALSE) {
- bottom_part <- "\\\n\\endfoot\n\\bottomrule\n\\endlastfoot"
+ bottom_part <- "\n\\endfoot\n\\bottomrule\n\\endlastfoot"
} else {
if (repeat_header_continued == TRUE) {
bottom_text <- "\\textit{(continued \\ldots)}"
@@ -435,22 +518,29 @@
return(list(x, col_align_vector))
}
-styling_latex_position <- function(x, table_info, position, latex_options) {
+styling_latex_position <- function(x, table_info, position, latex_options,
+ table.envir, wraptable_position) {
hold_position <- intersect(c("hold_position", "HOLD_position"), latex_options)
if (length(hold_position) == 0) hold_position <- ""
switch(
position,
- center = styling_latex_position_center(x, table_info, hold_position),
+ center = styling_latex_position_center(x, table_info, hold_position,
+ table.envir),
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")
+ right = styling_latex_position_right(x, table_info, hold_position,
+ table.envir),
+ float_left = styling_latex_position_float(x, table_info, "l", table.envir,
+ wraptable_position),
+ float_right = styling_latex_position_float(x, table_info, "r", table.envir,
+ wraptable_position)
)
}
-styling_latex_position_center <- function(x, table_info, hold_position) {
+styling_latex_position_center <- function(x, table_info, hold_position,
+ table.envir) {
if (!table_info$table_env & table_info$tabular == "tabular") {
- x <- paste0("\\begin{table}\n\\centering", x, "\n\\end{table}")
+ x <- paste0("\\begin{", table.envir, "}\n\\centering", x,
+ "\n\\end{", table.envir, "}")
if (hold_position == "hold_position") {
x <- styling_latex_hold_position(x)
} else {
@@ -467,23 +557,26 @@
paste0("\\\\begin\\{longtable\\}", longtable_option), x)
}
-styling_latex_position_right <- function(x, table_info, hold_position) {
+styling_latex_position_right <- function(x, table_info, hold_position,
+ table.envir) {
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_center(x, table_info, hold_position, table.envir)
}
-styling_latex_position_float <- function(x, table_info, option) {
+styling_latex_position_float <- function(x, table_info, option, table.envir,
+ wraptable_width) {
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 (option == "r") return(styling_latex_position_right(x, table_info, F,
+ table.envir))
}
size_matrix <- sapply(sapply(table_info$contents, str_split, " & "), nchar)
col_max_length <- apply(size_matrix, 1, max) + 4
if (table_info$table_env) {
option <- sprintf("\\\\begin\\{wraptable\\}\\{%s\\}", option)
- option <- paste0(option, "\\{0pt\\}")
+ option <- paste0(option, "\\{", wraptable_width, "\\}")
x <- sub("\\\\begin\\{table\\}\\[\\!h\\]", "\\\\begin\\{table\\}", x)
x <- sub("\\\\begin\\{table\\}", option, x)
x <- sub("\\\\end\\{table\\}", "\\\\end\\{wraptable\\}", x)
diff --git a/R/kable_xml.R b/R/kable_xml.R
new file mode 100644
index 0000000..280f042
--- /dev/null
+++ b/R/kable_xml.R
@@ -0,0 +1,23 @@
+#' Read HTML kable as XML
+#'
+#' @description This function will read kable as a xml file
+#'
+#' @param x kable or kableExtra object
+#'
+#' @export
+kable_as_xml <- function(x) {
+ read_kable_as_xml(x)
+}
+
+#' Convert XML back to kable
+#'
+#' @description Convert XML back to kable
+#'
+#' @param x XML table object
+#'
+#' @export
+xml_as_kable <- function(x) {
+ out <- as_kable_xml(x)
+ class(out) <- "kableExtra"
+ return(out)
+}
diff --git a/R/kbl.R b/R/kbl.R
new file mode 100644
index 0000000..af23485
--- /dev/null
+++ b/R/kbl.R
@@ -0,0 +1,134 @@
+#' Wrapper function of knitr::kable
+#'
+#' @description knitr's kable function is the foundation of this package.
+#' However, it has many latex/html specific arguments hidden under the ground
+#' unless you check its source code. This wrapper function is created to
+#' provide better documentation (and auto-complete yay) and at the same time,
+#' solve the auto format setting in a better way.
+#'
+#' @param table.attr A character string for addition HTML table attributes.
+#' This is convenient if you simply want to add a few HTML classes or styles.
+#' For example, you can put 'class="table" style="color: red"'.
+#' @param booktabs T/F for whether to enable the booktabs format for tables. I
+#' personally would recommend you turn this on for every latex table except
+#' some special cases.
+#' @param longtable T/F for whether to use the longtable format. If you have a
+#' table that will span over two or more pages, you will have to turn this on.
+#' @param valign You probably won't need to adjust this latex option very often.
+#' If you are familar with latex tables, this is the optional position for the
+#' tabular environment controling the vertical position of the table relative
+#' to the baseline of the surrounding text. Possible choices are `b`, `c` and
+#' `t` (default).
+#' @param position This is the "real" or say floating position for the latex
+#' table environment. The `kable` only puts tables in a table environment when
+#' a caption is provided. That is also the reason why your tables will be
+#' floating around if you specify captions for your table. Possible choices are
+#' `h` (here), `t` (top, default), `b` (bottom) and `p` (on a dedicated page).
+#' @param centering T (default)/F. Whether to center tables in the table
+#' environment.
+#' @param caption.short Another latex feature. Short captions for tables
+#' @param linesep By default, in booktabs tables, `kable` insert an extra space
+#' every five rows for clear display. If you don't want this feature or if you
+#' want to do it in a different pattern, you can consider change this option.
+#' The default is c('', '', '', '', '\\addlinespace'). Also, if you are not
+#' using booktabs, but you want a cleaner display, you can change this to ''.
+#' @param table.envir You probably don't need to change this as well. The
+#' default setting is to put a table environment outside of tabular if a
+#' caption is provided.
+#' @param vline vertical separator. Default is nothing for booktabs
+#' tables but "|" for normal tables.
+#' @param toprule toprule. Default is hline for normal table but toprule for
+#' booktabs tables.
+#' @param bottomrule bottomrule. Default is hline for normal table but
+#' bottomrule for booktabs tables.
+#' @param midrule midrule. Default is hline for normal table but midrule for
+#' booktabs tables.
+#'
+#' @inheritParams knitr::kable
+#' @export
+kbl <- function(x, format, digits = getOption("digits"),
+ row.names = NA, col.names = NA, align,
+ caption = NULL, label = NULL, format.args = list(),
+ escape = TRUE,
+ table.attr = '',
+ booktabs = FALSE, longtable = FALSE,
+ valign = 't', position = '', centering = TRUE,
+ vline = getOption('knitr.table.vline', if (booktabs) '' else '|'),
+ toprule = getOption('knitr.table.toprule', if (booktabs) '\\toprule' else '\\hline'),
+ bottomrule = getOption('knitr.table.bottomrule', if (booktabs) '\\bottomrule' else '\\hline'),
+ midrule = getOption('knitr.table.midrule', if (booktabs) '\\midrule' else '\\hline'),
+ linesep = if (booktabs) c('', '', '', '', '\\addlinespace') else '\\hline',
+ caption.short = '',
+ table.envir = if (!is.null(caption)) 'table', ...) {
+ if (!missing(align) && length(align) == 1L && !grepl('[^lcr]', align)) {
+ align <- strsplit(align, '')[[1]]
+ }
+ if (missing(format) || is.null(format)) {
+ if (knitr::is_latex_output()) {
+ format <- "latex"
+ out <- knitr::kable(
+ x = x, format = format, digits = digits,
+ row.names = row.names, col.names = col.names, align = align,
+ caption = caption, label = label, format.args = format.args,
+ escape = escape,
+ booktabs = booktabs, longtable = longtable,
+ valign = valign, position = position, centering = centering,
+ vline = vline, toprule = toprule, bottomrule = bottomrule,
+ midrule = midrule, linesep = linesep, caption.short = caption.short,
+ table.envir = table.envir, ...
+ )
+ table_info <- magic_mirror(out)
+ if (is.null(col.names)) {
+ table_info$position_offset <- 0
+ }
+ return(out)
+ } else {
+ format <- "html"
+ out <- knitr::kable(
+ x = x, format = format, digits = digits,
+ row.names = row.names, col.names = col.names, align = align,
+ caption = caption, label = label, format.args = format.args,
+ escape = escape,
+ table.attr = table.attr, ...
+ )
+ if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
+ return(out)
+ }
+ } else {
+ if (format == "latex") {
+ out <- knitr::kable(
+ x = x, format = format, digits = digits,
+ row.names = row.names, col.names = col.names, align = align,
+ caption = caption, label = label, format.args = format.args,
+ escape = escape,
+ booktabs = booktabs, longtable = longtable,
+ valign = valign, position = position, centering = centering,
+ vline = vline, toprule = toprule, bottomrule = bottomrule,
+ midrule = midrule, linesep = linesep, caption.short = caption.short,
+ table.envir = table.envir, ...
+ )
+ table_info <- magic_mirror(out)
+ if (is.null(col.names)) {
+ table_info$position_offset <- 0
+ }
+ return(out)
+ }
+ if (format == "html") {
+ out <- knitr::kable(
+ x = x, format = format, digits = digits,
+ row.names = row.names, col.names = col.names, align = align,
+ caption = caption, label = label, format.args = format.args,
+ escape = escape,
+ table.attr = table.attr, ...
+ )
+ if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
+ return(out)
+ }
+ return(knitr::kable(
+ x = x, format = format, digits = digits,
+ row.names = row.names, col.names = col.names, align = align,
+ caption = caption, label = label, format.args = format.args,
+ escape = escape, ...
+ ))
+ }
+}
diff --git a/R/light_themes.R b/R/light_themes.R
new file mode 100644
index 0000000..e4ed2a3
--- /dev/null
+++ b/R/light_themes.R
@@ -0,0 +1,86 @@
+#' Alternative HTML themes
+#'
+#' @description kableExtra uses the built-in bootstrap themes by default in
+#' `kable_styling()`. Alternatively, you can use a customized table themes for
+#' your table. This `lightable` table style sheet comes with three formats,
+#' namely `lightable-minimal`, `lightable-classic`, `lightable-material` and
+#' `lightable-material-dark` with `hover` and `striped` options.
+#'
+#' @param kable_input A HTML kable object.
+#' @param lightable_options Options to customize lightable. Similar with
+#' `bootstrap_options` in `kable_styling`. Choices include `basic`, `striped`
+#' and `hover`.
+#' @param html_font A string for HTML css font. For example,
+#' `html_font = '"Arial Narrow", arial, helvetica, sans-serif'`.
+#' @param ... Everything else you need to specify in `kable_styling`.
+#'
+#' @export
+kable_classic <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Arial Narrow", "Source Sans Pro", sans-serif', ...) {
+ kable_light(kable_input, "lightable-classic",
+ lightable_options, html_font, ...)
+}
+
+#' @rdname kable_classic
+#' @export
+kable_classic_2 <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Arial Narrow", "Source Sans Pro", sans-serif', ...) {
+ kable_light(kable_input, "lightable-classic-2",
+ lightable_options, html_font, ...)
+}
+
+#' @rdname kable_classic
+#' @export
+kable_minimal <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Trebuchet MS", verdana, calibri, sans-serif', ...) {
+ kable_light(kable_input, "lightable-minimal",
+ lightable_options, html_font, ...)
+}
+
+#' @rdname kable_classic
+#' @export
+kable_material <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Source Sans Pro", helvetica, sans-serif', ...) {
+ kable_light(kable_input, "lightable-material",
+ lightable_options, html_font, ...)
+}
+
+#' @rdname kable_classic
+#' @export
+kable_material_dark <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Source Sans Pro", helvetica, sans-serif', ...) {
+ kable_light(kable_input, "lightable-material-dark",
+ lightable_options, html_font, ...)
+}
+
+#' @rdname kable_classic
+#' @export
+kable_paper <- function(
+ kable_input, lightable_options = "basic",
+ html_font = '"Arial Narrow", arial, helvetica, sans-serif', ...) {
+ kable_light(kable_input, "lightable-paper", lightable_options,
+ html_font, ...)
+}
+
+kable_light <- function(kable_input, light_class, lightable_options,
+ html_font = NULL, ...) {
+ lightable_options <- match.arg(lightable_options,
+ choices = c("basic", "striped", "hover"),
+ several.ok = TRUE)
+ if ("striped" %in% lightable_options) {
+ light_class <- paste(light_class, "lightable-striped")
+ }
+ if ("hover" %in% lightable_options) {
+ light_class <- paste(light_class, "lightable-hover")
+ }
+ out <- kable_styling(kable_input, "none", htmltable_class = light_class,
+ html_font = html_font, ...)
+ attr(out, "lightable") <- TRUE
+ attr(out, "lightable_class") <- light_class
+ return(out)
+}
diff --git a/R/linebreak.R b/R/linebreak.R
index 54d7cae..3bc0d51 100644
--- a/R/linebreak.R
+++ b/R/linebreak.R
@@ -14,7 +14,7 @@
linebreaker = "\n") {
if (is.numeric(x) | is.logical(x)) return(x)
x <- as.character(x)
- align <- match.arg(align, c("l", "c", "r"))
+ align <- vapply(align, match.arg, 'a', choices = c("l", "c", "r"))
if (double_escape) {
ifelse(str_detect(x, linebreaker),
paste0("\\\\makecell[", align, "]{",
diff --git a/R/magic_mirror.R b/R/magic_mirror.R
index 09eea05..dc54067 100644
--- a/R/magic_mirror.R
+++ b/R/magic_mirror.R
@@ -8,103 +8,99 @@
#' @export
magic_mirror <- function(kable_input){
- if (!"knitr_kable" %in% attr(kable_input, "class")) {
- warning("magic_mirror may not be able to produce correct result if the",
- " input table is not rendered by knitr::kable. ")
- }
if ("kable_meta" %in% names(attributes(kable_input))) {
return(attr(kable_input, "kable_meta"))
}
kable_format <- attr(kable_input, "format")
if (kable_format == "latex") {
- kable_info <- magic_mirror_latex(kable_input)
+ table_info <- magic_mirror_latex(kable_input)
}
if (kable_format == "html") {
- kable_info <- magic_mirror_html(kable_input)
+ table_info <- magic_mirror_html(kable_input)
}
- return(kable_info)
+ return(table_info)
}
# Magic mirror for latex tables --------------
magic_mirror_latex <- function(kable_input){
- kable_info <- list(tabular = NULL, booktabs = FALSE, align = NULL,
+ table_info <- list(tabular = NULL, booktabs = FALSE, align = NULL,
valign = NULL, ncol = NULL, nrow = NULL, colnames = NULL,
rownames = NULL, caption = NULL, caption.short = NULL,
contents = NULL,
centering = FALSE, table_env = FALSE)
# Tabular
- kable_info$tabular <- ifelse(
+ table_info$tabular <- ifelse(
grepl("\\\\begin\\{tabular\\}", kable_input),
"tabular", "longtable"
)
# Booktabs
- kable_info$booktabs <- grepl("\\\\toprule", kable_input)
+ table_info$booktabs <- grepl("\\\\toprule", kable_input)
# Align
- kable_info$align <- gsub("\\|", "", str_match(
+ table_info$align <- gsub("\\|", "", str_match(
kable_input, paste0("\\\\begin\\{",
- kable_info$tabular,"\\}.*\\{(.*?)\\}"))[2])
- kable_info$align_vector <- unlist(strsplit(kable_info$align, ""))
- kable_info$align_vector_origin <- kable_info$align_vector
+ table_info$tabular,"\\}.*\\{(.*?)\\}"))[2])
+ table_info$align_vector <- unlist(strsplit(table_info$align, ""))
+ table_info$align_vector_origin <- table_info$align_vector
# valign
- kable_info$valign <- gsub("\\|", "", str_match(
- kable_input, paste0("\\\\begin\\{", kable_info$tabular,"\\}(.*)\\{.*?\\}"))[2])
- kable_info$valign2 <- sub("\\[", "\\\\[", kable_info$valign)
- kable_info$valign2 <- sub("\\]", "\\\\]", kable_info$valign2)
- kable_info$valign3 <- sub("\\[", "", kable_info$valign)
- kable_info$valign3 <- sub("\\]", "", kable_info$valign3)
- kable_info$begin_tabular <- paste0("\\\\begin\\{", kable_info$tabular, "\\}",
- kable_info$valign2)
- kable_info$end_tabular <- paste0("\\\\end\\{", kable_info$tabular, "\\}")
+ table_info$valign <- gsub("\\|", "", str_match(
+ kable_input, paste0("\\\\begin\\{", table_info$tabular,"\\}(.*)\\{.*?\\}"))[2])
+ 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, "\\}")
# N of columns
- kable_info$ncol <- nchar(kable_info$align)
+ table_info$ncol <- nchar(table_info$align)
# Caption
if (str_detect(kable_input, "caption\\[")) {
caption_line <- str_match(kable_input, "\\\\caption(.*)\\n")[2]
- kable_info$caption.short <- str_match(caption_line, "\\[(.*?)\\]")[2]
- kable_info$caption <- substr(caption_line,
- nchar(kable_info$caption.short) + 4,
+ table_info$caption.short <- str_match(caption_line, "\\[(.*?)\\]")[2]
+ table_info$caption <- substr(caption_line,
+ nchar(table_info$caption.short) + 4,
nchar(caption_line))
} else {
- kable_info$caption <- str_match(kable_input, "caption\\{(.*?)\\n")[2]
+ table_info$caption <- str_match(kable_input, "caption\\{(.*?)\\n")[2]
}
- if (kable_info$tabular == "longtable") {
- kable_info$caption <- str_sub(kable_info$caption, 1, -4)
+ if (table_info$tabular == "longtable") {
+ table_info$caption <- str_sub(table_info$caption, 1, -4)
} else {
- kable_info$caption <- str_sub(kable_info$caption, 1, -2)
+ table_info$caption <- str_sub(table_info$caption, 1, -2)
}
# Contents
- kable_info$contents <- str_match_all(kable_input, "\n(.*)\\\\\\\\")[[1]][,2]
- kable_info$contents <- regex_escape(kable_info$contents, T)
- if (kable_info$tabular == "longtable" & !is.na(kable_info$caption) &
+ table_info$contents <- str_match_all(kable_input, "\n(.*)\\\\\\\\")[[1]][,2]
+ table_info$contents <- regex_escape(table_info$contents, T)
+ if (table_info$tabular == "longtable" & !is.na(table_info$caption) &
!str_detect(kable_input, "\\\\begin\\{table\\}\\n\\n\\\\caption")) {
- kable_info$contents <- kable_info$contents[-1]
+ table_info$contents <- table_info$contents[-1]
}
if (!is.null(attr(kable_input, "n_head"))) {
n_head <- attr(kable_input, "n_head")
- kable_info$new_header_row <- kable_info$contents[seq(n_head - 1, 1)]
- kable_info$contents <- kable_info$contents[-seq(1, n_head - 1)]
- kable_info$header_df <- extra_header_to_header_df(kable_info$new_header_row)
- kable_info$new_header_row <- paste0(kable_info$new_header_row, "\\\\\\\\")
+ table_info$new_header_row <- table_info$contents[seq(n_head - 1, 1)]
+ table_info$contents <- table_info$contents[-seq(1, n_head - 1)]
+ table_info$header_df <- extra_header_to_header_df(table_info$new_header_row)
+ table_info$new_header_row <- paste0(table_info$new_header_row, "\\\\\\\\")
}
- kable_info$nrow <- length(kable_info$contents)
- kable_info$duplicated_rows <- (sum(duplicated(kable_info$contents)) != 0)
+ table_info$nrow <- length(table_info$contents)
+ table_info$duplicated_rows <- (sum(duplicated(table_info$contents)) != 0)
# Column names
- if (kable_info$booktabs & !grepl("\\\\midrule", kable_input)) {
- kable_info$colnames <- NULL
- kable_info$position_offset <- 0
+ if (table_info$booktabs & !grepl("\\\\midrule", kable_input)) {
+ table_info$colnames <- NULL
+ table_info$position_offset <- 0
} else {
- kable_info$colnames <- str_split(kable_info$contents[1], " \\& ")[[1]]
- kable_info$position_offset <- 1
+ table_info$colnames <- str_split(table_info$contents[1], " \\& ")[[1]]
+ table_info$position_offset <- 1
}
# Row names
- kable_info$rownames <- str_extract(kable_info$contents, "^[^ &]*")
+ table_info$rownames <- str_extract(table_info$contents, "^[^ &]*")
- kable_info$centering <- grepl("\\\\centering", kable_input)
+ table_info$centering <- grepl("\\\\centering", kable_input)
- kable_info$table_env <- (!is.na(kable_info$caption) &
- kable_info$tabular != "longtable")
+ table_info$table_env <- (!is.na(table_info$caption) &
+ table_info$tabular != "longtable")
- return(kable_info)
+ return(table_info)
}
extra_header_to_header_df <- function(extra_header_rows) {
@@ -123,23 +119,23 @@
# Magic Mirror for html table --------
magic_mirror_html <- function(kable_input){
- kable_info <- list()
+ table_info <- list()
kable_xml <- read_kable_as_xml(kable_input)
# Caption
- kable_info$caption <- xml_text(xml_child(kable_xml, "caption"))
+ table_info$caption <- xml_text(xml_child(kable_xml, "caption"))
# Contents
- # kable_info$contents <- html_table(read_html(as.character(kable_input)))[[1]]
+ # table_info$contents <- html_table(read_html(as.character(kable_input)))[[1]]
# colnames
- kable_info$colnames <- lapply(xml_children(xml_child(kable_xml, "thead")),
+ table_info$colnames <- lapply(xml_children(xml_child(kable_xml, "thead")),
xml_children)
- kable_info$colnames <- kable_info$colnames[[length(kable_info$colnames)]]
- kable_info$colnames <- trimws(xml_text(kable_info$colnames))
- kable_info$ncol <- length(kable_info$colnames)
- kable_info$nrow_header <- length(xml_children(xml_child(kable_xml, "thead")))
- kable_info$nrow_body <- nrow(kable_info$contents)
- kable_info$table_class <- xml_attr(kable_xml, "class")
- kable_info$table_style <- xml_attr(kable_xml, "style")
- return(kable_info)
+ table_info$colnames <- table_info$colnames[[length(table_info$colnames)]]
+ table_info$colnames <- trimws(xml_text(table_info$colnames))
+ table_info$ncol <- length(table_info$colnames)
+ table_info$nrow_header <- length(xml_children(xml_child(kable_xml, "thead")))
+ table_info$nrow_body <- nrow(table_info$contents)
+ table_info$table_class <- xml_attr(kable_xml, "class")
+ table_info$table_style <- xml_attr(kable_xml, "style")
+ return(table_info)
}
diff --git a/R/print.R b/R/print.R
index cc0e97b..6184762 100644
--- a/R/print.R
+++ b/R/print.R
@@ -1,16 +1,25 @@
#' @export
print.kableExtra <- function(x, ...) {
- html_header <- htmltools::tags$head(
- rmarkdown::html_dependency_jquery(),
- rmarkdown::html_dependency_bootstrap(theme = "simplex"),
- html_dependency_kePrint()
- )
- html_table <- htmltools::HTML(as.character(x))
- html_result <- htmltools::tagList(html_header, html_table)
- if (interactive() & rstudioapi::isAvailable()) {
- htmltools::html_print(html_result, viewer = rstudioapi::viewer)
+ view_html <- getOption("kableExtra_view_html", TRUE)
+ if (view_html) {
+ dep <- list(
+ rmarkdown::html_dependency_jquery(),
+ rmarkdown::html_dependency_bootstrap(theme = "cosmo"),
+ html_dependency_kePrint(),
+ html_dependency_lightable()
+ )
+ html_kable <- htmltools::browsable(
+ htmltools::HTML(
+ as.character(x),
+ '<script type="text/x-mathjax-config">MathJax.Hub.Config({tex2jax: {inlineMath: [["$","$"], ["\\(","\\)"]]}})</script><script async src="https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML"></script>'
+ )
+ )
+ htmlDependencies(html_kable) <- dep
+ class(html_kable) <- "shiny.tag.list"
+ print(html_kable)
+ } else {
+ cat(as.character(x))
}
- # print(html_result)
}
#' HTML dependency for js script to enable bootstrap tooltip and popup message
@@ -32,7 +41,19 @@
version = "3.3.7",
src = system.file("bootstrapTable-3.3.7",
package = "kableExtra"),
- stylesheet = "bootstrapTable.min.css")
+ stylesheet = "bootstrapTable.min.css",
+ script = "bootstrapTable.js")
+}
+
+#' HTML dependency for lightable
+#'
+#' @export
+html_dependency_lightable <- function() {
+ htmlDependency(name = "lightable",
+ version = "0.0.1",
+ src = system.file("lightable-0.0.1",
+ package = "kableExtra"),
+ stylesheet = "lightable.css")
}
#' @export
@@ -42,9 +63,10 @@
default = TRUE)
if (kp_dependency) {
meta_list <- list(html_dependency_kePrint())
+ meta_list[[2]] <- html_dependency_lightable()
bs <- getOption("kableExtra.html.bsTable", default = FALSE)
if (bs) {
- meta_list[[2]] <- html_dependency_bsTable()
+ meta_list[[3]] <- html_dependency_bsTable()
}
} else {
meta_list <- NULL
@@ -55,3 +77,5 @@
+
+
diff --git a/R/remove_column.R b/R/remove_column.R
new file mode 100644
index 0000000..3bff2f1
--- /dev/null
+++ b/R/remove_column.R
@@ -0,0 +1,96 @@
+#' Remove columns
+#'
+#' @param kable_input Output of [knitr::kable()] with format specified
+#' @param columns A numeric value or vector indicating in which column(s) rows
+#' need to be removed
+#'
+#' @export
+#'
+#' @examples
+#' remove_column(kable(mtcars), 1)
+remove_column <- function (kable_input, columns) {
+ if (is.null(columns)) return(kable_input)
+ kable_format <- attr(kable_input, "format")
+ if (!kable_format %in% c("html", "latex")) {
+ warning("Please specify format in kable. kableExtra can customize",
+ " either HTML or LaTeX outputs. See ",
+ "https://haozhu233.github.io/kableExtra/ for details.")
+ return(kable_input)
+ }
+
+ columns <- sort(unique(columns))
+ if (kable_format == "html") {
+ return(remove_column_html(kable_input, columns))
+ } else if (kable_format == "latex") {
+ stop("Removing columns was not implemented for latex kables yet")
+ }
+}
+
+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")
+ kable_thead <- xml_tpart(kable_xml, "thead")
+
+ group_header_rows <- attr(kable_input, "group_header_rows")
+ all_contents_rows <- seq(1, length(xml_children(kable_tbody)))
+
+ if (!is.null(group_header_rows)) {
+ warning("It's recommended to use remove_column after add_header_above.",
+ "Right now some column span numbers might not be correct. ")
+ all_contents_rows <- all_contents_rows[!all_contents_rows %in%
+ group_header_rows]
+ }
+
+ collapse_matrix <- attr(kable_input, "collapse_matrix")
+ collapse_columns <- NULL
+ if (!is.null(collapse_matrix)) {
+ collapse_columns <- sort(as.numeric(sub("x", "",
+ names(collapse_matrix))))
+ collapse_columns_origin <- collapse_columns
+ }
+
+ while (length(columns) > 0) {
+ xml2::xml_remove(xml2::xml_child(
+ xml2::xml_child(kable_thead, xml2::xml_length(kable_thead)),
+ 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])]]
+ non_skip_rows <- column_span != 0
+ collapse_columns <- collapse_columns[
+ collapse_columns != columns[1]
+ ] - 1
+ } else {
+ non_skip_rows <- rep(TRUE, length(all_contents_rows))
+ }
+ prior_col <- which(collapse_columns_origin < columns[1])
+ for (i in all_contents_rows[non_skip_rows]) {
+ if (length(prior_col) == 0) {
+ pos_adj <- 0
+ } else {
+ pos_adj <- sum(collapse_matrix[i, prior_col] == 0)
+ }
+ target_cell <- xml2::xml_child(
+ xml2::xml_child(kable_tbody, i),
+ columns[1] - pos_adj)
+ xml2::xml_remove(target_cell)
+ }
+ } else {
+ for (i in all_contents_rows) {
+ target_cell <- xml2::xml_child(
+ xml2::xml_child(kable_tbody, i),
+ columns[1])
+ xml2::xml_remove(target_cell)
+ }
+ }
+ # not very efficient but for finite task it's probably okay
+ columns <- (columns - 1)[-1]
+ }
+ out <- as_kable_xml(kable_xml)
+ attributes(out) <- kable_attrs
+ if (!"kableExtra" %in% class(out))
+ class(out) <- c("kableExtra", class(out))
+
+ return(out)
+}
diff --git a/R/row_spec.R b/R/row_spec.R
index 7bfb68e..92d8150 100644
--- a/R/row_spec.R
+++ b/R/row_spec.R
@@ -147,12 +147,12 @@
}
if (!is.null(color)) {
xml_attr(x, "style") <- paste0(xml_attr(x, "style"),
- "color: ", color, ";")
+ "color: ", html_color(color), " !important;")
}
if (!is.null(background)) {
xml_attr(x, "style") <- paste0(xml_attr(x, "style"),
"background-color: ",
- background, ";")
+ html_color(background), " !important;")
}
if (!is.null(align)) {
xml_attr(x, "style") <- paste0(xml_attr(x, "style"),
@@ -198,7 +198,9 @@
underline, strikeout,
color, background, align, font_size, angle,
hline_after, extra_latex_after)
- temp_sub <- ifelse(i == 1 & table_info$tabular == "longtable", gsub, sub)
+ temp_sub <- ifelse(i == 1 & (table_info$tabular == "longtable" |
+ !is.null(table_info$repeat_header_latex)),
+ gsub, sub)
if (length(new_row) == 1) {
out <- temp_sub(target_row, new_row, out, perl = T)
table_info$contents[i] <- new_row
@@ -247,9 +249,16 @@
}
if (!is.null(color)) {
new_row <- lapply(new_row, function(x) {
+ x <- clear_color_latex(x)
paste0("\\\\textcolor", latex_color(color), "\\{", x, "\\}")
})
}
+ if (!is.null(background)) {
+ new_row <- lapply(new_row, function(x) {
+ x <- clear_color_latex(x, background = TRUE)
+ paste0("\\\\cellcolor", latex_color(background), "\\{", x, "\\}")
+ })
+ }
if (!is.null(font_size)) {
new_row <- lapply(new_row, function(x) {
paste0("\\\\begingroup\\\\fontsize\\{", font_size, "\\}\\{",
@@ -282,9 +291,9 @@
new_row <- paste(unlist(new_row), collapse = " & ")
- if (!is.null(background)) {
- new_row <- paste0("\\\\rowcolor", latex_color(background), " ", new_row)
- }
+ # if (!is.null(background)) {
+ # new_row <- paste0("\\\\rowcolor", latex_color(background), " ", new_row)
+ # }
if (!hline_after & is.null(extra_latex_after)) {
return(new_row)
@@ -301,3 +310,5 @@
return(c(new_row, latex_after))
}
}
+
+
diff --git a/R/save_kable.R b/R/save_kable.R
index 5a5cbc0..8238552 100644
--- a/R/save_kable.R
+++ b/R/save_kable.R
@@ -4,46 +4,174 @@
#' kableExtra
#' @param file save to files. If the input table is in HTML and the output file
#' ends with `.png`, `.pdf` and `.jpeg`, `webshot` will be used to do the
-#' conversion
-#'
+#' conversion.
#' @param bs_theme Which Bootstrap theme to use
#' @param self_contained Will the files be self-contained?
-#' @param ... Additional variables being passed to `webshot::webshot`.`
+#' @param extra_dependencies Additional HTML dependencies. For example,
+#' `list(`
+#' @param ... Additional variables being passed to `webshot::webshot`. This
+#' is for HTML only.
+#' @param latex_header_includes A character vector of extra LaTeX header stuff.
+#' Each element is a row. You can have things like
+#' `c("\\\\usepackage{threeparttable}", "\\\\usepackage{icons}")` You could
+#' probably add your language package here if you use non-English text in your
+#' table, such as `\\\\usepackage[magyar]{babel}`.
+#' @param keep_tex A T/F option to control if the latex file that is initially created
+#' should be kept. Default is `FALSE`.
+#' @examples
+#' \dontrun{
+#' library(kableExtra)
#'
+#' kable(mtcars[1:5, ], "html") %>%
+#' kable_styling("striped") %>%
+#' row_spec(1, color = "red") %>%
+#' save_kable("inst/test.pdf")
+#' }
#' @export
save_kable <- function(x, file,
- bs_theme = "simplex", self_contained = TRUE, ...) {
- if (attr(x, "format") == "latex") {
- return(save_kable_latex(x, file))
+ bs_theme = "simplex", self_contained = TRUE,
+ extra_dependencies = NULL, ...,
+ latex_header_includes = NULL, keep_tex = FALSE) {
+ if (!is.null(attr(x, "format")) && attr(x, "format") == "latex") {
+ return(save_kable_latex(x, file, latex_header_includes, keep_tex))
}
- return(save_kable_html(x, file, bs_theme, self_contained, ...))
+ return(save_kable_html(x, file, bs_theme, self_contained,
+ extra_dependencies, ...))
}
-save_kable_html <- function(x, file, bs_theme, self_contained, ...) {
- html_header <- htmltools::tags$head(
+save_kable_html <- function(x, file, bs_theme, self_contained,
+ extra_dependencies, ...) {
+ dependencies <- list(
rmarkdown::html_dependency_jquery(),
rmarkdown::html_dependency_bootstrap(theme = bs_theme),
html_dependency_kePrint()
)
+ if (!is.null(extra_dependencies)) {
+ dependencies <- append(dependencies, extra_dependencies)
+ }
+
+ html_header <- htmltools::tags$head(dependencies)
html_table <- htmltools::HTML(as.character(x))
html_result <- htmltools::tagList(html_header, html_table)
- # Use webshot if necessary
+
+ # Check if we are generating an image and use webshot to do that
if (tools::file_ext(file) %in% c("png", "jpg", "jpeg", "pdf")) {
- file_html <- paste0(tools::file_path_sans_ext(file), ".html")
- htmltools::save_html(html_result, file = file_html)
- webshot::webshot(file_html, file, ...)
- unlink(file_html)
- unlink("lib", recursive = TRUE)
+ file_temp_html <- tempfile(pattern = tools::file_path_sans_ext(file), tmpdir = '.', fileext = ".html")
+
+ file.create(file_temp_html)
+ file_temp_html <- normalizePath(file_temp_html)
+ file.create(file)
+ file <- normalizePath(file)
+
+ # Generate a random temp lib directory. The sub is to remove any back or forward slash at the beginning of the temp_dir
+ temp_dir <- sub(pattern = '^[\\\\/]{1,2}', replacement = '', tempfile(pattern = 'lib', tmpdir = '' , fileext = ''))
+ htmltools::save_html(html_result, file = file_temp_html, libdir = temp_dir)
+
+ result <- webshot::webshot(file_temp_html, file, ...)
+ if (is.null(result)) {
+ # A webshot could not be created. Delete newly created files and issue msg
+ file.remove(file)
+ file.remove(file_temp_html)
+ message('save_kable could not create image with webshot package. Please check for any webshot messages')
+ } else {
+ if (tools::file_ext(file) == "pdf") {
+ message("Note that HTML color may not be displayed on PDF properly.")
+ }
+ # Remove temp html file and temp lib directory
+ file.remove(file_temp_html)
+ unlink(file.path(dirname(file_temp_html), temp_dir), recursive = TRUE)
+
+ if (requireNamespace("magick", quietly = TRUE)) {
+ img_rework <- magick::image_read(file)
+ img_rework <- magick::image_trim(img_rework)
+ img_info <- magick::image_info(img_rework)
+ magick::image_write(img_rework, file)
+ attr(file, "info") <- img_info
+ } else {
+ message("save_kable will have the best result with magick installed. ")
+ }
+ }
+
} else {
- htmltools::save_html(html_result, file = file)
+ file.create(file)
+ file <- normalizePath(file)
+
if (self_contained) {
+ # Generate a random temp lib directory. The sub is to remove any back or forward slash at the beginning of the temp_dir
+ temp_dir <- sub(pattern = '^[\\\\/]{1,2}', replacement = '', tempfile(pattern = 'lib', tmpdir = '' , fileext = ''))
+ htmltools::save_html(html_result, file = file, libdir = temp_dir)
+ #remove_html_doc(file)
rmarkdown::pandoc_self_contained_html(file, file)
- unlink("lib", recursive = TRUE)
+ unlink(file.path(dirname(file), temp_dir), recursive = TRUE)
+ } else {
+ # Simply use the htmltools::save_html to write out the files. Dependencies go to the standard lib folder
+ htmltools::save_html(html_result, file = file)
}
}
+
+ return(invisible(file))
}
-save_kable_latex <- function(x, file) {
+remove_html_doc <- function(x){
+ out <- paste(readLines(x)[-1], collapse = "\n")
+ writeLines(out, x)
+}
+save_kable_latex <- function(x, file, latex_header_includes, keep_tex) {
+ temp_tex <- c(
+ "\\documentclass[border=1mm, preview]{standalone}",
+ "\\usepackage[active,tightpage]{preview}",
+ "\\usepackage{varwidth}",
+ "\\usepackage{amssymb, amsmath}",
+ "\\usepackage{ifxetex,ifluatex}",
+ "\\usepackage{fixltx2e}",
+ "\\usepackage{polyglossia}",
+ latex_pkg_list(),
+ "\\usepackage{graphicx}",
+ "\\usepackage{xltxtra,xunicode}",
+ latex_header_includes,
+ "\\begin{document}",
+ solve_enc(x),
+ "\\end{document}"
+ )
+ temp_tex <- paste(temp_tex, collapse = "\n")
+
+ temp_tex_file <- paste0(tools::file_path_sans_ext(file), ".tex")
+ writeLines(temp_tex, temp_tex_file, useBytes = T)
+ temp_tex_file <- normalizePath(temp_tex_file)
+ file_no_ext <- tools::file_path_sans_ext(temp_tex_file)
+
+ owd <- setwd(dirname(temp_tex_file))
+
+ system(paste0('xelatex -interaction=batchmode "', temp_tex_file,'"'))
+ if (!keep_tex) {
+ temp_file_delete <- paste0(file_no_ext, c(".tex", ".aux", ".log"))
+ unlink(temp_file_delete)
+ }
+
+ table_img_info <- NULL
+ if (tools::file_ext(file) != "pdf") {
+ table_img_pdf <- try(
+ magick::image_read(paste0(file_no_ext, ".pdf"),
+ density = 300), silent = T)
+ if (class(table_img_pdf) == "try-error") {
+ stop("We hit an error when trying to use magick to read the generated ",
+ "PDF file. You may check your magick installation and try to ",
+ "use magick::image_read to read the PDF file manually. It's also ",
+ "possible that you didn't have ghostscript installed.")
+ }
+ unlink(paste0(file_no_ext, ".pdf"))
+ table_img <- magick::image_convert(table_img_pdf,
+ tools::file_ext(file))
+ table_img_info <- magick::image_info(table_img)
+ magick::image_write(table_img,
+ paste0(file_no_ext, ".", tools::file_ext(file)))
+ }
+
+ setwd(owd)
+
+ out <- paste0(file_no_ext, ".", tools::file_ext(file))
+ attr(out, "info") <- table_img_info
+ return(invisible(out))
}
diff --git a/R/scroll_box.R b/R/scroll_box.R
index 3d1b805..a1d1835 100644
--- a/R/scroll_box.R
+++ b/R/scroll_box.R
@@ -8,6 +8,8 @@
#' @param width A character string indicating the width of the box, e.g. "100px"
#' @param box_css CSS text for the box
#' @param extra_css Extra CSS styles
+#' @param fixed_thead HTML table option so table header row is fixed at top.
+#' Values can be either T/F or `list(enabled = T/F, background = "anycolor")`.
#'
#' @export
#'
@@ -23,26 +25,63 @@
#' kable_styling() %>%
#' scroll_box(width = "100%", height = "200px")
#' }
-
scroll_box <- function(kable_input, height = NULL, width = NULL,
box_css = "border: 1px solid #ddd; padding: 5px; ",
- extra_css = NULL) {
+ extra_css = NULL,
+ fixed_thead = TRUE
+ ) {
+ kable_format <- attr(kable_input, "format")
+ if (kable_format != "html") {
+ return(kable_input)
+ }
kable_attrs <- attributes(kable_input)
- out <- as.character(kable_input)
+ fixed_thead <- get_fixed_thead(fixed_thead)
+ if (is.null(height)) fixed_thead$enabled <- FALSE
+
+ if (fixed_thead$enabled) {
+ box_css = "border: 1px solid #ddd; padding: 0px; "
+ kable_xml <- read_kable_as_xml(kable_input)
+ 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))) {
+ xml_attr(all_header_cells[i], "style") <- paste0(
+ xml_attr(all_header_cells[i], "style"),
+ "position: sticky; top:0; background-color: ",
+ fixed_thead$background, ";"
+ )
+ }
+ out <- as.character(as_kable_xml(kable_xml))
+ } else {
+ out <- as.character(kable_input)
+ }
+
box_styles <- c(box_css, extra_css)
+
if (!is.null(height)) {
box_styles <- c(box_styles,
paste0("overflow-y: scroll; height:", height, "; "))
}
+
if (!is.null(width)) {
box_styles <- c(box_styles,
paste0("overflow-x: scroll; width:", width, "; "))
}
+
out <- paste0('<div style="', paste(box_styles, collapse = ""), '">',
out, '</div>')
out <- structure(out, format = "html",
class = "knitr_kable")
attributes(out) <- kable_attrs
+
if (!"kableExtra" %in% class(out)) class(out) <- c("kableExtra", class(out))
+
return(out)
}
+
+get_fixed_thead <- function(x) {
+ if (is.logical(x)) {
+ if (x) return(list(enabled = TRUE, background = "#FFFFFF"))
+ return(list(enabled = FALSE))
+ }
+ return(x)
+}
diff --git a/R/spec_tools.R b/R/spec_tools.R
index 76fb7dd..350925b 100644
--- a/R/spec_tools.R
+++ b/R/spec_tools.R
@@ -29,12 +29,22 @@
}
html_color <- function(colors) {
- colors <- as.character(colors)
+ colors <- trimws(gsub("\\!important", "", as.character(colors)))
sapply(colors, html_color_)
}
latex_color_ <- function(color) {
if (substr(color, 1, 1) != "#") {
+ return(paste0("\\{", color, "\\}"))
+ } else {
+ color <- sub("#", "", color)
+ if (nchar(color) == 8) color <- substr(color, 1, 6)
+ return(paste0("\\[HTML\\]\\{", color, "\\}"))
+ }
+}
+
+latex_color__ <- function(color) {
+ if (substr(color, 1, 1) != "#") {
return(paste0("{", color, "}"))
} else {
color <- sub("#", "", color)
@@ -42,9 +52,14 @@
return(paste0("[HTML]{", color, "}"))
}
}
-latex_color <- function(colors) {
+latex_color <- function(colors, escape = TRUE) {
colors <- as.character(colors)
- sapply(colors, latex_color_)
+ if (escape) {
+ return(sapply(colors, latex_color_))
+ } else {
+ return(sapply(colors, latex_color__))
+ }
+
}
#' Generate common font size for continuous values
@@ -98,11 +113,18 @@
position <- match.arg(position, c("right", "bottom", "top", "left", "auto"),
several.ok = TRUE)
tooltip_options <- paste(
- 'data-toggle="tooltip"',
+ 'data-toggle="tooltip" data-container="body"',
paste0('data-placement="', position, '"'),
# ifelse(as_html, 'data-html="true"', NULL),
paste0('title="', title, '"'))
+ tooltip_options_list <- list(
+ 'data-toggle' = 'tooltip',
+ 'data-container' = 'body',
+ 'data-placement' = position,
+ 'title' = if(is.null(title)) '' else title
+ )
class(tooltip_options) <- "ke_tooltip"
+ attr(tooltip_options, 'list') <- tooltip_options_list
return(tooltip_options)
}
@@ -123,11 +145,22 @@
position <- match.arg(position, c("bottom", "top", "left", "right", "auto"),
several.ok = TRUE)
popover_options <- paste(
- 'data-toggle="popover"',
+ 'data-toggle="popover" data-container="body"',
paste0('data-trigger="', trigger, '"'),
paste0('data-placement="', position, '"'),
ifelse(!is.null(title), paste0('title="', title, '"'), ""),
paste0('data-content="', content, '"'))
+ popover_options_list <- list(
+ 'data-toggle' = 'popover',
+ 'data-container' = 'body',
+ 'data-trigger' = trigger,
+ 'data-placement' = position,
+ 'data-content' = content
+ )
+ if (!is.null(title)) {
+ popover_options_list['title'] <- title
+ }
class(popover_options) <- "ke_popover"
+ attr(popover_options, 'list') <- popover_options_list
return(popover_options)
}
diff --git a/R/util.R b/R/util.R
index efe13bc..b156260 100644
--- a/R/util.R
+++ b/R/util.R
@@ -45,7 +45,7 @@
}
latex_row_cells <- function(x) {
- strsplit(x, " \\& ")
+ stringr::str_split(x, " \\& ")
}
regex_escape <- function(x, double_backslash = FALSE) {
@@ -100,7 +100,6 @@
"\\usepackage{longtable}",
"\\usepackage{array}",
"\\usepackage{multirow}",
- "\\usepackage[table]{xcolor}",
"\\usepackage{wrapfig}",
"\\usepackage{float}",
"\\usepackage{colortbl}",
@@ -128,7 +127,7 @@
# insert empty_times before last non whitespace characters
new_row <- str_replace(
dup_row, "(?<=\\s)([\\S]+[\\s]*)$",
- paste0("\\\\\\\\vphantom\\\\{", empty_times, "\\\\} \\1"))
+ paste0("\\\\\\\\vphantom\\\\{", empty_times, "\\\\}\\1"))
kable_input <- sub(
paste0(dup_row, "(?=\\s*\\\\\\\\\\*?(\\[.*\\])?)"),
new_row,
@@ -142,8 +141,14 @@
# Solve enc issue for LaTeX tables
solve_enc <- function(x) {
+ if (Encoding(x) == "UTF-8"){
+ out <- x
+ } else {
#may behave differently based on Sys.setlocale settings with respect to characters
- enc2utf8(as.character(base::format(x, trim = TRUE, justify = 'none')))
+ out <- enc2utf8(as.character(base::format(x, trim = TRUE, justify = 'none')))
+ }
+ mostattributes(out) <- attributes(x)
+ return(out)
}
input_escape <- function(x, latex_align) {
@@ -151,3 +156,17 @@
x <- linebreak(x, align = latex_align, double_escape = TRUE)
}
+clear_color_latex <- function(x, background = F) {
+ term <- if (background) "cellcolor" else "textcolor"
+ regex_1 <- sprintf(
+ "\\\\\\\\%s\\\\\\[HTML\\\\\\]\\\\\\{[a-zA-Z0-9]*\\\\\\}\\\\\\{", term
+ )
+ regex_2 <- sprintf(
+ "\\\\\\\\%s\\\\\\{[a-zA-Z0-9]*\\\\\\}\\\\\\{", term
+ )
+ origin_len <- nchar(x)
+ x <- stringr::str_remove(x, regex_1)
+ x <- stringr::str_remove(x, regex_2)
+ return(ifelse(nchar(x) != origin_len, stringr::str_remove(x, "\\\\\\}$"), x))
+}
+
diff --git a/R/xtable2kable.R b/R/xtable2kable.R
index 862d7a1..3c13658 100644
--- a/R/xtable2kable.R
+++ b/R/xtable2kable.R
@@ -51,6 +51,7 @@
if ("tabular.environment" %in% names(xtable_print_options)) {
out_meta$tabular <- xtable_print_options$tabular.environment
}
+ out_meta$xtable <- TRUE
attr(out, "kable_meta") <- out_meta
return(out)
}
diff --git a/R/zzz.R b/R/zzz.R
index e7b3c60..36133e7 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,26 +1,30 @@
.onLoad <- function(libname = find.package("kableExtra"), pkgname = "kableExtra") {
- load_packages <- getOption("kableExtra.latex.load_packages", default = TRUE)
- if (load_packages) {
- usepackage_latex("booktabs")
- usepackage_latex("longtable")
- usepackage_latex("array")
- usepackage_latex("multirow")
- usepackage_latex("xcolor", "table")
- usepackage_latex("wrapfig")
- usepackage_latex("float")
- usepackage_latex("colortbl")
- usepackage_latex("pdflscape")
- usepackage_latex("tabu")
- usepackage_latex("threeparttable")
- usepackage_latex("threeparttablex")
- usepackage_latex("ulem", "normalem")
- usepackage_latex("makecell")
+ if (knitr::is_latex_output()) {
+ load_packages <- getOption("kableExtra.latex.load_packages", default = TRUE)
+ if (load_packages) {
+ usepackage_latex("booktabs")
+ usepackage_latex("longtable")
+ usepackage_latex("array")
+ usepackage_latex("multirow")
+ usepackage_latex("wrapfig")
+ usepackage_latex("float")
+ usepackage_latex("colortbl")
+ usepackage_latex("pdflscape")
+ usepackage_latex("tabu")
+ usepackage_latex("threeparttable")
+ usepackage_latex("threeparttablex")
+ usepackage_latex("ulem", "normalem")
+ usepackage_latex("makecell")
+ # usepackage_latex("xcolor")
+ }
}
auto_format <- getOption("kableExtra.auto_format", default = TRUE)
if (auto_format) auto_set_format()
if (!is.null(rmarkdown::metadata$output) &&
rmarkdown::metadata$output %in% c(
- "ioslides_presentation", "slidy_presentation"
+ "ioslides_presentation", "slidy_presentation",
+ "gitbook", "bookdown::gitbook", "radix_article", "radix::radix_article",
+ "distill_article", "distill::distill_article"
)) {
options(kableExtra.html.bsTable = TRUE)
}