* Added kable_paper style for a NYT like table
* Let column_spec take conditional formats
* Added html_font option for kable_styling
diff --git a/R/cell_spec.R b/R/cell_spec.R
index 8e3facc..8a69c1f 100644
--- a/R/cell_spec.R
+++ b/R/cell_spec.R
@@ -59,13 +59,12 @@
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,
@@ -174,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, "}")
}
diff --git a/R/collapse_rows.R b/R/collapse_rows.R
index 927502e..66349c8 100644
--- a/R/collapse_rows.R
+++ b/R/collapse_rows.R
@@ -57,7 +57,7 @@
"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")
@@ -67,8 +67,7 @@
return(collapse_rows_html(kable_input, columns, valign, target))
}
if (kable_format == "latex") {
- latex_hline <- match.arg(latex_hline, c(
- "major", "full", "none", "custom", "linespace"))
+ 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,
diff --git a/R/column_spec.R b/R/column_spec.R
index 2a97fee..0f36f65 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,24 @@
#' 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
@@ -58,7 +68,9 @@
border_left = FALSE, border_right = FALSE,
width_min = NULL, width_max = NULL,
extra_css = NULL, include_thead = FALSE,
- latex_column_spec = NULL, latex_valign = 'p') {
+ 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. ")
}
@@ -76,7 +88,8 @@
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,
@@ -84,8 +97,8 @@
underline, strikeout,
color, background,
border_left, border_right,
- latex_column_spec = latex_column_spec,
- latex_valign = latex_valign))
+ latex_column_spec, latex_valign, include_thead,
+ link))
}
}
@@ -95,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")
@@ -120,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))
@@ -140,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]
)
}
}
@@ -154,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") <- ""
}
@@ -218,6 +258,56 @@
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,
@@ -225,7 +315,8 @@
underline, strikeout,
color, background,
border_left, border_right,
- latex_column_spec, latex_valign) {
+ 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,",
@@ -239,9 +330,7 @@
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, latex_column_spec,
- latex_valign)
+ x, width, border_left, border_right, latex_column_spec, latex_valign)
}
))
@@ -258,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)) {
@@ -271,9 +403,24 @@
return(out)
}
-latex_column_align_builder <- function(x, width, bold, italic, monospace,
- underline, strikeout,
- color, background,
+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 <- ""
@@ -284,24 +431,23 @@
"r" = "\\\\raggedleft\\\\arraybackslash")
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)
}
@@ -309,7 +455,7 @@
x <- paste0(x, "\\|")
}
if (!is.null(latex_column_spec))
- x <- latex_column_spec
+ x <- latex_column_spec
return(x)
}
@@ -317,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))
@@ -346,3 +492,53 @@
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)) {
+ new_row[column] <- paste0("\\\\textcolor", latex_color(color), "\\{",
+ new_row[column], "\\}")
+ }
+ # 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)) {
+ new_row[column] <- paste0("\\\\cellcolor", latex_color(background), "\\{",
+ new_row[column], "\\}")
+ }
+
+ 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/kable.R b/R/kable.R
index f1709d5..108e928 100644
--- a/R/kable.R
+++ b/R/kable.R
@@ -63,10 +63,10 @@
if (!missing(align) && length(align) == 1L && !grepl('[^lcr]', align)) {
align <- strsplit(align, '')[[1]]
}
- if (missing(format) | is.null(format)) {
+ if (missing(format) || is.null(format)) {
if (knitr::is_latex_output()) {
format <- "latex"
- return(knitr::kable(
+ 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,
@@ -76,28 +76,59 @@
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"
- return(knitr::kable(
+ 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, table.attr = table.attr,
- 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, ...
+ escape = escape, ...
))
}
diff --git a/R/kable_styling.R b/R/kable_styling.R
index a777faf..778335d 100644
--- a/R/kable_styling.R
+++ b/R/kable_styling.R
@@ -65,6 +65,8 @@
#' `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'`.
#'
#' @details For LaTeX, if you use other than English environment
#' - all tables are converted to 'UTF-8'. If you use, for example, Hungarian
@@ -100,7 +102,8 @@
protect_latex = TRUE,
table.envir = "table",
fixed_thead = FALSE,
- htmltable_class = NULL) {
+ htmltable_class = NULL,
+ html_font = NULL) {
if (length(bootstrap_options) == 1 && bootstrap_options == "basic") {
bootstrap_options <- getOption("kable_styling_bootstrap_options", "basic")
@@ -136,7 +139,8 @@
font_size = font_size,
protect_latex = protect_latex,
fixed_thead = fixed_thead,
- htmltable_class = htmltable_class))
+ htmltable_class = htmltable_class,
+ html_font = html_font))
}
if (kable_format == "latex") {
if (is.null(full_width)) {
@@ -195,7 +199,8 @@
font_size = NULL,
protect_latex = TRUE,
fixed_thead = FALSE,
- htmltable_class = NULL) {
+ htmltable_class = NULL,
+ html_font = NULL) {
if (protect_latex) {
kable_input <- extract_latex_from_kable(kable_input)
}
@@ -246,6 +251,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;")
}
diff --git a/R/light_themes.R b/R/light_themes.R
index 94aa826..4200dac 100644
--- a/R/light_themes.R
+++ b/R/light_themes.R
@@ -13,35 +13,60 @@
#' @param ... Everything else you need to specify in `kable_styling`.
#'
#' @export
-kable_classic <- function(kable_input, lightable_options = "basic", ...) {
- kable_light(kable_input, "lightable-classic", lightable_options, ...)
+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", ...) {
- kable_light(kable_input, "lightable-classic-2", lightable_options, ...)
+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", ...) {
- kable_light(kable_input, "lightable-minimal", lightable_options, ...)
+kable_minimal <- function(
+ kable_input, lightable_options = "basic",
+ html_font = 'calibri, cambria, "Source Sans Pro", sans-serif', ...) {
+ kable_light(kable_input, "lightable-minimal",
+ lightable_options, html_font, ...)
}
#' @rdname kable_classic
#' @export
-kable_material <- function(kable_input, lightable_options = "basic", ...) {
- kable_light(kable_input, "lightable-material", lightable_options, ...)
+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", ...) {
- kable_light(kable_input, "lightable-material-dark", lightable_options, ...)
+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, ...)
}
-kable_light <- function(kable_input, light_class, lightable_options, ...) {
+#' @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)
@@ -51,7 +76,8 @@
if ("hover" %in% lightable_options) {
light_class <- paste(light_class, "lightable-hover")
}
- out <- kable_styling(kable_input, "none", htmltable_class = light_class, ...)
+ 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/spec_tools.R b/R/spec_tools.R
index 0ae4032..350925b 100644
--- a/R/spec_tools.R
+++ b/R/spec_tools.R
@@ -35,6 +35,16 @@
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/zzz.R b/R/zzz.R
index 36133e7..3fd88fb 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -18,8 +18,8 @@
# usepackage_latex("xcolor")
}
}
- auto_format <- getOption("kableExtra.auto_format", default = TRUE)
- if (auto_format) auto_set_format()
+ # 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",