1# graphics devices in base R, plus those in Cairo, cairoDevice, tikzDevice
2auto_exts = c(
3  bmp = 'bmp', postscript = 'eps', pdf = 'pdf', png = 'png', svg = 'svg',
4  jpeg = 'jpeg', pictex = 'tex', tiff = 'tiff', win.metafile = 'wmf',
5  cairo_pdf = 'pdf', cairo_ps = 'eps',
6
7  quartz_pdf = 'pdf', quartz_png = 'png', quartz_jpeg = 'jpeg',
8  quartz_tiff = 'tiff', quartz_gif = 'gif', quartz_psd = 'psd',
9  quartz_bmp = 'bmp',
10
11  CairoJPEG = 'jpeg', CairoPNG = 'png', CairoPS = 'eps', CairoPDF = 'pdf',
12  CairoSVG = 'svg', CairoTIFF = 'tiff',
13
14  Cairo_pdf = 'pdf', Cairo_png = 'png', Cairo_ps = 'eps', Cairo_svg = 'svg',
15
16  svglite = 'svg',
17
18  ragg_png = 'png',
19
20  tikz = 'tex'
21)
22
23dev2ext = function(x) {
24  res = auto_exts[x]
25  if (any(idx <- is.na(res))) {
26    for (i in x[idx]) dev_get(i)
27    stop2(
28      'cannot find appropriate filename extensions for device ', x[idx], '; ',
29      "please use chunk option 'fig.ext' (https://yihui.org/knitr/options)"
30    )
31  }
32  unname(res)
33}
34
35# test if a device is available (and remember it), e.g., dev_available('png',
36# png); capabilities() gives similar results for some devices but this function
37# is more general
38dev_available = local({
39  res = list()
40  function(name, fun = dev_get(name)) {
41    if (!is.null(res[[name]])) return(res[[name]])
42    res[[name]] <<- tryCatch({
43      f = tempfile(); on.exit(unlink(f))
44      fun(f, width = 5, height = 5)
45      grDevices::dev.off()
46      TRUE
47    }, error = function(e) FALSE)
48  }
49})
50
51dev_get = function(dev, options = opts_current$get(), dpi = options$dpi[1]) {
52  if (is.null(dpi) || is.na(dpi)) dpi = 72
53  device = switch(
54    dev,
55    bmp = function(...) bmp(...,  res = dpi, units = 'in'),
56    postscript = function(...) {
57      postscript(..., onefile = FALSE, horizontal = FALSE, paper = 'special')
58    },
59    jpeg = function(...) jpeg(..., res = dpi, units = 'in'),
60    pdf = grDevices::pdf,
61    png = function(...) png(..., res = dpi, units = 'in'),
62    svg = grDevices::svg,
63    pictex = grDevices::pictex,
64    tiff = function(...) tiff(..., res = dpi, units = 'in'),
65    win.metafile = grDevices::win.metafile,
66    cairo_pdf = grDevices::cairo_pdf,
67    cairo_ps = grDevices::cairo_ps,
68
69    quartz_pdf = quartz_dev('pdf', dpi),
70    quartz_png = quartz_dev('png', dpi),
71    quartz_jpeg = quartz_dev('jpeg', dpi),
72    quartz_tiff = quartz_dev('tiff', dpi),
73    quartz_gif = quartz_dev('gif', dpi),
74    quartz_psd = quartz_dev('psd', dpi),
75    quartz_bmp = quartz_dev('bmp', dpi),
76
77    CairoJPEG = load_device('CairoJPEG', 'Cairo', dpi = dpi),
78    CairoPNG = load_device('CairoPNG', 'Cairo', dpi = dpi),
79    CairoTIFF = load_device('CairoTIFF', 'Cairo', dpi = dpi),
80    CairoPS = load_device('CairoPS', 'Cairo'),
81    CairoPDF = load_device('CairoPDF', 'Cairo'),
82    CairoSVG = load_device('CairoSVG', 'Cairo'),
83
84    Cairo_pdf = load_device('Cairo_pdf', 'cairoDevice'),
85    Cairo_png = load_device('Cairo_png', 'cairoDevice'),
86    Cairo_ps = load_device('Cairo_ps', 'cairoDevice'),
87    Cairo_svg = load_device('Cairo_svg', 'cairoDevice'),
88
89    svglite = load_device('svglite', 'svglite'),
90
91    # similar to load_device(), but the `dpi` argument is named `res`
92    ragg_png = function(...) {
93      ragg_png_dev(..., res = dpi, units = 'in')
94    },
95
96    tikz = function(...) {
97      tikz_dev(..., sanitize = options$sanitize, standAlone = options$external)
98    }
99  )
100  if (!is.null(device)) return(device)
101  # custom device provided by user as a character string
102  if (!exists(dev, mode = 'function', envir = knit_global()))
103    stop('The graphical device ', sQuote(dev), ' was not found (as a function).')
104  get(dev, mode = 'function', envir = knit_global())
105}
106
107# quartz devices under Mac
108quartz_dev = function(type, dpi) {
109  force(type); force(dpi)
110  function(file, width, height, ...) {
111    grDevices::quartz(file = file, width = width, height = height, type = type, dpi = dpi, ...)
112  }
113}
114
115# a wrapper of the tikzDevice::tikz device
116tikz_dev = function(...) {
117  loadNamespace('tikzDevice')
118  packages = switch(
119    getOption('tikzDefaultEngine'),
120    pdftex = getOption('tikzLatexPackages'),
121    xetex = getOption('tikzXelatexPackages'),
122    luatex = getOption('tikzLualatexPackages')
123  )
124  tikzDevice::tikz(..., packages = c('\n\\nonstopmode\n', packages, .knitEnv$tikzPackages))
125}
126
127# a wrapper of the ragg::agg_png device
128ragg_png_dev = function(...) {
129  loadNamespace('ragg')
130  args = list(...)
131  # handle bg -> background gracefully
132  args$background = args$background %n% args$bg
133  args$bg = NULL
134  do.call(ragg::agg_png, args)
135}
136
137# save a recorded plot
138save_plot = function(plot, name, dev, width, height, ext, dpi, options) {
139
140  path = paste(name, ext, sep = '.')
141  # when cache=2 and plot file exists, just return the filename
142  if (options$cache == 2 && cache$exists(options$hash, options$cache.lazy)) {
143    if (in_base_dir(!file.exists(path))) {
144      purge_cache(options)
145      stop('cannot find ', path, '; the cache has been purged; please re-compile')
146    }
147    return(paste(name, if (dev == 'tikz' && options$external) 'pdf' else ext, sep = '.'))
148  }
149  device = dev_get(dev, options, dpi)
150  in_base_dir(plot2dev(plot, name, dev, device, path, width, height, options))
151}
152
153plot2dev = function(plot, name, dev, device, path, width, height, options) {
154  dargs = get_dargs(options$dev.args, dev)
155  # re-plot the recorded plot to an off-screen device
156  do.call(device, c(list(path, width = width, height = height), dargs))
157  showtext(options)  # maybe begin showtext and set options
158  print(plot)
159  dev.off()
160
161  # Cairo::CairoPS always adds the extension .ps, even if you have specified an
162  # extension like .eps (https://github.com/yihui/knitr/issues/1364)
163  if (dev == 'CairoPS') {
164    path2 = paste0(path, '.ps')
165    if (file.exists(path2)) file.rename(path2, path)
166  }
167
168  # compile tikz to pdf
169  if (dev == 'tikz') {
170    patch_tikz_tex(path)
171    if (options$external) path = tinytex::latexmk(path, getOption('tikzDefaultEngine'))
172  }
173
174  fig_process(options$fig.process, path, options)
175}
176
177# the tikz plot may contain raster legends, in which case we need to adjust the
178# paths of these PNG files: https://stackoverflow.com/a/58410965/559676
179patch_tikz_tex = function(path) {
180  d = dirname(path)
181  p = list.files(d, r <- '_ras[0-9]+[.]png$')
182  b = sans_ext(basename(path)); bs = sub(r, '', p)
183  # for foo.tex, there must be foo_ras[N].png, otherwise no need to patch foo.tex
184  if (!(b %in% bs)) return()
185  x = read_utf8(path)
186  r = '^(\\s*\\\\pgfimage\\[.+?]\\{)(.+?_ras[0-9]+}};\\s*)$'
187  i = grep(r, x)
188  i = i[grep(b, x[i], fixed = TRUE)]
189  x1 = sub(r, '\\1', x[i])
190  x2 = sub(r, '\\2', x[i])
191  if (is_windows()) d = gsub('\\\\', '/', d)
192  x[i] = paste0(x1, d, '/', x2)
193  write_utf8(x, path)
194}
195
196# filter the dev.args option
197get_dargs = function(dargs, dev) {
198  if (length(dargs) == 0) return()
199  if (is.list(dargs) && all(sapply(dargs, is.list))) {
200    # dev.args is list(dev1 = list(arg1 = val1, ...), dev2 = list(arg2, ...))
201    dargs = dargs[[dev]]
202  }
203  dargs
204}
205
206# this is mainly for Cairo and cairoDevice
207load_device = function(name, package, dpi = NULL) {
208  dev = getFromNamespace(name, package)
209  # dpi is for bitmap devices; units must be inches!
210  if (is.null(dpi)) dev else function(...) dev(..., dpi = dpi, units = 'in')
211}
212
213
214# merge low-level plotting changes
215merge_low_plot = function(x, idx = sapply(x, evaluate::is.recordedplot)) {
216  idx = which(idx); n = length(idx); m = NULL # store indices that will be removed
217  if (n <= 1) return(x)
218  i1 = idx[1]; i2 = idx[2]  # compare plots sequentially
219  for (i in 1:(n - 1)) {
220    # remove the previous plot and move its index to the next plot
221    if (is_low_change(x[[i1]], x[[i2]])) m = c(m, i1)
222    i1 = idx[i + 1]
223    i2 = idx[i + 2]
224  }
225  if (is.null(m)) x else x[-m]
226}
227
228#' Compare two recorded plots
229#'
230#' Check if one plot only contains a low-level update of another plot.
231#' @param p1,p2 Plot objects.
232#' @return Logical value indicating whether \code{p2} is a low-level update of
233#'   \code{p1}.
234#' @export
235#' @examples
236#' pdf(NULL)
237#' dev.control('enable')  # enable plot recording
238#' plot(1:10)
239#' p1 = recordPlot()
240#' abline(0, 1)  # add a line (a low-level change)
241#' p2 = recordPlot()
242#' plot(rnorm(100))
243#' p3 = recordPlot()  # draw a completely new plot
244#' dev.off()
245#' knitr::is_low_change(p1, p2)  # true
246#' knitr::is_low_change(p1, p3)  # false
247is_low_change = function(p1, p2) {
248  UseMethod('is_low_change')
249}
250
251#' @export
252is_low_change.default = function(p1, p2) {
253  p1 = p1[[1]]; p2 = p2[[1]]  # real plot info is in [[1]]
254  if (length(p2) < (n1 <- length(p1))) return(FALSE)  # length must increase
255  identical(p1[1:n1], p2[1:n1])
256}
257
258# recycle some plot options such as fig.cap, out.width/height, etc when there
259# are multiple plots per chunk
260.recyle.opts = c('fig.cap', 'fig.scap', 'fig.alt', 'fig.env', 'fig.pos', 'fig.subcap',
261                 'out.width', 'out.height', 'out.extra', 'fig.link')
262
263# when passing options to plot hooks, reduce the recycled options to scalars
264reduce_plot_opts = function(options) {
265  i = options$fig.cur %n% 1L
266  for (o in .recyle.opts) {
267    v = options[[o]]
268    if ((n <- length(v)) == 0) next
269    if ((j <- i %% n) == 0) j = n
270    options[o] = list(v[j])
271  }
272  options
273}
274
275# the memory address of a NativeSymbolInfo object will be lost if it is saved to
276# disk; see http://markmail.org/message/zat2r2pfsvhrsfqz for the full
277# discussion; the hack below was stolen (with permission) from RStudio:
278# https://github.com/rstudio/rstudio/blob/master/src/cpp/r/R/Tools.R
279fix_recordedPlot = function(plot) {
280  # restore native symbols for R >= 3.0
281  for (i in seq_along(plot[[1]])) {
282    # get the symbol then test if it's a native symbol
283    symbol = plot[[1]][[i]][[2]][[1]]
284    if (inherits(symbol, 'NativeSymbolInfo')) {
285      # determine the dll that the symbol lives in
286      name = symbol[[if (is.null(symbol$package)) 'dll' else 'package']][['name']]
287      pkgDLL = getLoadedDLLs()[[name]]
288      # reconstruct the native symbol and assign it into the plot
289      nativeSymbol = getNativeSymbolInfo(
290        name = symbol$name, PACKAGE = pkgDLL, withRegistrationInfo = TRUE
291      )
292      plot[[1]][[i]][[2]][[1]] <- nativeSymbol
293    }
294  }
295  attr(plot, 'pid') = Sys.getpid()
296  plot
297}
298
299# fix plots in evaluate() results
300fix_evaluate = function(list, fix = TRUE) {
301  if (!fix) return(list)
302  lapply(list, function(x) {
303    if (evaluate::is.recordedplot(x)) fix_recordedPlot(x) else x
304  })
305}
306
307# remove the plots from the evaluate results for the case of cache=2; if we only
308# want to keep high-level plots, we need MD5 digests of the plot components so
309# that we will be able to filter out low-level changes later
310remove_plot = function(list, keep.high = TRUE) {
311  lapply(list, function(x) {
312    if (evaluate::is.recordedplot(x)) structure(
313      if (keep.high) digest_plot(x) else NULL, class = 'recordedplot'
314    ) else x
315  })
316}
317# replace the content of the recorded plot with MD5 digests so that merge_plot()
318# will still work, and this will also save disk space for the case of cache=2
319digest_plot = function(x, level = 1) {
320  if (!is.list(x) || level >= 3) return(digest(x))
321  lapply(x, digest_plot, level = level + 1)
322}
323
324# a null device
325pdf_null = function(width = 7, height = 7, ...) {
326  grDevices::pdf(NULL, width, height, ...)
327}
328
329fig_process = function(FUN, path, options) {
330  if (is.function(FUN)) {
331    ARG = intersect(c("options", names(options)), names(formals(FUN)))
332    path2 = do.call(FUN, c(path, c(options = list(options), options)[ARG]))
333    if (!is.character(path2) || length(path2) != 1L)
334      stop("'fig.process' must be a function that returns a character string")
335    path = path2
336  }
337  path
338}
339
340#' Crop a plot (remove the edges) using PDFCrop or ImageMagick
341#'
342#' The program \command{pdfcrop} (often shipped with a LaTeX distribution) is
343#' executed on a PDF plot file, and
344#' \code{magick::\link[magick:transform]{image_trim}()} is executed for other
345#' types of plot files.
346#'
347#' The program \command{pdfcrop} can crop the extra white margins when the plot
348#' format is PDF, to make better use of the space in the output document,
349#' otherwise we often have to struggle with \code{graphics::\link{par}()} to set
350#' appropriate margins. Note \command{pdfcrop} often comes with a LaTeX
351#' distribution such as TinyTeX, MiKTeX, or TeX Live, and you may not need to
352#' install it separately (use \code{Sys.which('pdfcrop')} to check it; if it not
353#' empty, you are able to use it). Note that \command{pdfcrop} depends on
354#' GhostScript. You can check if GhostScript is installed via
355#' \code{tools::find_gs_cmd()}.
356#' @param x Filename of the plot.
357#' @param quiet Whether to suppress standard output from the command.
358#' @export
359#' @references PDFCrop: \url{https://www.ctan.org/pkg/pdfcrop}. If you use
360#'   TinyTeX, you may install \command{pdfcrop} with
361#'   \code{tinytex::tlmgr_install('pdfcrop')}.
362#' @return The original filename.
363plot_crop = function(x, quiet = TRUE) {
364  is_pdf = grepl('[.]pdf$', x, ignore.case = TRUE)
365  x2 = x
366  x = path.expand(x)
367  if (is_pdf && !has_utility('pdfcrop') && !has_utility('ghostscript')) return(x2)
368
369  if (!quiet) message('cropping ', x)
370  if (is_pdf) {
371    system2('pdfcrop', shQuote(c(x, x)), stdout = if (quiet) FALSE else "")
372  } else if (loadable('magick')) {
373    img = magick::image_read(x)
374    magick::image_write(magick::image_trim(img), x)
375  } else message(
376    'The magick package is required to crop "', x2, '" but not available.'
377  )
378  x2
379}
380
381showtext = function(options) {
382  if (!isTRUE(options$fig.showtext)) return()
383  showtext::showtext_opts(dpi = options$dpi)
384  showtext::showtext_begin()
385}
386
387# handle some special cases of par()
388par2 = function(x) {
389  if (length(x) == 0) return()
390  # this may not be correct, but there is no way to tell if the user set mfrow
391  # or mfcol in par() (either setting will change mfrow/mfcol simultaneously),
392  # and I just assume it was mfrow
393  if (!is.null(x$mfrow)) {
394    # do this before the rest of pars because setting mfrow/mfcol will reset cex
395    par(mfrow = x$mfrow)
396    x$mfrow = x$mfcol = NULL
397    # do not restore mfg (#1215); this is unlikely to make sense, e.g. for
398    # par(mfrow = c(1, 2)), mfg will be c(1, 2, 1, 2) when the second plot is
399    # completed, but when the user generate a new plot, it should typically be
400    # drawn at (1, 1) instead of (1, 2)
401    x$mfg = NULL
402  }
403  if (!is.null(x$fg)) {
404    # set fg before the rest of the par because
405    # it resets col to the same value #1603
406    par(fg = x$fg)
407    x$fg = NULL
408  }
409  # you are unlikely to want to reset these pars
410  x$fig = x$fin = x$pin = x$plt = x$usr = NULL
411  x$ask = NULL  # does not make sense for typical non-interactive R sessions
412  par(x)
413}
414
415#' Embed external images in \pkg{knitr} documents
416#'
417#' When plots are not generated from R code, there is no way for \pkg{knitr} to
418#' capture plots automatically. In this case, you may generate the images
419#' manually and pass their file paths to this function to include them in the
420#' output. The major advantage of using this function is that it is portable in
421#' the sense that it works for all document formats that \pkg{knitr} supports,
422#' so you do not need to think if you have to use, for example, LaTeX or
423#' Markdown syntax, to embed an external image. Chunk options related to
424#' graphics output that work for normal R plots also work for these images, such
425#' as \code{out.width} and \code{out.height}.
426#' @param path A character vector of image paths.
427#' @param auto_pdf Whether to use PDF images automatically when the output
428#'   format is LaTeX. If \code{TRUE}, then e.g. \file{foo/bar.png} will be
429#'   replaced by \file{foo/bar.pdf} if the latter exists. This can be useful
430#'   since normally PDF images are of higher quality than raster images like
431#'   PNG, when the output is LaTeX/PDF.
432#' @param dpi DPI (dots per inch) value. Used to calculate the output width (in
433#'   inches) of the images. This will be their actual width in pixels, divided
434#'   by \code{dpi}. If not provided, the chunk option \code{dpi} is used; if
435#'   \code{NA}, the output width will not be calculated.
436#' @param error Whether to signal an error if any files specified in the
437#'   \code{path} argument do not exist and are not web resources.
438#' @note This function is supposed to be used in R code chunks or inline R code
439#'   expressions. You are recommended to use forward slashes (\verb{/}) as path
440#'   separators instead of backslashes in the image paths.
441#'
442#'   The automatic calculation of the output width requires the \pkg{png}
443#'   package (for PNG images) or the \pkg{jpeg} package (for JPEG images). The
444#'   width will not be calculated if the chunk option \code{out.width} is
445#'   already provided or \code{dpi = NA}.
446#' @return The same as the input character vector \code{path} but it is marked
447#'   with special internal S3 classes so that \pkg{knitr} will convert the file
448#'   paths to proper output code according to the output format.
449#' @export
450include_graphics = function(
451  path, auto_pdf = getOption('knitr.graphics.auto_pdf', FALSE), dpi = NULL,
452  error = getOption('knitr.graphics.error', TRUE)
453) {
454  path = native_encode(path)  # https://d.cosx.org/d/420524
455  if (auto_pdf && is_latex_output()) {
456    path2 = with_ext(path, 'pdf')
457    i = file.exists(path2)
458    path[i] = path2[i]
459  }
460  # relative paths can be tricky in child documents, so don't error (#1957)
461  if (child_mode()) error = FALSE
462  if (error && length(p <- path[!xfun::is_web_path(path) & !file.exists(path)])) stop(
463    'Cannot find the file(s): ', paste0('"', p, '"', collapse = '; ')
464  )
465  structure(path, class = c('knit_image_paths', 'knit_asis'), dpi = dpi)
466}
467
468# calculate the width in inches for PNG/JPEG images given a DPI
469raster_dpi_width = function(path, dpi) {
470  if (!file.exists(path) || is.na(dpi)) return()
471  is_png = grepl('[.]png$', path, ignore.case = TRUE)
472  is_jpg = grepl('[.]jpe?g$', path, ignore.case = TRUE)
473  if (!is_png && !is_jpg) return()
474  if (is_png) {
475    if (!loadable('png')) return()
476    meta = attr(png::readPNG(path, native = TRUE, info = TRUE), 'info')
477    w = meta$dim[1]
478    if (!is.numeric(dpi)) dpi = meta$dpi[1]
479    if (!is.numeric(dpi)) return()  # cannot calculate the desired width
480  } else if (is_jpg) {
481    if (!loadable('jpeg')) return()
482    if (!is.numeric(dpi)) return()  # there is no dpi info in JPEG
483    w = ncol(jpeg::readJPEG(path, native = TRUE))
484  }
485  if (is_latex_output()) {
486    paste0(round(w / dpi, 2), 'in')
487  } else if (is_html_output()) {
488    round(w / (dpi / 96))
489  }
490}
491
492#' Embed a URL as an HTML iframe or a screenshot in \pkg{knitr} documents
493#'
494#' When the output format is HTML, \code{include_url()} inserts an iframe in the
495#' output; otherwise it takes a screenshot of the URL and insert the image in
496#' the output. \code{include_app()} takes the URL of a Shiny app and adds
497#' \samp{?showcase=0} to it (to disable the showcase mode), then passes the URL
498#' to \code{include_url()}.
499#' @param url A character vector of URLs.
500#' @param height A character vector to specify the height of iframes.
501#' @return An R object with a special class that \pkg{knitr} recognizes
502#'   internally to generate the iframes or screenshots.
503#' @seealso \code{\link{include_graphics}}
504#' @export
505include_url = function(url, height = '400px') {
506  include_url2(url, height)
507}
508
509include_url2 = function(url, height = '400px', orig = url) {
510  structure(
511    list(url = url, height = height, url.orig = orig),
512    class = c('knit_embed_url', 'knit_asis_url')
513  )
514}
515
516#' @rdname include_url
517#' @export
518include_app = function(url, height = '400px') {
519  orig = url  # store the original URL
520  i = !grepl('?', url, fixed = TRUE)
521  url[i] = paste0(url[i], '?showcase=0')
522  include_url2(url, height, orig)
523}
524
525need_screenshot = function(x, ...) {
526  options = list(...)[['options']]
527  # if users specify screenshot.force = FALSE, skip screenshot and render HTML
528  if (isFALSE(options$screenshot.force)) return(FALSE)
529  # force screenshotting even if the output format support HTML
530  force = is.list(options) && isTRUE(options$screenshot.force)
531  fmt = pandoc_to()
532  i1 = inherits(x, 'htmlwidget')
533  i2 = inherits(x, 'shiny.appobj')
534  i3 = inherits(x, 'knit_embed_url')
535  # not R Markdown v2, always screenshot htmlwidgets and shiny apps
536  if (length(fmt) == 0 || force) return(i1 || i2 || i3)
537  html_format = fmt %in% c('html', 'html4', 'html5', 'revealjs', 's5', 'slideous', 'slidy')
538  res = ((i1 || i3) && !html_format) || (i2 && !(html_format && runtime_shiny()))
539  res && any(webshot_available())
540}
541
542runtime_shiny = function() {
543  identical(opts_knit$get('rmarkdown.runtime'), 'shiny')
544}
545
546webshot_available = local({
547  res = NULL  # cache the availability of webshot2/Chrome and webshot/PhantomJS
548  test = function(pkg, fun, pkg2 = pkg) {
549    loadable(pkg) && tryCatch(
550      file.exists(getFromNamespace(fun, pkg2)()),
551      error = function(e) FALSE
552    )
553  }
554  function() {
555    if (is.null(res)) res <<- c(
556      webshot2 = test('webshot2', 'find_chrome', 'chromote'),
557      webshot  = test('webshot',  'find_phantom')
558    )
559    res
560  }
561})
562
563html_screenshot = function(x, options = opts_current$get(), ...) {
564  i1 = inherits(x, 'htmlwidget')
565  i2 = inherits(x, 'shiny.appobj')
566  i3 = inherits(x, 'knit_embed_url')
567  if (!(i1 || i2 || i3))
568    stop('Screenshotting for the class ', class(x)[1], ' is not supported.')
569
570  # if user has specified the screenshot image, just use it
571  if (!is.null(shots <- options$screenshot.alt)) {
572    i = shot_counter()
573    if (length(shots) < i) stop('Not enough number of screenshots provided')
574    return(structure(list(file = shots[i]), class = 'html_screenshot'))
575  }
576
577  ext = if (length(options$dev)) {
578    switch(options$dev[1], pdf = '.pdf', jpeg = '.jpeg', '.png')
579  } else '.png'
580  wargs = options$screenshot.opts %n% list()
581  if (is.null(wargs$vwidth)) wargs$vwidth = options$out.width.px
582  if (is.null(wargs$vheight)) wargs$vheight = options$out.height.px
583  if (is.null(wargs$delay)) wargs$delay = if (i1) 0.2 else 1
584  d = tempfile()
585  dir.create(d); on.exit(unlink(d, recursive = TRUE), add = TRUE)
586  w = webshot_available()
587  webshot = c(options$webshot, names(w)[w])
588  webshot = if (length(webshot) == 0) 'webshot' else webshot[[1L]]
589  f = in_dir(d, {
590    if (i1 || i3) {
591      if (i1) {
592        f1 = wd_tempfile('widget', '.html')
593        save_widget(x, f1, FALSE, options = options)
594      } else f1 = x$url
595      f2 = wd_tempfile('webshot', ext)
596      f3 = do.call(getFromNamespace('webshot', webshot), c(list(f1, f2), wargs))
597      normalizePath(f3)
598    } else if (i2) {
599      f1 = wd_tempfile('webshot', ext)
600      f2 = do.call(getFromNamespace('appshot', webshot), c(list(x, f1), wargs))
601      normalizePath(f2)
602    }
603  })
604  lapply(f, function(filename) {
605    res = xfun::read_bin(filename)
606    structure(
607      list(image = res, extension = ext, url = if (i3) x$url.orig[filename == f]),
608      class = 'html_screenshot'
609    )
610  })
611}
612
613save_widget = function(..., options) {
614  FUN = htmlwidgets::saveWidget
615  if ('knitrOptions' %in% names(formals(FUN))) {
616    FUN(..., knitrOptions = options)
617  } else FUN(...)
618}
619