Add spec_color and family
diff --git a/R/cell_spec.R b/R/cell_spec.R
index f5bff2a..aacac76 100644
--- a/R/cell_spec.R
+++ b/R/cell_spec.R
@@ -20,25 +20,27 @@
#' while for LaTeX, you can only choose from `l`, `c` & `r`.
#' @param font_size Only if you want to specify font size locally in HTML.
#' This feature is not available in LaTeX
-#' @param angle 0-360, degree that the text will rotate.
+#' @param angle 0-360, degree that the text will rotate. Can be a vector.
+#' @param hover_message A vector of strings to be displayed as hover message.
+#' Of course, this feature is nly available in HTML.
#'
#' @export
cell_spec <- function(x, format,
bold = F, italic = F, monospace = F,
color = NULL, background = NULL,
- align = NULL, font_size = NULL, angle = NULL) {
+ align = NULL, font_size = NULL, angle = NULL,
+ hover_message = NULL) {
if (missing(format) || is.null(format)) format = getOption('knitr.table.format')
if (is.null(format)) {
- warning("Output format for cell_formatter was not specified. Using ",
- "html as default. You may consider to set it up via option knitr.table.format.",
- "See ?cell_formatter for details. ")
- return(x)
+ message("Setting cell_spec format as html")
+ format <- "html"
}
if (tolower(format) == "html") {
return(cell_spec_html(x, bold, italic, monospace,
- color, background, align, font_size, angle))
+ color, background, align, font_size, angle,
+ hover_message))
}
if (tolower(format) == "latex") {
return(cell_spec_latex(x, bold, italic, monospace,
@@ -47,31 +49,37 @@
}
cell_spec_html <- function(x, bold, italic, monospace,
- color, background, align, font_size, angle) {
+ color, background, align, font_size, angle,
+ hover_message) {
cell_style <- NULL
if (bold) cell_style <- paste(cell_style,"font-weight: bold;")
if (italic) cell_style <- paste(cell_style, "font-style: italic;")
if (monospace) cell_style <- paste(cell_style, "font-family: monospace;")
- if (!is.null(color)) cell_style <- paste0(cell_style, " color: ", color, ";")
+ if (!is.null(color)) cell_style <- paste0(cell_style, "color: ", color, ";")
if (!is.null(background)) {
- cell_style <- paste0(cell_style, " border-radius: 4px; padding-right: 2px",
- "; background-color: ", background, ";")
+ cell_style <- paste0(cell_style, "border-radius: 4px; padding-right: 4px",
+ ";padding-left: 4px; background-color: ", background, ";")
}
if (!is.null(align)) {
- cell_style <- paste0(cell_style, " text-align: ", align, ";")
+ cell_style <- paste0(cell_style, "text-align: ", align, ";")
}
if (!is.null(font_size)) {
- cell_style <- paste0(cell_style, " font-size: ", font_size, "px;")
+ cell_style <- paste0(cell_style, "font-size: ", font_size, "px;")
}
if (!is.null(angle)) {
cell_style <- paste0(cell_style,
- " -webkit-transform: rotate(", angle,
+ "-webkit-transform: rotate(", angle,
"deg); -moz-transform: rotate(", angle,
"deg); -ms-transform: rotate(", angle,
"deg); -o-transform: rotate(", angle, "deg);")
}
+
+ if (!is.null(hover_message)) {
+ hover_message <- gsub("\n", "
", hover_message)
+ hover_message <- paste0("data-toggle='tooltip' title='", hover_message, "'")
+ }
out <- paste0(
- '<div style="', cell_style, '">', x, '</div>'
+ '<div style="', cell_style, '"', hover_message, '>', x, '</div>'
)
return(out)
}
@@ -81,8 +89,14 @@
if (bold) x <- paste0("\\bfseries{", x, "}")
if (italic) x <-paste0("\\em{", x, "}")
if (monospace) x <- paste0("\\ttfamily{", x, "}")
- if (!is.null(color)) x <- paste0("\\textcolor{", color, "}{", x, "}")
- if (!is.null(background)) x <- paste0("\\cellcolor{", background, "}{", x, "}")
+ if (!is.null(color)) {
+ color <- latex_color(color)
+ x <- paste0("\\textcolor", color, "{", x, "}")
+ }
+ if (!is.null(background)) {
+ background <- latex_color(background)
+ x <- paste0("\\cellcolor", background, "{", x, "}")
+ }
if (!is.null(align)) x <- paste0("\\multicolumn{1}{", align, "}{", x, "}")
if (!is.null(angle)) x <- paste0("\\rotatebox{", angle, "}{", x, "}")
return(x)
diff --git a/R/column_spec.R b/R/column_spec.R
index 8e0c554..647f689 100644
--- a/R/column_spec.R
+++ b/R/column_spec.R
@@ -87,7 +87,8 @@
target_cell <- xml_child(xml_child(kable_tbody, i), j)
if (!is.null(width)) {
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
- "width: ", width, "; ")
+ "width: ", width,
+ "; display: inline-block; ")
}
if (bold) {
xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"),
diff --git a/R/kableExtra-package.R b/R/kableExtra-package.R
index 32131c1..672eb8d 100644
--- a/R/kableExtra-package.R
+++ b/R/kableExtra-package.R
@@ -66,6 +66,8 @@
#' @importFrom magrittr %>%
#' @importFrom utils read.csv
#' @importFrom readr read_lines read_file
+#' @importFrom scales rescale
+#' @importFrom viridisLite viridis
#' @name kableExtra-package
#' @aliases kableExtra
#' @docType package
diff --git a/R/spec_tools.R b/R/spec_tools.R
new file mode 100644
index 0000000..7708118
--- /dev/null
+++ b/R/spec_tools.R
@@ -0,0 +1,39 @@
+#' Generate viridis Color code for continuous values
+#'
+#' @inheritParams viridisLite::viridis
+#' @param x continuous vectors of values
+#' @param na_color color code for NA values
+#' @export
+spec_color <- function(x, alpha = 1, begin = 0, end = 1,
+ direction = 1, option = "D",
+ na_color = "#BBBBBBFF") {
+ x <- round(rescale(x, c(1, 256)))
+ color_code <- viridisLite::viridis(256, alpha, begin, end, direction, option)[x]
+ color_code[is.na(color_code)] <- na_color
+ return(color_code)
+}
+
+#' Generate common font size for continuous values
+#'
+#' @param x continuous vectors of values
+#' @param begin Smalles font size to be used. Default is 10.
+#' @param end Largest font size. Default is 20.
+#' @param na_font_size font size for NA values
+#' @export
+spec_font_size <- function(x, begin = 10, end = 20, na_font_size = "inherit") {
+ x <- round(rescale(x, c(begin, end)))
+ x[is.na(x)] <- na_font_size
+ return(x)
+}
+
+#' Generate rotation angle for continuous values
+#'
+#' @param x continuous vectors of values
+#' @param begin Smallest degree to rotate. Default is 0
+#' @param end Largest degree to rotate. Default is 359.
+#' @export
+spec_angle <- function(x) {
+ x <- round(rescale(x, c(0, 359)))
+ x[is.na(x)] <- 0
+ return(x)
+}
diff --git a/R/util.R b/R/util.R
index 27f7d57..f80c89a 100644
--- a/R/util.R
+++ b/R/util.R
@@ -110,3 +110,13 @@
"\\usepackage{threeparttable}"
))
}
+
+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, "}"))
+ }
+}