R/save_kable.R - IDS-Mannheim/kableExtra - Gitiles

 #' 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`, `webshot` 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 `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`.
 #' @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)
   html_table <- htmltools::HTML(as.character(x))
   html_result <- htmltools::tagList(html_header, html_table)


   # 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_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)

     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, 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 {
     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)
       #remove_html_doc(file)
       rmarkdown::pandoc_self_contained_html(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
       htmltools::save_html(html_result, file = file)
     }
   }

   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, background = "white", libdir="lib") {
   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("<!DOCTYPE html>", "<html>", "<head>",
             "<meta charset=\"utf-8\" title=\"table output\"/>",
             sprintf("<style>body{background-color:%s;}</style>",
                     htmltools::htmlEscape(background)),
             htmltools::renderDependencies(deps, c("href", "file")),
             rendered$head, "</head>", "<body>",
             rendered$html, "</body>", "</html>")
   writeLines(html, file, 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, 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}",
     "\\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))

   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 = 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))
 }
	#' 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`, `webshot` 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 `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`.
	#' @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)
	html_table <- htmltools::HTML(as.character(x))
	html_result <- htmltools::tagList(html_header, html_table)


	# 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_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)

	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, 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 {
	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)
	#remove_html_doc(file)
	rmarkdown::pandoc_self_contained_html(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
	htmltools::save_html(html_result, file = file)
	}
	}

	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, background = "white", libdir="lib") {
	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("<!DOCTYPE html>", "<html>", "<head>",
	"<meta charset=\"utf-8\" title=\"table output\"/>",
	sprintf("<style>body{background-color:%s;}</style>",
	htmltools::htmlEscape(background)),
	htmltools::renderDependencies(deps, c("href", "file")),
	rendered$head, "</head>", "<body>",
	rendered$html, "</body>", "</html>")
	writeLines(html, file, 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, 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}",
	"\\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))

	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 = 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))
	}