export wrap() and is_low_change() to allow rgl (and other) graphics s…

…ystems to work like base graphics (#1892)

also closes #1853

Co-authored-by: Yihui Xie <xie@yihui.name>

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("$",knitr_strict_list)
+S3method(is_low_change,default)
 S3method(knit_print,default)
 S3method(knit_print,knit_asis)
 S3method(knit_print,knitr_kable)
@@ -70,6 +71,7 @@ export(include_url)
 export(inline_expr)
 export(is_html_output)
 export(is_latex_output)
+export(is_low_change)
 export(kable)
 export(kables)
 export(knit)
@@ -143,6 +145,7 @@ export(spin_child)
 export(stitch)
 export(stitch_rhtml)
 export(stitch_rmd)
+export(wrap)
 export(wrap_rmd)
 export(write_bib)
 import(grDevices)

NEWS.md

@@ -1,5 +1,9 @@
 # CHANGES IN knitr VERSION 1.33
 
+## NEW FEATURES
+
+- Exported the previously internal functions `wrap()` and `is_low_change()` to make it possible for other graphics systems such as **rgl** to work in **knitr** like base and grid graphics in base R (thanks, @dmurdoch, #1892 #1853).
+
 ## BUG FIXES
 
 - Reverted the fix for #1595 since it caused problems in **kableExtra** (thanks, @bttomio, haozhu233/kableExtra#607), and applied a different fix to the original problem (i.e., add `{}` before `[`).

R/block.R

@@ -278,9 +278,8 @@ eng_r = function(options) {
   # number of plots in this chunk
   if (is.null(options$fig.num))
     options$fig.num = if (length(res)) sum(sapply(res, function(x) {
-      if (evaluate::is.recordedplot(x)) return(1)
       if (inherits(x, 'knit_image_paths')) return(length(x))
-      if (inherits(x, 'html_screenshot')) return(1)
+      if (is_plot_output(x)) return(1)
       0
     })) else 0L
 
@@ -422,7 +421,8 @@ find_recordedplot = function(x) {
 }
 
 is_plot_output = function(x) {
-  evaluate::is.recordedplot(x) || inherits(x, 'knit_image_paths')
+  evaluate::is.recordedplot(x) ||
+    inherits(x, c('knit_image_paths', 'html_screenshot', 'knit_other_plot'))
 }
 
 # move plots before source code

R/output.R

@@ -428,25 +428,29 @@ knit_log = new_defaults()  # knitr log for errors, warnings and messages
 
 #' Wrap evaluated results for output
 #'
-#' @param x output from \code{evaluate::\link{evaluate}()}
-#' @param options List of options used to control output
-#' @noRd
+#' This function is mainly for internal use: it is called on each part of the
+#' output of the code chunk (code, messages, text output, and plots, etc.) after
+#' all statements in the code chunk have been evaluated.
+#' @param x Output from \code{evaluate::\link{evaluate}()}.
+#' @param options A list of chunk options used to control output.
+#' @param ... Other arguments to pass to methods.
+#' @export
 wrap = function(x, options = list(), ...) {
   UseMethod('wrap', x)
 }
 
 #' @export
-wrap.list = function(x, options = list()) {
+wrap.list = function(x, options = list(), ...) {
   if (length(x) == 0L) return(x)
   lapply(x, wrap, options)
 }
 
 # ignore unknown classes
 #' @export
-wrap.default = function(x, options) return()
+wrap.default = function(x, options, ...) return()
 
 #' @export
-wrap.character = function(x, options) {
+wrap.character = function(x, options, ...) {
   if (options$results == 'hide') return()
   if (output_asis(x, options)) {
     if (!out_format('latex')) return(x)  # latex output still need a tweak
@@ -457,7 +461,7 @@ wrap.character = function(x, options) {
 # If you provide a custom print function that returns a character object of
 # class 'knit_asis', it will be written as is.
 #' @export
-wrap.knit_asis = function(x, options, inline = FALSE) {
+wrap.knit_asis = function(x, options, inline = FALSE, ...) {
   m = attr(x, 'knit_meta')
   knit_meta_add(m, if (missing(options)) '' else options$label)
   if (!missing(options)) {
@@ -482,7 +486,7 @@ wrap.knit_asis = function(x, options, inline = FALSE) {
 }
 
 #' @export
-wrap.source = function(x, options) {
+wrap.source = function(x, options, ...) {
   if (isFALSE(options$echo)) return()
   src = sub('\n$', '', x$src)
   if (!options$collapse && options$strip.white) src = strip_white(src)
@@ -514,7 +518,7 @@ msg_sanitize = function(message, type) {
 }
 
 #' @export
-wrap.warning = function(x, options) {
+wrap.warning = function(x, options, ...) {
   call = if (is.null(x$call)) '' else {
     call = deparse(x$call)[1]
     if (call == 'eval(expr, envir, enclos)') '' else paste(' in', call)
@@ -523,17 +527,17 @@ wrap.warning = function(x, options) {
 }
 
 #' @export
-wrap.message = function(x, options) {
+wrap.message = function(x, options, ...) {
   msg_wrap(paste(x$message, collapse = ''), 'message', options)
 }
 
 #' @export
-wrap.error = function(x, options) {
+wrap.error = function(x, options, ...) {
   msg_wrap(as.character(x), 'error', options)
 }
 
 #' @export
-wrap.recordedplot = function(x, options) {
+wrap.recordedplot = function(x, options, ...) {
   # figure number sequence for multiple plots
   fig.cur = plot_counter()
   options$fig.cur = fig.cur # put fig num in options
@@ -555,7 +559,7 @@ wrap.recordedplot = function(x, options) {
 }
 
 #' @export
-wrap.knit_image_paths = function(x, options = opts_chunk$get(), inline = FALSE) {
+wrap.knit_image_paths = function(x, options = opts_chunk$get(), inline = FALSE, ...) {
   if (options$fig.show == 'hide') return('')
   # remove the automatically set out.width when fig.retina is set, otherwise the
   # size of external images embedded via include_graphics() will be set to
@@ -578,7 +582,7 @@ wrap.knit_image_paths = function(x, options = opts_chunk$get(), inline = FALSE)
 }
 
 #' @export
-wrap.html_screenshot = function(x, options = opts_chunk$get(), inline = FALSE) {
+wrap.html_screenshot = function(x, options = opts_chunk$get(), inline = FALSE, ...) {
   ext = x$extension
   in_base_dir({
     i = plot_counter()
@@ -603,7 +607,7 @@ run_hook_plot = function(x, options) {
 }
 
 #' @export
-wrap.knit_embed_url = function(x, options = opts_chunk$get(), inline = FALSE) {
+wrap.knit_embed_url = function(x, options = opts_chunk$get(), inline = FALSE, ...) {
   options$fig.cur = plot_counter()
   options = reduce_plot_opts(options)
   if (length(extra <- options$out.extra)) extra = paste('', extra, collapse = '')

R/plot.R

@@ -225,8 +225,31 @@ merge_low_plot = function(x, idx = sapply(x, evaluate::is.recordedplot)) {
   if (is.null(m)) x else x[-m]
 }
 
-# compare two recorded plots
+#' Compare two recorded plots
+#'
+#' Check if one plot only contains a low-level update of another plot.
+#' @param p1,p2 Plot objects.
+#' @return Logical value indicating whether \code{p2} is a low-level update of
+#'   \code{p1}.
+#' @export
+#' @examples
+#' pdf(NULL)
+#' dev.control('enable')  # enable plot recording
+#' plot(1:10)
+#' p1 = recordPlot()
+#' abline(0, 1)  # add a line (a low-level change)
+#' p2 = recordPlot()
+#' plot(rnorm(100))
+#' p3 = recordPlot()  # draw a completely new plot
+#' dev.off()
+#' knitr::is_low_change(p1, p2)  # true
+#' knitr::is_low_change(p1, p3)  # false
 is_low_change = function(p1, p2) {
+  UseMethod('is_low_change')
+}
+
+#' @export
+is_low_change.default = function(p1, p2) {
   p1 = p1[[1]]; p2 = p2[[1]]  # real plot info is in [[1]]
   if (length(p2) < (n1 <- length(p1))) return(FALSE)  # length must increase
   identical(p1[1:n1], p2[1:n1])