diff --git a/NAMESPACE b/NAMESPACE index 92609ac..ae072e2 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 638a755..00cff7c 100644 --- a/NEWS.md +++ b/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. diff --git a/R/evaluation.R b/R/evaluation.R index 4f84089..cb0bb12 100644 --- a/R/evaluation.R +++ b/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("") diff --git a/R/graphics.R b/R/graphics.R index 89874c8..ae6fed1 100644 --- a/R/graphics.R +++ b/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)]) +} diff --git a/man/trim_intermediate_plots.Rd b/man/trim_intermediate_plots.Rd new file mode 100644 index 0000000..7edcd9a --- /dev/null +++ b/man/trim_intermediate_plots.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/graphics.R +\name{trim_intermediate_plots} +\alias{trim_intermediate_plots} +\title{Trim away intermediate plots} +\usage{ +trim_intermediate_plots(x) +} +\arguments{ +\item{x}{An evaluation object produced by \code{\link[=evaluate]{evaluate()}}.} +} +\value{ +A modified evaluation object. +} +\description{ +Trim off plots that are modified by subsequent lines to only show +the "final" plot. +} +\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) +} diff --git a/tests/testthat/_snaps/graphics.md b/tests/testthat/_snaps/graphics.md new file mode 100644 index 0000000..166f546 --- /dev/null +++ b/tests/testthat/_snaps/graphics.md @@ -0,0 +1,8 @@ +# checks its input + + Code + trim_intermediate_plots(1) + Condition + Error in `trim_intermediate_plots()`: + ! `x` must be an evaluation object. + diff --git a/tests/testthat/test-graphics.R b/tests/testthat/test-graphics.R index 618a4a3..2d12524 100644 --- a/tests/testthat/test-graphics.R +++ b/tests/testthat/test-graphics.R @@ -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) +})