Trim intermediate plots (#207)

Fixes #206

Author: hadley

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",evaluate_evaluation)
 S3method(parse_all,"function")
 S3method(parse_all,call)
 S3method(parse_all,character)
@@ -26,6 +27,7 @@ export(parse_all)
 export(remove_hooks)
 export(replay)
 export(set_hooks)
+export(trim_intermediate_plots)
 export(try_capture_stack)
 import(grDevices)
 import(graphics)

NEWS.md

@@ -1,5 +1,6 @@
 # evaluate (development version)
 
+* New `trim_intermediate_plots()` drops intermediate plots to reveal the complete/final plot (#206).
 * evaluation "chunks" now provide a function-like scope. This means that `on.exit()` will now run at the end of the evaluate code, rather than immediately and `return()` will cause the evaluation to finish (#201).
 * The default `value` handler now evaluates print in a child environment of the evaluation environment. This largely makes evaluate easier to test, but should make defining S3 methods for print a little easier (#192).
 * `parse_all()` adds a `\n` to the end of every line, even the last one if it didn't have one in the input.

R/evaluation.R

@@ -3,6 +3,15 @@ new_evaluation <- function(x) {
   structure(x, class = c("evaluate_evaluation", "list"))
 }
 
+is_evaluation <- function(x) {
+  inherits(x, "evaluate_evaluation")
+}
+
+#' @export
+`[.evaluate_evaluation` <- function(x, i, ...) {
+  new_evaluation(NextMethod())
+}
+
 #' @export
 print.evaluate_evaluation <- function(x, ...) {
   cat_line("<evaluation>")

R/graphics.R

@@ -9,6 +9,8 @@ local_plot_hooks <- function(f, frame = parent.frame()) {
   invisible()
 }
 
+# visual changes ---------------------------------------------------------
+
 looks_different <- function(old_dl, new_dl) {
   if (identical(old_dl, new_dl)) {
     return(FALSE)
@@ -54,3 +56,56 @@ non_visual_calls <- c(
   "C_strHeight", "C_strWidth", 
   "palette", "palette2"
 )
+
+# plot trimming ----------------------------------------------------------
+
+#' Trim away intermediate plots
+#' 
+#' Trim off plots that are modified by subsequent lines to only show
+#' the "final" plot.
+#' 
+#' @param x An evaluation object produced by [evaluate()].
+#' @return A modified evaluation object.
+#' @export
+#' @examples
+#' ev <- evaluate(c(
+#'   "plot(1:3)",
+#'   "text(1, 1, 'x')",
+#'   "text(1, 1, 'y')"
+#' ))
+#' 
+#' # All intermediate plots are captured
+#' ev
+#' # Only the final plot is shown
+#' trim_intermediate_plots(ev)
+trim_intermediate_plots <- function(x) {
+  if (!is_evaluation(x)) {
+    stop("`x` must be an evaluation object.")
+  }
+
+  is_plot <- vapply(x, is.recordedplot, logical(1))
+  plot_idx <- which(is_plot)
+  keep <- rep(TRUE, length(plot_idx))
+
+  prev_plot <- NULL
+  for (i in seq2(2, length(plot_idx))) {
+    cur_plot_dl <- x[[plot_idx[i]]][[1]]
+    prev_plot_dl <- x[[plot_idx[i - 1]]][[1]]
+
+    if (prev_plot_dl %is_prefix_of% cur_plot_dl) {
+      keep[i - 1] <- FALSE
+    }
+  }
+
+  idx <- seq_along(x)
+  idx <- setdiff(idx, plot_idx[!keep])
+  x[idx]
+}
+
+`%is_prefix_of%` <- function(x, y) {
+  if (length(x) > length(y)) {
+    return(FALSE)
+  }
+
+  identical(x[], y[seq_along(x)])
+}

man/trim_intermediate_plots.Rd

@@ -0,0 +1,8 @@
+# checks its input
+
+    Code
+      trim_intermediate_plots(1)
+    Condition
+      Error in `trim_intermediate_plots()`:
+      ! `x` must be an evaluation object.
+

tests/testthat/_snaps/graphics.md

@@ -222,3 +222,37 @@ test_that("evaluate ignores plots created in new device", {
   })
   expect_output_types(ev, c("source", "source", "source", "source", "plot"))
 })
+
+
+# trim_intermediate_plots ------------------------------------------------
+
+test_that("can trim off intermediate plots", {
+  ev <- evaluate(c(
+    "plot(1:3)",
+    "text(1, 1, 'x')",
+    "text(1, 1, 'y')"
+  ))
+  ev <- trim_intermediate_plots(ev)
+  expect_output_types(ev, c("source", "source", "source", "plot"))
+
+  ev <- evaluate(c(
+    "plot(1:3)",
+    "text(1, 1, 'x')",
+    "plot(1:3)",
+    "text(1, 1, 'y')"
+  ))
+  ev <- trim_intermediate_plots(ev)
+  expect_output_types(ev, c("source", "source", "plot", "source", "source", "plot"))
+})
+
+test_that("works with empty output", {
+  ev <- trim_intermediate_plots(evaluate(""))
+  expect_output_types(ev, "source")
+
+  ev <- trim_intermediate_plots(new_evaluation(list()))
+  expect_output_types(ev, character())
+})
+
+test_that("checks its input", {
+  expect_snapshot(trim_intermediate_plots(1), error = TRUE)
+})