tests/testit/test-plot.R

In knitr: A General-Purpose Package for Dynamic Report Generation in R

library(testit)

op = options(device = function(file = NULL, ...) {
  pdf(file, ...)
  dev.control('enable')  # important! otherwise plots get discarded
})

evaluate = evaluate::evaluate
classes = evaluate:::classes

# remove the blank plot
assert('blank plots are removed', {
  res = evaluate('layout(t(1:2))')
  (identical(classes(res), 'source'))
})

assert('plots generated by par(), palette() or layout() are removed', {
  res = evaluate('par(mfrow = c(1, 2))\npie(islands)\nbarplot(islands)')
  (identical(classes(res), rep(c('source', 'recordedplot'), c(3, 1))))
  res = evaluate('layout(t(1:2))\npie(islands)\nbarplot(islands)')
  (identical(classes(res), rep(c('source', 'recordedplot'), c(3, 1))))
  res = evaluate('pie(islands)\nbarplot(islands)\npar(mfrow = c(1, 2))')
  res = merge_low_plot(res)
  (identical(classes(res), rep(c('source', 'recordedplot'), length = 5)))
  res = evaluate('pie(islands)\npar(cex.main=1.2)\nbarplot(islands)')
  res = merge_low_plot(res)
  (identical(classes(res), c('source', 'recordedplot')[c(1, 2, 1, 1, 2)]))
  res = evaluate('par(cex.main=1.2)\npalette(c("red","black"))\nbarplot(islands)')
  (identical(classes(res), rep(c('source', 'recordedplot'), c(3, 1))))
})

assert('merge low-level changes', {
  res = evaluate('plot(1)\npoints(1.1, 1.1)')
  (classes(res) %==% rep(c('source', 'recordedplot'), 2))
  (classes(merge_low_plot(res)) %==% rep(c('source', 'recordedplot'), c(2, 1)))
})

assert('captures grid graphics', {
  res = evaluate('library(grid)
    grid.newpage()
    grid.rect(gp=gpar(fill="grey"))
    grid.rect(gp=gpar(fill="red"))')
  (classes(res) %==% c('source', 'recordedplot')[c(1, 1, 1, 2, 1, 2)])
  res = merge_low_plot(res)
  (identical(classes(res), rep(c('source', 'recordedplot'), c(4, 1))))
})

options(op)

# rmarkdown sets dev.args = list(pdf = list(useDingbats = FALSE)) when dev = 'pdf'
if (!has_error({png(); dev.off()})) {
  assert('chunk_device() correctly opens the png device with dev.args', {
    chunk_device(opts_chunk$merge(list(
      dev = 'png', dev.args = list(pdf = list(useDingbats = FALSE))
    )))
    plot(1:10)
    dev.off()
    TRUE
  })
}

if (requireNamespace("ragg", quietly = TRUE) &&
    !has_error({ragg::agg_png(); dev.off()})) {
  assert(
    'chunk_device() correctly opens the ragg::agg_png device with dev.args',
    {
      chunk_device(opts_chunk$merge(list(
        dev = 'ragg_png', dev.args = list(pdf = list(useDingbats = FALSE))
      )))
      plot(1:10)
      dev.off()
      TRUE
    }
  )
  assert(
    'ragg_png_dev correctly handles bg dev.arg into background arg',
    {
      chunk_device(opts_chunk$merge(list(
        dev = 'ragg_png', dev.args = list(bg = "grey")
      )))
      plot(1:10)
      dev.off()
      TRUE
    }
  )
}

# should not error (find `pdf` correctly in grDevices, instead of the one
# defined below)
pdf = function() {}
do.call(pdf_null, list(7, 7))
dev.off()


gen_source = function(x) structure(x, class = 'source')
gen_plotrc = function(x) structure(factor(x), class = c('factor', 'recordedplot'))

assert('fig_before_code() moves plots before code blocks', {
  res = list(
    gen_source(1), gen_plotrc('a'), gen_plotrc('b'), gen_source(2), gen_source(3),
    gen_plotrc('c'), gen_source(4), gen_plotrc('d')
  )
  (fig_before_code(res) %==% res[c(2, 3, 1, 4, 6, 5, 8, 7)])
})

assert('plots are rearrange based on fig.keep & fig.show options', {
  res = list(gen_source(1), gen_source(2))
  (rearrange_figs(res, 'high', NULL, 'asis') %==% res)
  # only one plot to keep
  res = c(evaluate('plot(1)'), list(gen_source(1)))
  (rearrange_figs(res, 'high', NULL, 'asis') %==% res)
  (rearrange_figs(res, 'all', NULL, 'asis') %==% res)
  (rearrange_figs(res, 'last', NULL, 'asis') %==% res)
  (rearrange_figs(res, 'first', NULL, 'asis') %==% res)
  (rearrange_figs(res, 'index', 2, 'asis') %==% res)
  # several plots
  res = c(list(gen_source(1)), evaluate('plot(1)\npoints(1.1, 1.1)'),
          list(gen_plotrc('b'), gen_source(2)))
  (rearrange_figs(res, 'high', NULL, 'asis') %==% res[-3])
  (rearrange_figs(res, 'all', NULL, 'asis') %==% res)
  (rearrange_figs(res, 'all', NULL, 'hold') %==% res[c(1:2, 4, 7, 3, 5, 6)])
  (rearrange_figs(res, 'last', NULL, 'asis') %==% res[c(-3, -5)])
  (rearrange_figs(res, 'first', NULL, 'asis') %==% res[c(-5, -6)])
  (rearrange_figs(res, 'none', NULL, 'asis') %==% res[c(-3, -5, -6)])
  # correspond to options$fig.keep with numeric vector
  (rearrange_figs(res, 'index', 1, 'asis') %==% res[c(-5, -6)])
  (rearrange_figs(res, 'index', c(2, 3), 'asis') %==% res[c(-3)])
  (rearrange_figs(res, 'index', c(2, 3), 'hold') %==% res[c(1:2, 4, 7, 5, 6)])
  (rearrange_figs(res, 'index', c(1, 2, 3), 'asis') %==% res)
})

# should not error when a plot label contains special characters and sanitize=TRUE
if (xfun::loadable('tikzDevice') &&
    (!is.na(Sys.getenv('CI', NA)) || Sys.getenv('USER') == 'yihui' || !xfun::is_macos())) {
  knit('knit-tikzDevice.Rnw', quiet = TRUE)
  unlink(c('*-tikzDictionary', 'figure', 'knit-tikzDevice.tex'), recursive = TRUE)
}

# https://github.com/yihui/knitr/issues/1166
knit(text = "\\Sexpr{include_graphics('myfigure.pdf', error = FALSE)}", quiet = TRUE)

assert('include_graphics() expands ~', {
  path1 = "~/test.png"
  (!has_warning(include_graphics("img/test.png", error = FALSE)))
  (unclass(suppressWarnings(include_graphics(path1, error = FALSE))) %==% path.expand(path1))
})

with_par = function(expr, ...) {
  # set par
  op = graphics::par(...)
  # reset on exit
  on.exit(graphics::par(op))
  # save changed state
  global.pars = par(no.readonly = TRUE)
  # reset par
  graphics::par(op)
  # simulate what happens when global.par = TRUE by restoring pars
  par2(global.pars)
  # evaluate in this state
  force(expr)
}

assert("par2 correctly handles specific pars", {
  (par2(NULL) %==% NULL)
  # correctly changed
  (with_par(par("col") %==% "red", col = "red"))
  (with_par(par("cex") %==% 2, cex = 2))
  # unchanged
  old = par("fig")
  (with_par(par("fig") %==% old, fig = old / 2))
  old = par("fin")
  (with_par(par("fin") %==% old, fin = old / 2))
  old = par("pin")
  (with_par(par("pin") %==% old, pin = old / 2))
  old = par("usr")
  (with_par(par("usr") %==% old, usr = old / 2))
  old = par("ask")
  (with_par(par("ask") %==% old, ask = !old))
  # Does not work - something else is changing plt when setting everything
  # old = par("plt")
  # (with_par(par("plt") %==% old, plt = old / 2))
})