1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
|
#' Save kable to files
#'
#' @param x A piece of HTML code for tables, usually generated by kable and
#' kableExtra
#' @param file save to files. If the input table is in HTML and the output file
#' ends with `.png`, `.pdf` and `.jpeg`, `webshot2` will be used to do the
#' conversion.
#' @param bs_theme Which Bootstrap theme to use
#' @param self_contained Will the files be self-contained?
#' @param extra_dependencies Additional HTML dependencies. For example,
#' `list(`
#' @param ... Additional variables being passed to `webshot2::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`.
#' @param density density argument passed to magick if needed. Default is 300.
#' @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,
extra_dependencies = NULL, ...,
latex_header_includes = NULL, keep_tex = FALSE,
density = 300) {
if (!is.null(attr(x, "format"))) {
# latex
if (attr(x, "format") == "latex") {
return(save_kable_latex(x, file, latex_header_includes, keep_tex, density))
# markdown
} else if (attr(x, "format") == "pipe") {
# good file extension: write to file
if (tools::file_ext(file) %in% c("txt", "md", "markdown", "Rmd")) {
return(save_kable_markdown(x, file))
# bad file extension: warning + keep going to html writer
} else {
warning('`save_kable` can only save markdown tables to files with the following extensions: .txt, .md, .markdown, .Rmd. Since the supplied file name has a different extension, `save_kable` will try to use the HTML writer. This is likely to produce suboptimal results. To save images or other file formats, try supplying a LaTeX or HTML table to `save_kable`.')
}
}
}
# html
return(save_kable_html(x, file, bs_theme, self_contained,
extra_dependencies, density, ...))
}
save_kable_markdown <- function(x, file, ...) {
out <- paste(x, collapse="\n")
writeLines(text=out, con=file)
return(invisible(file))
}
save_kable_html <- function(x, file, bs_theme, self_contained,
extra_dependencies, density, ...) {
dependencies <- list(
rmarkdown::html_dependency_jquery(),
rmarkdown::html_dependency_bootstrap(theme = bs_theme),
html_dependency_lightable(),
html_dependency_kePrint()
)
if (!is.null(extra_dependencies)) {
dependencies <- append(dependencies, extra_dependencies)
}
html_header <- htmltools::tags$head(dependencies)
# Check if we are generating an image and use webshot to do that
if (tools::file_ext(file) %in% c("png", "jpg", "jpeg", "pdf")) {
html_table <- htmltools::HTML(paste0(
'<div style="margin-right: 15px;position: relative;">',
as.character(x),
'</div>'
))
html_result <- htmltools::tagList(html_header, html_table)
file_temp_html <- tempfile(
pattern = tools::file_path_sans_ext(basename(file)),
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 = ''))
save_HTML(html_result, file = file_temp_html, libdir = temp_dir,
self_contained = FALSE)
if (requireNamespace("webshot2", quietly = TRUE)) {
result <- webshot2::webshot(file_temp_html, file, ...)
} else {
stop("Please install the `webshot2` package.", call. = FALSE)
}
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, density = density)
img_rework <- magick::image_trim(img_rework)
img_info <- magick::image_info(img_rework)
magick::image_write(img_rework, file, density = density)
attr(file, "info") <- img_info
} else {
message("save_kable will have the best result with magick installed. ")
}
}
} else {
html_table <- htmltools::HTML(as.character(x))
html_result <- htmltools::tagList(html_header, html_table)
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 = ''))
save_HTML(html_result, file = file, libdir = temp_dir,
self_contained = TRUE)
#remove_html_doc(file)
self_contained(file, file)
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
save_HTML(html_result, file = file, self_contained = FALSE)
}
}
return(invisible(file))
}
# Local version of htmltools::save_html with fix to relative path.
# See https://github.com/rstudio/htmltools/pull/105
save_HTML <- function(html, file, libdir = "lib", self_contained = TRUE) {
base_file <- basename(file)
dir <- dirname(file)
file <- file.path(dir, base_file)
oldwd <- setwd(dir)
on.exit(setwd(oldwd), add = TRUE)
rendered <- htmltools::renderTags(html)
deps <- lapply(rendered$dependencies, function(dep) {
dep <- htmltools::copyDependencyToDir(dep, libdir, FALSE)
dep <- htmltools::makeDependencyRelative(dep, dir, FALSE)
dep
})
html <- c(
if (self_contained) "" else "<!DOCTYPE html>",
"<html>", "<head>",
"<meta charset=\"utf-8\"/>",
"<title>table output</title>",
htmltools::renderDependencies(deps, c("href", "file")),
rendered$head, "</head>", "<body>",
rendered$html, "</body>", "</html>")
writeLines(html, file, useBytes = TRUE)
}
# Local version of rmarkdown::pandoc_self_contained_html(input, output) to
# remove the no title bug
self_contained <- function(input, output) {
input <- normalizePath(input)
if (!file.exists(output))
file.create(output)
output <- normalizePath(output)
template <- tempfile(fileext = ".html")
on.exit(unlink(template), add = TRUE)
write_utf8("$body$", template)
from <- if (rmarkdown::pandoc_available("1.17")) "markdown_strict" else "markdown"
rmarkdown::pandoc_convert(
input = input, from = from, output = output,
options = c("--metadata", 'pagetitle="table output"', "--self-contained",
"--template", template))
invisible(output)
}
# Local version of rmarkdown:::write_utf8
write_utf8 <- function (text, con, ...) {
opts <- options(encoding = "native.enc")
on.exit(options(opts), add = TRUE)
writeLines(enc2utf8(text), con, ..., useBytes = TRUE)
}
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, density) {
# if file extension is .tex, write to file, return the table as an
# invisible string, and do nothing else
if (tools::file_ext(file) == "tex") {
writeLines(x, file, useBytes = T)
return(invisible(x))
}
temp_tex <- c(
"\\documentclass[border=1mm]{standalone}",
"\\usepackage{amssymb, amsmath}",
latex_pkg_list(),
"\\usepackage{graphicx}",
"\\usepackage{xunicode}",
"\\usepackage{xcolor}",
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))
if (!requireNamespace("tinytex", quietly = TRUE)) {
system(paste0("xelatex -interaction=batchmode ",
gsub(pattern = " ", replacement = "\\ ",
temp_tex_file, fixed = TRUE)))
} else {
tinytex::xelatex(gsub(pattern = " ", replacement = "\\ ",
temp_tex_file, fixed = TRUE))
}
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 = density), silent = T)
if (inherits(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)),
density = density)
}
setwd(owd)
out <- paste0(file_no_ext, ".", tools::file_ext(file))
attr(out, "info") <- table_img_info
return(invisible(out))
}
|