R/save_kable.R

#' 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,
              self_contained = FALSE)

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