evaluate/0000755000176200001440000000000014740323162012062 5ustar liggesusersevaluate/tests/0000755000176200001440000000000014740317320013223 5ustar liggesusersevaluate/tests/testthat/0000755000176200001440000000000014740317320015063 5ustar liggesusersevaluate/tests/testthat/test-parse_all.R0000644000176200001440000001070414661412557020141 0ustar liggesuserstest_that("can parse empty input", { expect_equal(parse_all(character())$src, character()) }) test_that("can parse even if no expressions", { expect_equal(parse_all("")$src, "\n") expect_equal(parse_all("#")$src, "#\n") expect_equal(parse_all("#\n\n")$src, c("#\n", "\n")) }) test_that("every line gets nl", { expect_equal(parse_all("x")$src, "x\n") expect_equal(parse_all("")$src, "\n") expect_equal(parse_all("\n")$src, "\n") # even empty lines expect_equal(parse_all("a\n\nb")$src, c("a\n", "\n", "b\n")) expect_equal(parse_all("a\n\nb\n")$src, c("a\n", "\n", "b\n")) expect_equal(parse_all("\n\n")$src, c("\n", "\n")) }) test_that("empty lines are never silently dropped", { # It's not possible to simulate problem directly from code, but it can occur # in knitr # ```{r, tidy = TRUE}` # for (i in 1) {} # # two blank lines below # # # 1 # ``` expect_equal(parse_all(c("\n", "", "1"))$src, c("\n", "\n", "1\n")) }) test_that("a character vector is equivalent to a multi-line string", { expect_equal(parse_all(c("a", "b")), parse_all(c("a\nb"))) }) test_that("recombines multi-expression TLEs", { expect_equal(parse_all("1;2;3")$expr[[1]], expression(1, 2, 3)) expect_equal(parse_all("1+\n2;3")$expr[[1]], expression(1 + 2, 3)) expect_equal( parse_all("1+\n2;3+\n4; 5")$expr[[1]], expression(1 + 2, 3 + 4, 5) ) }) test_that("re-integrates lines without expressions", { expect_equal(parse_all("1\n\n2")$src, c("1\n", "\n", "2\n")) expect_equal(parse_all("1\n#\n2")$src, c("1\n", "#\n", "2\n")) }) test_that("expr is always an expression", { expect_equal(parse_all("#")$expr[[1]], expression()) expect_equal(parse_all("1")$expr[[1]], expression(1)) expect_equal(parse_all("1;2")$expr[[1]], expression(1, 2)) parsed <- parse_all("#\n1\n1;2") expect_equal(lengths(parsed$expr), c(0, 1, 2)) }) test_that("parse(allow_error = TRUE/FALSE)", { expect_error(parse_all("x <-", allow_error = FALSE)) res <- parse_all("x <-", allow_error = TRUE) expect_true(inherits(attr(res, "PARSE_ERROR"), "error")) # And correctly flows through to evaluate expect_no_error(evaluate("x <-", stop_on_error = 0)) }) test_that("double quotes in Chinese characters not destroyed", { skip_if_not(l10n_info()[["UTF-8"]]) out <- parse_all(c("1+1", '"你好"')) expect_equal(out$src[[2]], '"你好"\n') expect_equal(out$expr[[2]], expression("你好")) }) test_that("multibyte characters are parsed correctly", { skip_if_not(l10n_info()[["UTF-8"]]) code <- c("ϱ <- 1# g / ml", "äöüßÄÖÜπ <- 7 + 3# nonsense") out <- parse_all(code) expect_equal(out$src, paste0(code, "\n")) }) # input types ------------------------------------------------------------------ test_that("can parse a call", { out <- parse_all(quote(f(a, b, c))) expect_equal(out$src, "f(a, b, c)\n") expect_equal(out$expr, list(expression(f(a, b, c)))) }) test_that("can parse a connection", { path <- withr::local_tempfile(lines = c("# 1", "1 + 1")) cur_cons <- getAllConnections() con <- file(path) out <- parse_all(con) expect_equal(out$src, c("# 1\n", "1 + 1\n")) expect_equal(out$expr, list(expression(), expression(1 + 1))) # Doesn't leave any connections around expect_equal(getAllConnections(), cur_cons) }) test_that("can parse a function", { out <- parse_all(function() { # Hi 1 + 1 }) expect_equal(out$src, c("# Hi\n", "1 + 1\n")) expect_equal(out$expr, list(expression(), expression(1 + 1))) }) # find_function_body ----------------------------------------------------------- test_that("parsing a function parses its body", { out <- parse_all(function() { # Hi 1 + 1 }) expect_equal(out$src, c("# Hi\n", "1 + 1\n")) }) test_that("dedents function body", { f <- function() { 1 + 1 } expect_equal(find_function_body(f), "1 + 1") }) test_that("preserves src if possible", { f <- function() { 1 + 1 # hi } expect_equal(find_function_body(f), "1 + 1 # hi") f <- removeSource(f) expect_equal(find_function_body(f), "1 + 1") }) test_that("isn't flumoxed by nested parens", { f <- function() { { 1 + 1 } } expect_equal(find_function_body(f), c("{", " 1 + 1", "}")) }) test_that("works if no parens", { f <- function() 1 + 1 expect_equal(find_function_body(f), "1 + 1") f <- function() ( 1 + 1 ) expect_equal(find_function_body(f), "(1 + 1)") }) test_that("can handle empty body", { f <- function() {} expect_equal(find_function_body(f), character()) }) evaluate/tests/testthat/test-replay.R0000644000176200001440000000252214645307216017467 0ustar liggesuserstest_that("replay() should work when print() returns visible NULLs", { withr::local_options(prompt = "> ") print.FOO_BAR <- function(x, ...) NULL ret <- evaluate('structure(1, class = "FOO_BAR")') expect_snapshot(replay(ret)) }) test_that("replay handles various output types", { ev <- evaluate(function() { print("1") message("2") warning("3") stop("4") }) expect_snapshot(replay(ev)) }) test_that("replay handles rlang conditions", { ev <- evaluate(function() { rlang::inform("2") rlang::warn("3") rlang::abort("4", call = NULL) }) expect_snapshot(replay(ev)) }) test_that("replace nicely formats multiple lines", { ev <- evaluate("1 + \n 2") expect_snapshot(replay(ev)) }) test_that("can replay plots", { ev <- evaluate("plot(1)") path <- withr::local_tempfile() pdf(path) expect_output(replay(ev)) dev.off() expect_true(file.exists(path)) }) test_that("format_condition handles different types of warning", { expect_snapshot({ w1 <- simpleWarning("This is a warning") cat(format_condition(w1)) w2 <- simpleWarning("This is a warning", call = quote(f())) cat(format_condition(w2)) w3 <- rlang::warning_cnd(message = "This is a warning") cat(format_condition(w3)) w4 <- rlang::warning_cnd(message = "This is a warning") cat(format_condition(w4)) }) }) evaluate/tests/testthat/test-flush-console.R0000644000176200001440000000115614661412557020761 0ustar liggesuserstest_that("flush_console() is a null op by default", { expect_no_error(flush_console()) }) test_that("can set and restore output handler", { f <- function() message("Hi") old <- set_console_flusher(function() message("Hi")) expect_equal(the$console_flusher, f) expect_equal(old, NULL) expect_message(flush_console(), "Hi") old2 <- set_console_flusher(old) expect_equal(old2, f) }) test_that("can use flush_console() inside evaluate", { test <- function() { cat("hi") flush_console() cat("bye") } ev <- evaluate("test()") expect_equal(ev[[2]], "hi") expect_equal(ev[[3]], "bye") }) evaluate/tests/testthat/test-reproducible-output.R0000644000176200001440000000220614661412557022212 0ustar liggesuserstest_that("local_reproducible_output() respects local context", { local_reproducible_output(width = 105) expect_equal(getOption("width"), 105) local({ local_reproducible_output(width = 110) expect_equal(getOption("width"), 110) }) expect_equal(getOption("width"), 105) }) test_that("local_envvar respects local context", { local_envvar(test = "a") expect_equal(Sys.getenv("test"), "a") local({ local_envvar(test = "b") expect_equal(Sys.getenv("test"), "b") }) expect_equal(Sys.getenv("test"), "a") local({ local_envvar(test = NA) expect_equal(Sys.getenv("test"), "") }) expect_equal(Sys.getenv("test"), "a") }) test_that("local_collate respects local context", { locale <- switch(Sys.info()[["sysname"]], Darwin = , Linux = "en_US.UTF-8", Windows = if (getRversion() >= "4.2") "en-US" ) skip_if(is.null(locale), "Don't know good locale to use for this platform") local_collate("C") expect_equal(Sys.getlocale("LC_COLLATE"), "C") local({ local_collate(locale) expect_equal(Sys.getlocale("LC_COLLATE"), locale) }) expect_equal(Sys.getlocale("LC_COLLATE"), "C") }) evaluate/tests/testthat/test-output-handler.R0000644000176200001440000000560114661412557021152 0ustar liggesuserstest_that("calling handlers are checked", { expect_snapshot(error = TRUE, { check_handlers(list(condition = 1)) check_handlers(list(function(...) NULL)) check_handlers(stats::setNames(list(function(...) NULL), NA)) check_handlers(stats::setNames(list(function(...) NULL), "")) }) }) test_that("text output handler is called with text", { text <- NULL oh <- new_output_handler(text = function(o) text <<- o) evaluate("print('abc')", output_handler = oh) expect_equal(text, "[1] \"abc\"\n") }) test_that("graphic output handler not called with no graphics", { graphics <- NULL oh <- new_output_handler(graphics = function(o) graphics <<- 1) evaluate("print('abc')", output_handler = oh) expect_equal(graphics, NULL) }) test_that("can conditionally omit output with output handler", { hide_source <- function(src, tle) { if (length(tle) == 0) { src } else if (is.call(tle[[1]]) && identical(tle[[1]][[1]], quote(hide))) { NULL } else { src } } handler <- new_output_handler(source = hide_source) hide <- function(x) invisible(x) out <- evaluate("hide(x <- 1)\nx", output_handler = handler) expect_output_types(out, c("source", "text")) expect_snapshot(replay(out)) }) test_that("source handled called correctly when src is unparseable", { src <- NULL call <- NULL capture_args <- function(src, call) { src <<- src call <<- call src } handler <- new_output_handler(source = capture_args) evaluate("x + ", output_handler = handler) expect_equal(src, new_source("x + ")) expect_equal(call, expression()) }) test_that("return value of value handler inserted directly in output list", { skip_if_not_installed("ggplot2") ev <- evaluate( function() { rnorm(10) x <- list("I\'m a list!") ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) }, output_handler = new_output_handler(value = identity) ) expect_output_types(ev, c("source", "numeric", "source", "source", "gg")) }) test_that("invisible values can also be saved if value handler has two arguments", { handler <- new_output_handler(value = function(x, visible) { x # always returns a visible value }) expect_true(show_value(handler, FALSE)) ev <- evaluate("x<-1:10", output_handler = handler) expect_output_types(ev, c("source", "integer")) }) test_that("user can register calling handlers", { cnd <- structure(list(), class = c("foobar", "condition")) hnd <- function(cnd) handled <<- cnd handled <- NULL hnd <- function(cnd) handled <<- cnd out_hnd <- new_output_handler(calling_handlers = list(foobar = hnd)) evaluate("signalCondition(cnd)", output_handler = out_hnd) expect_s3_class(handled, "foobar") handled <- NULL out_hnd <- new_output_handler(calling_handlers = list(error = hnd)) evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd) expect_s3_class(handled, "error") }) evaluate/tests/testthat/test-conditions.R0000644000176200001440000001657514740245700020354 0ustar liggesuserstest_that("all condition handlers first capture output", { test <- function() { plot(1, main = "one") message("this is an message!") plot(2, main = "two") warning("this is a warning") plot(3, main = "three") stop("this is an error") } expect_output_types( evaluate("test()"), c("source", "plot", "message", "plot", "warning", "plot", "error") ) }) test_that("conditions get calls stripped", { expect_equal(evaluate("warning('x')")[[2]]$call, NULL) expect_equal(evaluate("stop('x')")[[2]]$call, NULL) # including errors emitted by C expect_equal(evaluate("mpg")[[2]]$call, NULL) expect_equal(evaluate("3()")[[2]]$call, NULL) }) test_that("envvar overrides keep_* arguments", { withr::local_envvar(R_EVALUATE_BYPASS_MESSAGES = "true") expect_message(ev <- evaluate("message('Hi!')", keep_message = FALSE), "Hi") expect_output_types(ev, "source") expect_warning(ev <- evaluate("warning('Hi!')", keep_warning = FALSE), "Hi") expect_output_types(ev, "source") }) # messages -------------------------------------------------------------------- test_that("all three states of keep_message work as expected", { test <- function() { message("Hi!") } # message captured in output expect_no_message(ev <- evaluate("test()", keep_message = TRUE)) expect_output_types(ev, c("source", "message")) # message propagated expect_message(ev <- evaluate("test()", keep_message = NA), "Hi") expect_output_types(ev, "source") # message ignored expect_no_message(ev <- evaluate("test()", keep_message = FALSE)) expect_output_types(ev, "source") }) # warnings -------------------------------------------------------------------- test_that("respects warn options", { # suppress warnings withr::local_options(warn = -1) ev <- evaluate("warning('hi')") expect_output_types(ev, "source") # delayed warnings are always immediate in knitr withr::local_options(warn = 0) ev <- evaluate("warning('hi')") expect_output_types(ev, c("source", "warning")) # immediate warnings withr::local_options(warn = 1) ev <- evaluate("warning('hi')") expect_output_types(ev, c("source", "warning")) # warnings become errors withr::local_options(warn = 2) ev <- evaluate("warning('hi')") expect_output_types(ev, c("source", "error")) }) test_that("all three states of keep_warning work as expected", { test <- function() { warning("Hi!") } # warning captured in output expect_no_warning(ev <- evaluate("test()", keep_warning = TRUE)) expect_output_types(ev, c("source", "warning")) # warning propagated expect_warning(ev <- evaluate("test()", keep_warning = NA), "Hi") expect_output_types(ev, "source") # warning ignored expect_no_warning(ev <- evaluate("test()", keep_warning = FALSE)) expect_output_types(ev, "source") }) test_that("log_warning causes warnings to be emitted", { f <- function() { warning("Hi!", immediate. = TRUE) } expect_snapshot(ev <- evaluate("f()", log_warning = TRUE)) # And still recorded in eval result expect_output_types(ev, c("source", "warning")) expect_equal(ev[[1]]$src, "f()\n") expect_equal(ev[[2]], simpleWarning("Hi!", quote(f()))) }) # errors ---------------------------------------------------------------------- test_that("an error terminates evaluation of multi-expression input", { ev <- evaluate("stop('1');2\n3") expect_output_types(ev, c("source", "error", "source", "text")) expect_equal(ev[[1]]$src, "stop('1');2\n") ev <- evaluate("stop('1');2\n3", stop_on_error = 1L) expect_equal(ev[[1]]$src, "stop('1');2\n") expect_output_types(ev, c("source", "error")) }) test_that("all three values of stop_on_error work as expected", { ev <- evaluate('stop("1")\n2', stop_on_error = 0L) expect_output_types(ev, c("source", "error", "source", "text")) ev <- evaluate('stop("1")\n2', stop_on_error = 1L) expect_output_types(ev, c("source", "error")) expect_snapshot(ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L), error = TRUE) }) test_that("errors during printing are captured", { methods::setClass("A", contains = "function", where = environment()) methods::setMethod("show", "A", function(object) stop("B")) a <- methods::new("A", function() b) ev <- evaluate("a") expect_output_types(ev, c("source", "error")) }) test_that("Error can be entraced and correctly handled in outputs", { skip_if_not_installed("rlang") skip_if_not_installed("knitr") skip_if_not_installed("callr") skip_on_cran() # install dev version of package in temp directory withr::local_temp_libpaths() quick_install(pkgload::pkg_path("."), lib = .libPaths()[1]) out <- withr::local_tempfile(fileext = ".txt") # Checking different way to entrace with evaluate ## No trace callr::rscript(test_path("ressources/with-stop-error-no-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'stop-error-no-trace.txt') ## Using calling.handler in evaluate's output handler callr::rscript(test_path("ressources/with-stop-error-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'stop-error-trace-calling-handler.txt') ## Using withCallingHandler() callr::rscript(test_path("ressources/with-stop-error-wch.R"), fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'stop-error-trace-wch.txt') ## Using abort() in evaluated code callr::rscript(test_path("ressources/with-abort-error.R"), fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'abort-error.txt') # setting option rlang_trace_top_env modified opt-out default evaluate trace trimming callr::rscript(test_path("ressources/with-stop-error-trace-trim.R"), fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'stop-error-trace-trim.txt', transform = function(lines) gsub("\\s*at evaluate/R/.*\\.R(:\\d+)*", "", lines)) # Checking error thrown when in rmarkdown and knitr context rscript <- withr::local_tempfile(fileext = ".R") out2 <- normalizePath(withr::local_tempfile(fileext = ".md"), winslash = "/", mustWork = FALSE) writeLines(c( "options(knitr.chunk.error = FALSE)", sprintf('knitr::knit("%s", output = "%s")', test_path("ressources/with-stop-error-auto-entrace.Rmd"), out2) ), con = rscript) callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'rmd-stop-error-auto-entrace.txt') writeLines(c( "options(knitr.chunk.error = FALSE)", sprintf('res <- knitr::knit("%s", output = "%s")', test_path("ressources/with-abort-error.Rmd"), out2) ), con = rscript) callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) expect_snapshot_file(out, name = 'rmd-abort-error.txt') # Checking error captured in cell output in rmarkdown and knitr context withr::with_options(list(options(knitr.chunk.error = TRUE)), { expect_snapshot_file( knitr::knit(test_path("ressources/with-stop-error-auto-entrace.Rmd"), output = out, quiet = TRUE), name = "rmd-stop-error.md" ) expect_snapshot_file( knitr::knit(test_path("ressources/with-stop-error-sewed.Rmd"), output = out, quiet = TRUE), name = "rmd-stop-error-entrace-sewed.md" ) expect_snapshot_file( knitr::knit(test_path("ressources/with-abort-error.Rmd"), output = out, quiet = TRUE), name = "rmd-abort-error.md" ) }) }) evaluate/tests/testthat/helper.R0000644000176200001440000000100314740245700016461 0ustar liggesusersexpect_output_types <- function(x, types) { output_types <- vapply(x, output_type, character(1)) expect_equal(output_types, types) } quick_install <- function(package, lib, quiet = TRUE) { opts <- c( "--data-compress=none", "--no-byte-compile", "--no-data", "--no-demo", "--no-docs", "--no-help", "--no-html", "--no-libs", "--use-vanilla", sprintf("--library=%s", lib), package ) invisible(callr::rcmd("INSTALL", opts, show = !quiet, fail_on_status = TRUE)) } evaluate/tests/testthat/test-graphics.R0000644000176200001440000001465414661412557020007 0ustar liggesuserstest_that("single plot is captured", { ev <- evaluate("plot(1:10)") expect_output_types(ev, c("source", "plot")) }) test_that("plot additions are captured", { ev <- evaluate(function() { plot(1:10) lines(1:10) }) expect_output_types(ev, c("source", "plot", "source", "plot")) }) test_that("blank plots created by plot.new() are preserved", { ev <- evaluate(function() { plot.new() plot(1:10) plot.new() plot(1:10) plot.new() }) expect_output_types(ev, rep(c("source", "plot"), 5)) }) test_that("evaluate doesn't open plots or create files", { n <- length(dev.list()) evaluate("plot(1)") expect_false(file.exists("Rplots.pdf")) expect_equal(length(dev.list()), n) }) test_that("base plots in a single expression are captured", { ev <- evaluate(function() { { plot(rnorm(100)) plot(rnorm(100)) plot(rnorm(100)) } }) expect_output_types(ev, c("source", "plot", "plot", "plot")) }) test_that("captures ggplots", { skip_if_not_installed("ggplot2") library(ggplot2) ev <- evaluate( "ggplot(mtcars, aes(mpg, wt)) + geom_point()" ) expect_output_types(ev, c("source", "plot")) ev <- evaluate(function() { for (j in 1:2) { print(ggplot(mtcars, aes(mpg, wt)) + geom_point()) } }) expect_output_types(ev, c("source", "plot", "plot")) }) test_that("erroring ggplots should not be recorded", { skip_if_not_installed("ggplot2") library(ggplot2) # error in aesthetics ev <- evaluate(function() { ggplot(iris, aes(XXXXXXXXXX, Sepal.Length)) + geom_boxplot() }) expect_output_types(ev, c("source", "error")) # error in geom ev <- evaluate(function() { ggplot(iris, aes(Species, Sepal.Length)) + geom_bar() }) expect_output_types(ev, c("source", "error")) }) test_that("multirow graphics are captured only when complete", { ev <- evaluate(function() { par(mfrow = c(1, 2)) plot(1) plot(2) }) expect_output_types(ev, c("source", "source", "source", "plot")) }) test_that("multirow graphics are captured on close even if not complete", { ev <- evaluate(function() { par(mfrow = c(1, 2)) plot(1) }) expect_output_types(ev, c("source", "source", "plot")) # Even if there's a comment at the end ev <- evaluate(function() { par(mfrow = c(1, 2)) plot(1) # comment }) expect_output_types(ev, c("source", "source", "source", "plot")) }) test_that("plots are captured in a non-rectangular layout", { ev <- evaluate(function() { for (j in 1:3) { layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE)) plot(rnorm(10)) plot(rnorm(10)) plot(rnorm(10)) plot(rnorm(10)) } }) expect_output_types(ev, c("source", "plot", "plot", "plot")) ev <- evaluate(function() { layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE)) # another expression before drawing the plots x <- 1 + 1 for (j in 1:2) { plot(rnorm(10)) plot(rnorm(10)) plot(rnorm(10)) plot(rnorm(10)) } }) expect_output_types(ev, rep(c("source", "plot"), c(4, 2))) }) test_that("changes in parameters don't generate new plots", { ev <- evaluate(function() { plot(1) par(mar = rep(0, 4)) plot(2) }) expect_output_types(ev, c("source", "plot", "source", "source", "plot")) }) test_that("multiple plots are captured even if calls in DL are the same", { ev <- evaluate(function() { barplot(1) barplot(2); barplot(3) }) expect_output_types(ev, c("source", "plot", "source", "plot", "plot")) }) test_that("strwidth()/strheight() should not produce new plots", { ev <- evaluate(function() { x <- strwidth("foo", "inches") y <- strheight("foo", "inches") plot(1) }) expect_output_types(ev, c("source", "source", "source", "plot")) }) test_that("clip() does not produce new plots", { ev <- evaluate(function() { plot(1) clip(-1, 1, -1, 1) points(1, col = "red") }) expect_output_types(ev, c("source", "plot", "source", "source", "plot")) }) test_that("perspective plots are captured", { x <- seq(-10, 10, length.out = 30) y <- x ff <- function(x, y) { r <- sqrt(x^2 + y^2) 10 * sin(r) / r } z <- outer(x, y, ff) z[is.na(z)] <- 1 ev <- evaluate(function() { for (i in 1:3) { persp(x, y, z, phi = 30 + i * 10, theta = 30) } }) expect_output_types(ev, c("source", "plot", "plot", "plot")) }) # a bug report yihui/knitr#722 test_that("plot state doesn't persist over evaluate calls", { expect_output_types(evaluate("plot(1)"), c("source", "plot")) expect_output_types(evaluate("plot(1)"), c("source", "plot")) expect_output_types(evaluate("plot(1)"), c("source", "plot")) }) test_that("evaluate() doesn't depend on device option", { path <- withr::local_tempfile() # This would error if used because recording is not enable withr::local_options(device = function() png(path)) ev <- evaluate("plot(1)") expect_output_types(ev, c("source", "plot")) }) # https://github.com/yihui/knitr/issues/2297 test_that("existing plot doesn't leak into evaluate()", { pdf(NULL) plot.new() defer(dev.off()) # errors because plot.new() called ev <- evaluate("lines(1)") expect_output_types(ev, c("source", "error")) }) test_that("evaluate restores existing plot", { pdf(NULL) d <- dev.cur() defer(dev.off()) ev <- evaluate("plot(1)") expect_output_types(ev, c("source", "plot")) expect_equal(dev.cur(), d) }) test_that("evaluate ignores plots created in new device", { ev <- evaluate(function() { pdf(NULL) plot(1) invisible(dev.off()) plot(1) }) 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) }) evaluate/tests/testthat/test-evaluate.R0000644000176200001440000000660114667574212020011 0ustar liggesuserstest_that("file with only comments runs", { ev <- evaluate(function() { # This test case contains no executable code # but it shouldn't throw an error }) expect_output_types(ev, c("source", "source")) }) test_that("can evaluate expressions of all lengths", { source <- " # a comment 1 x <- 2; x " expect_no_error(evaluate(source)) }) test_that("log_echo causes output to be immediately written to stderr()", { f <- function() { 1 } out <- capture.output( res <- evaluate("f()", log_echo = TRUE), type = "message" ) expect_equal(out, c("f()", "")) # But still recorded in eval result expect_output_types(res, c("source", "text")) expect_equal(res[[1]]$src, "f()\n") }) test_that("ACTIONS_STEP_DEBUG forces log_warning and log_echo to TRUE", { f <- function() { 1 warning("abc") } out <- local({ withr::local_envvar(ACTIONS_STEP_DEBUG = "true") capture.output(expect_warning(evaluate("f()"), "abc"), type = "message") }) expect_equal(out, c("f()", "")) }) test_that("data sets loaded", { skip_if_not_installed("lattice") ev <- evaluate(function() { data(barley, package = "lattice") barley }) expect_output_types(ev, c("source", "source", "text")) }) test_that("terminal newline not needed", { ev <- evaluate("cat('foo')") expect_output_types(ev, c("source", "text")) expect_equal(ev[[2]], "foo") }) test_that("S4 methods are displayed with show, not print", { methods::setClass("A", contains = "function", where = environment()) methods::setMethod("show", "A", function(object) cat("B")) a <- methods::new("A", function() b) ev <- evaluate("a") expect_equal(ev[[2]], "B") }) test_that("output and plots interleaved correctly", { ev <- evaluate(function() { for (i in 1:2) { cat(i) plot(i) } }) expect_output_types(ev, c("source", "text", "plot", "text", "plot")) ev <- evaluate(function() { for (i in 1:2) { plot(i) cat(i) } }) expect_output_types(ev, c("source", "plot", "text", "plot", "text")) }) test_that("multiple expressions on one line can get printed as expected", { ev <- evaluate("x <- 1; y <- 2; x; y") expect_output_types(ev, c("source", "text", "text")) }) test_that("multiple lines of comments do not lose the terminating \\n", { ev <- evaluate("# foo\n#bar") expect_output_types(ev, c("source", "source")) expect_equal(ev[[1]]$src, "# foo\n") }) test_that("check_stop_on_error converts integer to enum", { expect_equal(check_stop_on_error(0), "continue") expect_equal(check_stop_on_error(1), "stop") expect_equal(check_stop_on_error(2), "error") expect_snapshot(check_stop_on_error(4), error = TRUE) }) test_that("check_keep converts to logical as expected", { expect_true(check_keep(TRUE)$capture) expect_false(check_keep(NA)$capture) expect_false(check_keep(FALSE)$capture) expect_true(check_keep(TRUE)$silence) expect_false(check_keep(NA)$silence) expect_true(check_keep(FALSE)$silence) }) test_that("check_keep can integrate log option", { # logging means we never silence the ouptut expect_false(check_keep(TRUE, log = TRUE)$silence) expect_false(check_keep(NA, log = TRUE)$silence) expect_false(check_keep(FALSE, log = TRUE)$silence) }) test_that("check_keep errors with bad inputs", { expect_snapshot(error = TRUE, { check_keep(1, "keep_message") check_keep(c(TRUE, FALSE), "keep_message") }) }) evaluate/tests/testthat/test-output.R0000644000176200001440000000157314661412557017543 0ustar liggesusers# new_source ------------------------------------------------------------------- test_that("handles various numbers of arguments", { signal_condition <- function(class) { signalCondition(structure(list(), class = c(class, "condition"))) } expected <- structure(list(src = "x"), class = "source") # No handler expect_equal(new_source("x", quote(x)), expected) # One argument f1 <- function(src) signal_condition("handler_called") expect_condition(out <- new_source("x", quote(x), f1), class = "handler_called") expect_equal(out, expected) # Two arguments f2 <- function(src, call) { signal_condition("handler_called") NULL } expect_condition(out <- new_source("x", quote(x), f2), class = "handler_called") expect_equal(out, NULL) # Three arguments f3 <- function(a, b, c) NULL expect_snapshot(new_source("x", quote(x), f3), error = TRUE) }) evaluate/tests/testthat/test-evaluation.R0000644000176200001440000000031714661412557020345 0ustar liggesuserstest_that("has a reasonable print method", { f <- function() { print("1") message("2") warning("3") stop("4") } expect_snapshot({ evaluate("f()") evaluate("plot(1:3)") }) }) evaluate/tests/testthat/test-watchout.R0000644000176200001440000000276414661412557020044 0ustar liggesuserstest_that("capture messages in try() (#88)", { f <- function(x) stop(paste0("Obscure ", x)) g <- function() f("error") ev <- evaluate("try(g())") expect_output_types(ev, c("source", "text")) expect_match(ev[[2]], "Obscure error") }) test_that("code can use own sink", { f <- function() { con <- file("") defer(close(con)) sink(con) cat("One") sink() } ev <- evaluate("f()\n1") expect_output_types(ev, c("source", "source", "text")) }) test_that("evaluate preserves externally created sinks", { sink(withr::local_tempfile()) defer(sink()) n <- sink.number() ev <- evaluate("1") expect_output_types(ev, c("source", "text")) expect_equal(sink.number(), n) }) test_that("evaluate recovers from closed sink", { expect_snapshot(ev <- evaluate("sink()\n1")) expect_output_types(ev, c("source", "source", "text")) }) test_that("unbalanced sink doesn't break evaluate", { path <- withr::local_tempfile() ev <- evaluate(function() { sink(path) 1 1 }) expect_output_types(ev, c("source", "source", "source")) }) test_that("evaluate recovers from closed connection", { expect_snapshot(ev <- evaluate("closeAllConnections()\n1")) expect_output_types(ev, c("source", "source", "text")) }) test_that("isValid() works correctly", { con1 <- file("") expect_true(isValid(con1)) close(con1) expect_false(isValid(con1)) con2 <- file("") expect_false(isValid(con1)) # isOpen would return TRUE here expect_true(isValid(con2)) close(con2) }) evaluate/tests/testthat/_snaps/0000755000176200001440000000000014740245700016350 5ustar liggesusersevaluate/tests/testthat/_snaps/output.md0000644000176200001440000000030014701552712020224 0ustar liggesusers# handles various numbers of arguments Code new_source("x", quote(x), f3) Condition Error in `new_source()`: ! Source output handler must have one or two arguments evaluate/tests/testthat/_snaps/conditions.md0000644000176200001440000000046714740245700021052 0ustar liggesusers# log_warning causes warnings to be emitted Code ev <- evaluate("f()", log_warning = TRUE) Condition Warning in `f()`: Hi! # all three values of stop_on_error work as expected Code ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L) Condition Error: ! 1 evaluate/tests/testthat/_snaps/evaluate.md0000644000176200001440000000070714701552712020505 0ustar liggesusers# check_stop_on_error converts integer to enum Code check_stop_on_error(4) Condition Error: ! `stop_on_error` must be 0, 1, or 2. # check_keep errors with bad inputs Code check_keep(1, "keep_message") Condition Error: ! `keep_message` must be TRUE, FALSE, or NA. Code check_keep(c(TRUE, FALSE), "keep_message") Condition Error: ! `keep_message` must be TRUE, FALSE, or NA. evaluate/tests/testthat/_snaps/graphics.md0000644000176200001440000000024314701552712020472 0ustar liggesusers# checks its input Code trim_intermediate_plots(1) Condition Error in `trim_intermediate_plots()`: ! `x` must be an evaluation object. evaluate/tests/testthat/_snaps/evaluation.md0000644000176200001440000000115514701552712021044 0ustar liggesusers# has a reasonable print method Code evaluate("f()") Output Source code: f() Text output: [1] "1" Condition: 2 Condition: Warning in f(): 3 Condition: Error in f(): 4 Code evaluate("plot(1:3)") Output Source code: plot(1:3) Plot [8]: C_plot_new() palette2() C_plot_window() C_plotXY() C_axis() C_axis() C_box() C_title() evaluate/tests/testthat/_snaps/watchout.md0000644000176200001440000000027114701552713020532 0ustar liggesusers# evaluate recovers from closed sink Code ev <- evaluate("sink()\n1") # evaluate recovers from closed connection Code ev <- evaluate("closeAllConnections()\n1") evaluate/tests/testthat/_snaps/output-handler.md0000644000176200001440000000154414701552712021652 0ustar liggesusers# calling handlers are checked Code check_handlers(list(condition = 1)) Condition Error in `new_output_handler()`: ! `calling_handlers` must be a named list of functions. Code check_handlers(list(function(...) NULL)) Condition Error in `new_output_handler()`: ! `calling_handlers` must be a named list of functions. Code check_handlers(stats::setNames(list(function(...) NULL), NA)) Condition Error in `new_output_handler()`: ! `calling_handlers` must be a named list of functions. Code check_handlers(stats::setNames(list(function(...) NULL), "")) Condition Error in `new_output_handler()`: ! `calling_handlers` must be a named list of functions. # can conditionally omit output with output handler Code replay(out) Output > x [1] 1 evaluate/tests/testthat/_snaps/replay.md0000644000176200001440000000252614701552713020175 0ustar liggesusers# replay() should work when print() returns visible NULLs Code replay(ret) Output > structure(1, class = "FOO_BAR") NULL # replay handles various output types Code replay(ev) Output > print("1") [1] "1" > message("2") 2 > warning("3") Warning: 3 > stop("4") Error: 4 # replay handles rlang conditions Code replay(ev) Output > rlang::inform("2") 2 > rlang::warn("3") Warning: 3 > rlang::abort("4", call = NULL) Error: 4 # replace nicely formats multiple lines Code replay(ev) Output > 1 + + 2 [1] 3 # format_condition handles different types of warning Code w1 <- simpleWarning("This is a warning") cat(format_condition(w1)) Output Warning: This is a warning Code w2 <- simpleWarning("This is a warning", call = quote(f())) cat(format_condition(w2)) Output Warning in f(): This is a warning Code w3 <- rlang::warning_cnd(message = "This is a warning") cat(format_condition(w3)) Output Warning: This is a warning Code w4 <- rlang::warning_cnd(message = "This is a warning") cat(format_condition(w4)) Output Warning: This is a warning evaluate/tests/testthat/_snaps/conditions/0000755000176200001440000000000014740323162020520 5ustar liggesusersevaluate/tests/testthat/_snaps/conditions/rmd-stop-error.md0000644000176200001440000000022114740245700023732 0ustar liggesusers--- title: document with error --- ``` r f <- function() g() g <- function() h() h <- function() stop("!") f() ``` ``` ## Error in h(): ! ``` evaluate/tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md0000644000176200001440000000054514740245700026467 0ustar liggesusers--- title: document with error --- ``` r rlang::global_entrace() options(rlang_backtrace_on_error_report = "full") ``` ``` r f <- function() g() g <- function() h() h <- function() stop("!") f() ``` ``` ## Error in `h()`: ## ! ! ## Backtrace: ## x ## 1. \-evaluate (local) f() ## 2. \-evaluate (local) g() ## 3. \-evaluate (local) h() ``` evaluate/tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt0000644000176200001440000000036614740245700026550 0ustar liggesusers processing file: ressources/with-stop-error-auto-entrace.Rmd Error in `h()`: ! ! Backtrace: 1. global f() 2. global g() 3. global h() Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-stop-error-auto-entrace.Rmd) Execution halted evaluate/tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt0000644000176200001440000000021414740245700027511 0ustar liggesusersError in `h()`: ! ! Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Execution halted Ran 8/8 deferred expressions evaluate/tests/testthat/_snaps/conditions/stop-error-no-trace.txt0000644000176200001440000000023014740245700025077 0ustar liggesusersError in h() : ! Calls: ... withCallingHandlers -> withVisible -> eval -> eval -> f -> g -> h Execution halted Ran 8/8 deferred expressions evaluate/tests/testthat/_snaps/conditions/abort-error.txt0000644000176200001440000000025214740245700023517 0ustar liggesusersError in `h()`: ! ! Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() 4. \-rlang::abort("!") Execution halted Ran 8/8 deferred expressions evaluate/tests/testthat/_snaps/conditions/stop-error-trace-wch.txt0000644000176200001440000000021414740245700025246 0ustar liggesusersError in `h()`: ! ! Backtrace: x 1. \-global f() 2. \-global g() 3. \-global h() Execution halted Ran 8/8 deferred expressions evaluate/tests/testthat/_snaps/conditions/rmd-abort-error.md0000644000176200001440000000047014740245700024062 0ustar liggesusers--- title: document with error --- ``` r f <- function() g() g <- function() h() h <- function() rlang::abort("!") f() ``` ``` ## Error in `h()`: ## ! ! ## Backtrace: ## x ## 1. \-evaluate (local) f() ## 2. \-evaluate (local) g() ## 3. \-evaluate (local) h() ## 4. \-rlang::abort("!") ``` evaluate/tests/testthat/_snaps/conditions/rmd-abort-error.txt0000644000176200001440000000033614740245700024302 0ustar liggesusers processing file: ressources/with-abort-error.Rmd Error in `h()`: ! ! Backtrace: 1. global f() 2. global g() 3. global h() Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-abort-error.Rmd) Execution halted evaluate/tests/testthat/_snaps/conditions/stop-error-trace-trim.txt0000644000176200001440000000155614740245700025452 0ustar liggesusersError in `h()`: ! ! Backtrace: x 1. +-evaluate::evaluate(...) 2. | +-base::withRestarts(...) 3. | | \-base (local) withRestartList(expr, restarts) 4. | | +-base (local) withOneRestart(withRestartList(expr, restarts[-nr]), restarts[[nr]]) 5. | | | \-base (local) doWithOneRestart(return(expr), restart) 6. | | \-base (local) withRestartList(expr, restarts[-nr]) 7. | | \-base (local) withOneRestart(expr, restarts[[1L]]) 8. | | \-base (local) doWithOneRestart(return(expr), restart) 9. | +-evaluate:::with_handlers(...) 10. | | +-base::eval(call) 11. | | | \-base::eval(call) 12. | | \-base::withCallingHandlers(...) 13. | +-base::withVisible(eval(expr, envir)) 14. | \-base::eval(expr, envir) 15. | \-base::eval(expr, envir) 16. \-global f() 17. \-global g() 18. \-global h() Execution halted Ran 8/8 deferred expressions evaluate/tests/testthat/test-inject-funs.R0000644000176200001440000000027314634551613020421 0ustar liggesuserstest_that("can inject functons into evaluation context", { old <- inject_funs(f = function() 1) defer(inject_funs(old)) ev <- evaluate("f()") expect_equal(ev[[2]], "[1] 1\n") }) evaluate/tests/testthat/ressources/0000755000176200001440000000000014740245700017262 5ustar liggesusersevaluate/tests/testthat/ressources/with-stop-error-trace.R0000644000176200001440000000046714740245700023575 0ustar liggesuserstestthat::local_reproducible_output() handlers <- evaluate::new_output_handler( calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) ) evaluate::evaluate(function() { f <- function() g() g <- function() h() h <- function() stop("!") f() }, stop_on_error = 2L, output_handler = handlers) evaluate/tests/testthat/ressources/with-abort-error.R0000644000176200001440000000026314740245700022615 0ustar liggesuserstestthat::local_reproducible_output() evaluate::evaluate(function() { f <- function() g() g <- function() h() h <- function() rlang::abort("!") f() }, stop_on_error = 2L) evaluate/tests/testthat/ressources/with-stop-error-auto-entrace.Rmd0000644000176200001440000000016514740245700025402 0ustar liggesusers--- title: document with error --- ```{r} f <- function() g() g <- function() h() h <- function() stop("!") f() ``` evaluate/tests/testthat/ressources/with-stop-error-trace-trim.R0000644000176200001440000000057114740245700024542 0ustar liggesuserstestthat::local_reproducible_output() handlers <- evaluate::new_output_handler( calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) ) library(evaluate) options(rlang_trace_top_env = rlang::pkg_env("evaluate")) evaluate(function() { f <- function() g() g <- function() h() h <- function() stop("!") f() }, stop_on_error = 2L, output_handler = handlers) evaluate/tests/testthat/ressources/with-stop-error-sewed.Rmd0000644000176200001440000000031314740245700024115 0ustar liggesusers--- title: document with error --- ```{r} rlang::global_entrace() options(rlang_backtrace_on_error_report = "full") ``` ```{r} f <- function() g() g <- function() h() h <- function() stop("!") f() ``` evaluate/tests/testthat/ressources/with-abort-error.Rmd0000644000176200001440000000017514740245700023140 0ustar liggesusers--- title: document with error --- ```{r} f <- function() g() g <- function() h() h <- function() rlang::abort("!") f() ``` evaluate/tests/testthat/ressources/with-stop-error-wch.R0000644000176200001440000000037314740245700023254 0ustar liggesuserstestthat::local_reproducible_output() withCallingHandlers( error = function(cnd) rlang::entrace(cnd), evaluate::evaluate(function() { f <- function() g() g <- function() h() h <- function() stop("!") f() }, stop_on_error = 2L) ) evaluate/tests/testthat/ressources/with-stop-error-no-trace.R0000644000176200001440000000025314740245700024200 0ustar liggesuserstestthat::local_reproducible_output() evaluate::evaluate(function() { f <- function() g() g <- function() h() h <- function() stop("!") f() }, stop_on_error = 2L) evaluate/tests/test-all.R0000644000176200001440000000012314371256305015074 0ustar liggesuserslibrary(evaluate) if (require("testthat", quietly = TRUE)) test_check("evaluate") evaluate/MD50000644000176200001440000001142614740323162012376 0ustar liggesusers0c7b6980c626fc9aac832ff1ed2004c0 *DESCRIPTION 84608dd8acefaf79f48adad1e7e40991 *LICENSE 8aa475d3af1613b75abd625db0147fe6 *NAMESPACE 1f93c395ef1643d8239f79307cd6b04a *NEWS.md ee34fd32f672bfe78c312f71e983150b *R/conditions.R 321d64e22cd8a6c6767b0a925020a75b *R/evaluate-package.R 6dd9fa8a6fa1fbf2a348b51346b4e625 *R/evaluate.R fb4a60688b2c82aa5d7acf9911291b4c *R/evaluation.R 474407c336f046428511912b81af882e *R/flush-console.R 0c3135d2f30ba3853d8b8623ded91a2b *R/graphics.R 7bd2d5f21963974bf0998474ccc72dec *R/hooks.R 154e7a0aa903fdce0928315ed5e26db9 *R/inject-funs.R 6e213004b92752177b7b2d8cad9172d3 *R/output-handler.R ab94ef2ce4ffaaa2a214f5a48d837744 *R/output.R 5c2603f4b1369b153c2e67c8d8392286 *R/parse_all.R 5a46fed2db9cffb1cb1e812c495c7ef8 *R/replay.R 5ffc249af9ebc526a91c187439798e48 *R/reproducible-output.R 540fb3f16f20c0056ed8b58756c5f6ab *R/traceback.R a067717099a9905b8d4ec40cc861e967 *R/utils.R fb71fd775a1225d0dac8f9b8bf72157c *R/watchout.R 5cb0eaea51550fe601d814e36c251b6e *R/zzz.R 5e5dc31b541d5ca17c0bf7ad6e6cd9c7 *README.md cb5d4f7137189a9b73d1e344e768e3f5 *man/create_traceback.Rd 6829168629cb7aaab7e108aed01491eb *man/evaluate-package.Rd 0873cca9cc7bc5aa9441265967f4de1e *man/evaluate.Rd 66e3cafbe3eeba50d9bde4eaa9c82883 *man/flush_console.Rd d2556b1888973d222808b0f99a7f077a *man/inject_funs.Rd bcc5e1d85275d798afb6036dd823e3d8 *man/is.message.Rd 85c3a15a508816a85cda725ca9850a87 *man/line_prompt.Rd 7dc64e44c7039d93a8bd6a5a168b04f0 *man/local_reproducible_output.Rd b849c79dbf68b1f63271c7b85031a77a *man/new_output_handler.Rd 3ce26dcb7a949164221e0307e7364360 *man/parse_all.Rd cae57e5397174315b58629b9cefaf6f8 *man/replay.Rd 58eeb92a755374fae4100caffbd61abd *man/set_hooks.Rd e672364ab539d1c2f8bfbd63f0740fae *man/trim_intermediate_plots.Rd 53672d8333455458502c8632085d1f24 *man/try_capture_stack.Rd 7d1137c5d46bfb4567e5300009945ca2 *tests/test-all.R 873d339353417a6f733d87cb409fd120 *tests/testthat/_snaps/conditions.md a3b181e860e9d59b912606dfac582db8 *tests/testthat/_snaps/conditions/abort-error.txt 95b5b64998cdf94fae97090782a2d9fa *tests/testthat/_snaps/conditions/rmd-abort-error.md cee24af6617677358f58b4ddd062037f *tests/testthat/_snaps/conditions/rmd-abort-error.txt 3efb62753193bf3f4d757b15744dc909 *tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt 2dd1c2bc0bcd3567a948bed34082ce6d *tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md 49df8750fee8744aab7dda146c49b371 *tests/testthat/_snaps/conditions/rmd-stop-error.md 54425ad46486c500e48138f04c212a15 *tests/testthat/_snaps/conditions/stop-error-no-trace.txt 8d0d82a4e446fc856ca7d40f011cf0f4 *tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt 6b37bb1128b02de9e31fe550bb9b2cdb *tests/testthat/_snaps/conditions/stop-error-trace-trim.txt 8d0d82a4e446fc856ca7d40f011cf0f4 *tests/testthat/_snaps/conditions/stop-error-trace-wch.txt 710e4f5946cccf06c74c7ebf8c5564ff *tests/testthat/_snaps/evaluate.md 98c96bd69230580aab73dd0ddfa65dc3 *tests/testthat/_snaps/evaluation.md eb82009fc93498b4f1d5a6a7e7933c5b *tests/testthat/_snaps/graphics.md e4d4358340a3e744df012b1f948dbf4b *tests/testthat/_snaps/output-handler.md 647150561b8068b961dc3f5309e25171 *tests/testthat/_snaps/output.md 5bc7c1369e81fe76a2d2ffbf0b06e4b3 *tests/testthat/_snaps/replay.md 200cf5f9a4665db6f9b49859b38d35e1 *tests/testthat/_snaps/watchout.md 6df7e7f73c7593c2bc32c59c55f69f0e *tests/testthat/helper.R 9ac24dd4e29bab4a3ad04f9ce0ef0c5c *tests/testthat/ressources/with-abort-error.R 6fc9065122587f841b571b83b032ca7e *tests/testthat/ressources/with-abort-error.Rmd 5306bcc110d4e115829380817d50220e *tests/testthat/ressources/with-stop-error-auto-entrace.Rmd c0436bcea5a869e8644d205b666aa9ef *tests/testthat/ressources/with-stop-error-no-trace.R 2470df04067c49c23467cbf5ce667616 *tests/testthat/ressources/with-stop-error-sewed.Rmd ba9eefc838df44cd820e1e20a40c0685 *tests/testthat/ressources/with-stop-error-trace-trim.R 0253d8c937d539925cb54eff87fc4e20 *tests/testthat/ressources/with-stop-error-trace.R 7e54f029c0a282f279a1349c88b3684a *tests/testthat/ressources/with-stop-error-wch.R 652669e7928fbfc5aaca1ade381e8590 *tests/testthat/test-conditions.R 962643af2f4b668f46e85447d99d465b *tests/testthat/test-evaluate.R 911b0e79b02bd2406bf3b5f74864679d *tests/testthat/test-evaluation.R 7c65e09b6e57712bef945868c6170ed5 *tests/testthat/test-flush-console.R e71e3083ee78ea1d18262e352b789e0a *tests/testthat/test-graphics.R f6e736e65dd07ccbf99c85ffaaa01eb0 *tests/testthat/test-inject-funs.R 001a58b0d0633041b21de24cb0cd8886 *tests/testthat/test-output-handler.R cbfca5e9c5681dfa70cc8beb659c28aa *tests/testthat/test-output.R ea7a8a211f3daecd3e0fcdcac0036caa *tests/testthat/test-parse_all.R c0ebf9529291028b020e7881e2702f8d *tests/testthat/test-replay.R 883515868e8449a50e611a5a3e00ec46 *tests/testthat/test-reproducible-output.R fb50d4db4e6257f2de78ffc1d5943ebd *tests/testthat/test-watchout.R evaluate/R/0000755000176200001440000000000014740245700012264 5ustar liggesusersevaluate/R/traceback.R0000644000176200001440000000254714661412557014346 0ustar liggesusers#' Generate a traceback from a list of calls #' #' @param callstack stack of calls, as generated by (e.g.) #' [base::sys.calls()] #' @keywords internal #' @export create_traceback <- function(callstack) { if (length(callstack) == 0) { return() } # Convert to text calls <- lapply(callstack, deparse, width = 500) calls <- sapply(calls, paste0, collapse = "\n") # Number and indent calls <- paste0(seq_along(calls), ": ", calls) calls <- sub("\n", "\n ", calls) calls } #' Try, capturing stack on error #' #' This is a variant of [tryCatch()] that also captures the call #' stack if an error occurs. #' #' @param quoted_code code to evaluate, in quoted form #' @param env environment in which to execute code #' @keywords internal #' @export try_capture_stack <- function(quoted_code, env) { capture_calls <- function(e) { # Make sure a "call" component exists to avoid warnings with partial # matching in conditionCall.condition() e["call"] <- e["call"] # Capture call stack, removing last two calls from end (added by # withCallingHandlers), and first frame + 7 calls from start (added by # tryCatch etc) e$calls <- head(sys.calls()[-seq_len(frame + 7)], -2) signalCondition(e) } frame <- sys.nframe() tryCatch( withCallingHandlers(eval(quoted_code, env), error = capture_calls), error = identity ) } evaluate/R/hooks.R0000644000176200001440000000211714634551613013540 0ustar liggesusers#' Set and remove hooks #' #' This interface wraps the base [setHook()] function to provide a return #' value that makes it easy to undo. #' #' @param hooks a named list of hooks - each hook can either be a function or #' a list of functions. #' @param action `"replace"`, `"append"` or `"prepend"` #' @keywords internal #' @export #' @examples #' new1 <- list(before.plot.new = function() print("Plotted!")) #' new2 <- list(before.plot.new = function() print("Plotted Again!")) #' set_hooks(new1) #' set_hooks(new2) #' plot(1) #' remove_hooks(new1) #' plot(1) #' remove_hooks(new2) #' plot(1) set_hooks <- function(hooks, action = "append") { old <- list() for (hook_name in names(hooks)) { old[[hook_name]] <- getHook(hook_name) setHook(hook_name, hooks[[hook_name]], action = action) } invisible(old) } #' @rdname set_hooks #' @export remove_hooks <- function(hooks) { for (hook_name in names(hooks)) { hook <- getHook(hook_name) for (fun in unlist(hooks[hook_name])) { hook[sapply(hook, identical, fun)] <- NULL } setHook(hook_name, hook, "replace") } } evaluate/R/parse_all.R0000644000176200001440000001356314661412557014371 0ustar liggesusers#' Parse, retaining comments #' #' Works very similarly to parse, but also keeps original formatting and #' comments. #' #' @param x object to parse. Can be a string, a file connection, or a function. #' If a connection, will be opened and closed only if it was closed initially. #' @param filename string overriding the file name #' @param allow_error whether to allow syntax errors in `x` #' @return #' A data frame two columns, `src` and `expr`, and one row for each complete #' input in `x`. A complete input is R code that would trigger execution when #' typed at the console. This might consist of multiple expressions separated #' by `;` or one expression spread over multiple lines (like a function #' definition). #' #' `src` is a character vector of source code. Each element represents a #' complete input expression (which might span multiple line) and always has a #' terminal `\n`. #' #' `expr` is a list-column of [expression]s. The expressions can be of any #' length, depending on the structure of the complete input source: #' #' * If `src` consists of only only whitespace and/or comments, `expr` will #' be length 0. #' * If `src` a single scalar (like `TRUE`, `1`, or `"x"`), name, or #' function call, `expr` will be length 1. #' * If `src` contains multiple expressions separated by `;`, `expr` will #' have length two or more. #' #' The expressions have their srcrefs removed. #' #' If there are syntax errors in `x` and `allow_error = TRUE`, the data #' frame will have an attribute `PARSE_ERROR` that stores the error object. #' @export #' @examples #' # Each of these inputs are single line, but generate different numbers of #' # expressions #' source <- c( #' "# a comment", #' "x", #' "x;y", #' "x;y;z" #' ) #' parsed <- parse_all(source) #' lengths(parsed$expr) #' str(parsed$expr) #' #' # Each of these inputs are a single expression, but span different numbers #' # of lines #' source <- c( #' "function() {}", #' "function() {", #' " # Hello!", #' "}", #' "function() {", #' " # Hello!", #' " # Goodbye!", #' "}" #' ) #' parsed <- parse_all(source) #' lengths(parsed$expr) #' parsed$src parse_all <- function(x, filename = NULL, allow_error = FALSE) UseMethod("parse_all") #' @export parse_all.character <- function(x, filename = NULL, allow_error = FALSE) { if (any(grepl("\n", x))) { # Ensure that empty lines are not dropped by strsplit() x[x == ""] <- "\n" # Standardise to a character vector with one line per element; # this is the input that parse() is documented to accept x <- unlist(strsplit(x, "\n"), recursive = FALSE, use.names = FALSE) } n <- length(x) filename <- filename %||% "" src <- srcfilecopy(filename, x) if (allow_error) { exprs <- tryCatch(parse(text = x, srcfile = src), error = identity) if (inherits(exprs, "error")) { return(structure( data.frame(src = paste(x, collapse = "\n"), expr = empty_expr()), PARSE_ERROR = exprs )) } } else { exprs <- parse(text = x, srcfile = src) } srcref <- attr(exprs, "srcref", exact = TRUE) pos <- data.frame( start = vapply(srcref, `[[`, 7, FUN.VALUE = integer(1)), end = vapply(srcref, `[[`, 8, FUN.VALUE = integer(1)) ) pos$exprs <- exprs # parse() splits TLEs that use ; into multiple expressions so we # join together expressions that overlaps on the same line(s) line_group <- cumsum(is_new_line(pos$start, pos$end)) tles <- lapply(split(pos, line_group), function(p) { n <- nrow(p) data.frame( src = paste(x[p$start[1]:p$end[n]], collapse = "\n"), expr = I(list(p$exprs)), line = p$start[1] ) }) tles <- do.call(rbind, tles) # parse() drops comments and whitespace so we add them back in gaps <- data.frame(start = c(1, pos$end + 1), end = c(pos$start - 1, n)) gaps <- gaps[gaps$start <= gaps$end, , ] # some indexing magic in order to vectorise the extraction lengths <- gaps$end - gaps$start + 1 lines <- sequence(lengths) + rep(gaps$start, lengths) - 1 comments <- data.frame( src = x[lines], expr = empty_expr(length(lines)), line = lines ) res <- rbind(tles, comments) res <- res[order(res$line), c("src", "expr")] # Restore newlines stripped while converting to vector of lines if (length(res$src)) { res$src <- paste0(res$src, "\n") } else { res$src <- character() } res$expr <- lapply(res$expr, removeSource) rownames(res) <- NULL res } #' @export parse_all.connection <- function(x, filename = NULL, ...) { if (!isOpen(x, "r")) { open(x, "r") defer(close(x)) } text <- readLines(x) filename <- filename %||% summary(x)$description parse_all(text, filename, ...) } #' @export parse_all.function <- function(x, filename = NULL, ...) { filename <- filename %||% "" parse_all(find_function_body(x), filename = filename, ...) } # Calls are already parsed and always length one #' @export parse_all.call <- function(x, filename = NULL, ...) { parse_all(deparse(x), filename = filename, ...) } # Helpers --------------------------------------------------------------------- empty_expr <- function(n = 1) { I(rep(list(expression()), n)) } is_new_line <- function(start, end) { if (length(start) == 0) { logical() } else if (length(start) == 1) { TRUE } else { c(TRUE, start[-1] != end[-length(end)]) } } find_function_body <- function(f) { if (is_call(body(f), "{")) { lines <- deparse(f, control = "useSource") expr <- parse(text = lines, keep.source = TRUE) data <- getParseData(expr) token_start <- which(data$token == "'{'")[[1]] token_end <- last(which(data$token == "'}'")) line_start <- data$line1[token_start] + 1 line_end <- data$line2[token_end] - 1 lines <- lines[seq2(line_start, line_end)] dedent <- min(data$col1[seq2(token_start + 1, token_end - 1)], 1e3) substr(lines, dedent, nchar(lines)) } else { deparse(body(f)) } } evaluate/R/graphics.R0000644000176200001440000000477214661412557014231 0ustar liggesuserslocal_plot_hooks <- function(f, frame = parent.frame()) { hook_list <- list( persp = f, before.plot.new = f, before.grid.newpage = f ) set_hooks(hook_list) defer(remove_hooks(hook_list), frame) invisible() } # visual changes --------------------------------------------------------- looks_different <- function(old_dl, new_dl) { if (identical(old_dl, new_dl)) { return(FALSE) } # If the new plot has fewer calls, it must be a visual change if (length(new_dl) < length(old_dl)) { return(TRUE) } # If the initial calls are different, it must be a visual change if (!identical(old_dl[], new_dl[seq_along(old_dl)])) { return(TRUE) } # If the last calls involve visual changes then it's a visual change added_dl <- new_dl[-seq_along(old_dl)] makes_visual_change(added_dl) } makes_visual_change <- function(plot) { xs <- lapply(plot, function(x) x[[2]][[1]]) for (x in xs) { if (hasName(x, "name")) { # base graphics if (!x$name %in% non_visual_calls) { return(TRUE) } } else if (is.call(x)) { # grid graphics if (as.character(x[[1]]) != "requireNamespace") { return(TRUE) } } } FALSE } non_visual_calls <- c( "C_clip", "C_layout", "C_par", "C_plot_window", "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)]) } evaluate/R/conditions.R0000644000176200001440000000264214740245700014564 0ustar liggesuserscondition_handlers <- function(watcher, on_error, on_warning, on_message) { list( message = function(cnd) { watcher$capture_plot_and_output() if (on_message$capture) { watcher$push(cnd) } if (on_message$silence) { invokeRestart("muffleMessage") } }, warning = function(cnd) { # do not handle warnings that shortly become errors or have been silenced if (getOption("warn") >= 2 || getOption("warn") < 0) { return() } watcher$capture_plot_and_output() if (on_warning$capture) { cnd <- sanitize_call(cnd) watcher$push(cnd) } if (on_warning$silence) { invokeRestart("muffleWarning") } }, error = function(cnd) { watcher$capture_plot_and_output() cnd <- sanitize_call(cnd) watcher$push(cnd) switch(on_error, continue = invokeRestart("eval_continue"), stop = invokeRestart("eval_stop"), # No need to invoke a restart as we want the error to be thrown in this case. error = NULL ) } ) } with_handlers <- function(code, handlers) { if (!is.list(handlers)) { stop("`handlers` must be a list", call. = FALSE) } call <- as.call(c(quote(withCallingHandlers), quote(code), handlers)) eval(call) } sanitize_call <- function(cnd) { if (identical(cnd$call, quote(eval(expr, envir)))) { cnd$call <- NULL } cnd } evaluate/R/zzz.R0000644000176200001440000000074114740245700013246 0ustar liggesusers# used evaluate() to avoid overhead of calling new_output_handler() repeatedly evaluate_default_output_handler <- NULL # used by knitr, as above, but also for value handler default_output_handler <- NULL .onLoad <- function(...) { evaluate_default_output_handler <<- new_output_handler() default_output_handler <<- new_output_handler() # Match knitr's expectations default_output_handler$value <<- function(x) { render(x, visible = TRUE, envir = parent.frame()) } } evaluate/R/output.R0000644000176200001440000000267714661412557013773 0ustar liggesusersnew_source <- function(src, call, handler = NULL) { src <- structure(list(src = src), class = "source") if (is.null(handler)) { return(src) } n_args <- length(formals(handler)) if (n_args == 1) { # Old format only called for side effects handler(src) src } else if (n_args == 2) { # New format can influence result handler(src, call) } else { stop("Source output handler must have one or two arguments") } } # If the output handler has two arguments, then the user has opted into # handling the value regardless of whether it's not visible. show_value <- function(handler, visible) { visible || length(formals(handler$value)) > 1 } handle_value <- function(handler, value, visible, envir = parent.frame()) { n_args <- length(formals(handler$value)) if (n_args == 1) { handler$value(value) } else if (n_args == 2) { handler$value(value, visible) } else if (n_args == 3) { handler$value(value, visible, envir) } else { stop("Value output handler must have one or two arguments") } } render <- function(value, visible, envir) { if (!visible) { return(invisible()) } if (isS4(value)) { methods::show(value) } else { # We need to evaluate the print() generic in a child environment of the # evaluation frame in order to find any methods registered there print_env <- new.env(parent = envir) print_env$value <- value evalq(print(value), envir = print_env) } } evaluate/R/output-handler.R0000644000176200001440000000766314661412557015406 0ustar liggesusers#' Custom output handlers #' #' An `output_handler` handles the results of [evaluate()], #' including the values, graphics, conditions. Each type of output is handled by #' a particular function in the handler object. #' #' The handler functions should accept an output object as their first argument. #' The return value of the handlers is ignored, except in the case of the #' `value` handler, where a visible return value is saved in the output #' list. #' #' Calling the constructor with no arguments results in the default handler, #' which mimics the behavior of the console by printing visible values. #' #' Note that recursion is common: for example, if `value` does any #' printing, then the `text` or `graphics` handlers may be called. #' #' @param source Function to handle the echoed source code under evaluation. #' This function should take two arguments (`src` and `expr`), and return #' an object that will be inserted into the evaluate outputs. `src` is the #' unparsed text of the source code, and `expr` is the complete input #' expression (which may have 0, 1, 2, or more components; see [parse_all()] #' for details). #' #' Return `src` for the default evaluate behaviour. Return `NULL` to #' drop the source from the output. #' @param text Function to handle any textual console output. #' @param graphics Function to handle graphics, as returned by #' [recordPlot()]. #' @param message Function to handle [message()] output. #' @param warning Function to handle [warning()] output. #' @param error Function to handle [stop()] output. #' @param value Function to handle the values returned from evaluation. #' * If it has one argument, it called on visible values. #' * If it has two arguments, it handles all values, with the second #' argument indicating whether or not the value is visible. #' * If it has three arguments, it will be called on all values, with the #' the third argument given the evaluation environment which is needed #' to look up print methods for S3 objects. #' @param calling_handlers List of [calling handlers][withCallingHandlers]. #' These handlers have precedence over the exiting handler installed #' by [evaluate()] when `stop_on_error` is set to 0. #' @return A new `output_handler` object #' @aliases output_handler #' @export new_output_handler <- function(source = identity, text = identity, graphics = identity, message = identity, warning = identity, error = identity, value = render, calling_handlers = list()) { source <- match.fun(source) stopifnot(length(formals(source)) >= 1) text <- match.fun(text) stopifnot(length(formals(text)) >= 1) graphics <- match.fun(graphics) stopifnot(length(formals(graphics)) >= 1) message <- match.fun(message) stopifnot(length(formals(message)) >= 1) warning <- match.fun(warning) stopifnot(length(formals(warning)) >= 1) error <- match.fun(error) stopifnot(length(formals(error)) >= 1) value <- match.fun(value) stopifnot(length(formals(value)) >= 1) check_handlers(calling_handlers) structure( list( source = source, text = text, graphics = graphics, message = message, warning = warning, error = error, value = value, calling_handlers = calling_handlers ), class = "output_handler" ) } check_handlers <- function(x) { if (!is.list(x)) { stop_bad_handlers() } if (!length(x)) { return() } names <- names(x) if (!is.character(names) || anyNA(names) || any(names == "")) { stop_bad_handlers() } for (elt in x) { if (!is.function(elt)) { stop_bad_handlers() } } } stop_bad_handlers <- function() { stop(simpleError( "`calling_handlers` must be a named list of functions.", call = call("new_output_handler") )) } evaluate/R/reproducible-output.R0000644000176200001440000000635714661412557016447 0ustar liggesusers#' Control common output options #' #' @description #' Often when using `evaluate()` you are running R code with a specific output #' context in mind. But there are many options and env vars that packages #' will take from the current environment, meaning that output depends on #' the current state in undesirable ways. #' #' This function allows you to describe the characteristics of the desired #' output and takes care of setting the options and environment variables #' for you. #' #' @export #' @param width Value of the `"width"` option. #' @param color Determines whether or not cli/crayon colour should be used. #' @param unicode Should we use unicode characaters where possible? #' @param hyperlinks Should we use ANSI hyperlinks? #' @param rstudio Should we pretend that we're running inside of RStudio? #' @param frame Scope of the changes; when this calling frame terminates the #' changes will be undone. For expert use only. local_reproducible_output <- function(width = 80, color = FALSE, unicode = FALSE, hyperlinks = FALSE, rstudio = FALSE, frame = parent.frame()) { local_options( # crayon crayon.enabled = color, # cli cli.width = width, cli.condition_width = width, cli.num_colors = if (color) 8L else 1L, cli.hyperlink = hyperlinks, cli.hyperlink_run = hyperlinks, cli.hyperlink_help = hyperlinks, cli.hyperlink_vignette = hyperlinks, cli.unicode = unicode, cli.dynamic = FALSE, # base R width = width, useFancyQuotes = unicode, # rlang rlang_interactive = FALSE, .frame = frame ) local_envvar( NO_COLOR = if (color) NA else 1, # Simulate RStudio RSTUDIO = if (rstudio) 1 else NA, RSTUDIO_SESSION_PID = if (rstudio) Sys.getpid() else NA, RSTUDIO_CHILD_PROCESS_PANE = if (rstudio) "build" else NA, RSTUDIO_CLI_HYPERLINKS = if (rstudio) 1 else NA, RSTUDIO_CONSOLE_WIDTH = width, .frame = frame ) local_collate("C", frame = frame) invisible() } local_options <- function(..., .frame = parent.frame()) { old <- options(...) defer(options(old), .frame) invisible() } local_envvar <- function(..., .frame = parent.frame()) { old <- set_envvar(list(...)) defer(set_envvar(old), .frame) invisible() } local_collate <- function(locale, frame = parent.frame()) { old <- Sys.getlocale("LC_COLLATE") defer(Sys.setlocale("LC_COLLATE", old), frame) Sys.setlocale("LC_COLLATE", locale) # From https://github.com/r-lib/withr/blob/v3.0.0/R/locale.R#L51-L55: # R supports setting LC_COLLATE to C via envvar. When that is the # case, it takes precedence over the currently set locale. We need # to set both the envvar and the locale for collate to fully take # effect. local_envvar(LC_COLLATE = locale, .frame = frame) invisible() } # adapted from withr:::set_envvar set_envvar <- function(envs) { if (length(envs) == 0) { return() } old <- Sys.getenv(names(envs), names = TRUE, unset = NA) set <- !is.na(envs) if (any(set)) do.call("Sys.setenv", as.list(envs[set])) if (any(!set)) Sys.unsetenv(names(envs)[!set]) invisible(old) } evaluate/R/evaluate-package.R0000644000176200001440000000020214635236223015603 0ustar liggesusers#' @keywords internal "_PACKAGE" the <- new.env(parent = emptyenv()) ## usethis namespace: start ## usethis namespace: end NULL evaluate/R/evaluate.R0000644000176200001440000001500214740245700014213 0ustar liggesusers#' Evaluate input and return all details of evaluation #' #' Compare to [eval()], `evaluate` captures all of the #' information necessary to recreate the output as if you had copied and pasted #' the code into a R terminal. It captures messages, warnings, errors and #' output, all correctly interleaved in the order in which they occured. It #' stores the final result, whether or not it should be visible, and the #' contents of the current graphics device. #' #' @export #' @param input input object to be parsed and evaluated. May be a string, file #' connection or function. Passed on to [parse_all()]. #' @param envir environment in which to evaluate expressions. #' @param enclos when `envir` is a list or data frame, this is treated as #' the parent environment to `envir`. #' @param debug if `TRUE`, displays information useful for debugging, #' including all output that evaluate captures. #' @param stop_on_error A number between 0 and 2 that controls what happens #' when the code errors: #' #' * If `0`, the default, will continue running all code, just as if you'd #' pasted the code into the command line. #' * If `1`, evaluation will stop on first error without signaling the error, #' and you will get back all results up to that point. #' * If `2`, evaluation will halt on first error and you will get back no #' results. #' @param keep_warning,keep_message A single logical value that controls what #' happens to warnings and messages. #' #' * If `TRUE`, the default, warnings and messages will be captured in the #' output. #' * If `NA`, warnings and messages will not be captured and bubble up to #' the calling environment of `evaluate()`. #' * If `FALSE`, warnings and messages will be completed supressed and #' not shown anywhere. #' #' Note that setting the envvar `R_EVALUATE_BYPASS_MESSAGES` to `true` will #' force these arguments to be set to `NA`. #' @param log_echo,log_warning If `TRUE`, will immediately log code and #' warnings (respectively) to `stderr`. #' #' This will be force to `TRUE` if env var `ACTIONS_STEP_DEBUG` is #' `true`, as when debugging a failing GitHub Actions workflow. #' @param new_device if `TRUE`, will open a new graphics device and #' automatically close it after completion. This prevents evaluation from #' interfering with your existing graphics environment. #' @param output_handler an instance of [output_handler()] that #' processes the output from the evaluation. The default simply prints the #' visible return values. #' @param filename string overrriding the [base::srcfile()] filename. #' @param include_timing Deprecated. #' @import graphics grDevices utils #' @examples #' evaluate(c( #' "1 + 1", #' "2 + 2" #' )) #' #' # Not that's there's a difference in output between putting multiple #' # expressions on one line vs spreading them across multiple lines #' evaluate("1;2;3") #' evaluate(c("1", "2", "3")) #' #' # This also affects how errors propagate, matching the behaviour #' # of the R console #' evaluate("1;stop(2);3") #' evaluate(c("1", "stop(2)", "3")) evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE, stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE, log_echo = FALSE, log_warning = FALSE, new_device = TRUE, output_handler = NULL, filename = NULL, include_timing = FALSE) { on_error <- check_stop_on_error(stop_on_error) # if this env var is set to true, always bypass messages if (env_var_is_true("R_EVALUATE_BYPASS_MESSAGES")) { keep_message <- NA keep_warning <- NA } if (env_var_is_true("ACTIONS_STEP_DEBUG")) { log_warning <- TRUE log_echo <- TRUE } on_message <- check_keep(keep_message, "keep_message") on_warning <- check_keep(keep_warning, "keep_warning", log_warning) output_handler <- output_handler %||% evaluate_default_output_handler if (isTRUE(include_timing)) { warning("`evaluate(include_timing)` is deprecated") } # Capture output watcher <- watchout(output_handler, new_device = new_device, debug = debug) if (on_error != "error" && !can_parse(input)) { err <- tryCatch(parse(text = input), error = function(cnd) cnd) watcher$push_source(input, expression()) watcher$push(err) return(watcher$get()) } parsed <- parse_all(input, filename = filename) # "Transpose" parsed so we get a list that's easier to iterate over tles <- Map( function(src, exprs) list(src = src, exprs = exprs), parsed$src, parsed$expr ) if (is.list(envir)) { envir <- list2env(envir, parent = enclos %||% parent.frame()) } local_inject_funs(envir) if (is.null(getOption("rlang_trace_top_env"))) { # If not already set, indicate the top environment to trim traceback options(rlang_trace_top_env = envir) } # Handlers for warnings, errors and messages user_handlers <- output_handler$calling_handlers evaluate_handlers <- condition_handlers( watcher, on_error = on_error, on_warning = on_warning, on_message = on_message ) # The user's condition handlers have priority over ours handlers <- c(user_handlers, evaluate_handlers) for (tle in tles) { watcher$push_source(tle$src, tle$exprs) if (debug || log_echo) { cat_line(tle$src, file = stderr()) } continue <- withRestarts( with_handlers( { for (expr in tle$exprs) { ev <- withVisible(eval(expr, envir)) watcher$capture_plot_and_output() watcher$print_value(ev$value, ev$visible, envir) } TRUE }, handlers ), eval_continue = function() TRUE, eval_stop = function() FALSE ) watcher$check_devices() if (!continue) { break } } # Always capture last plot, even if incomplete watcher$capture_plot(TRUE) watcher$get() } check_stop_on_error <- function(x) { if (is.numeric(x) && length(x) == 1 && !is.na(x)) { if (x == 0L) { return("continue") } else if (x == 1L) { return("stop") } else if (x == 2L) { return("error") } } stop("`stop_on_error` must be 0, 1, or 2.", call. = FALSE) } check_keep <- function(x, arg, log = FALSE) { if (!is.logical(x) || length(x) != 1) { stop("`", arg, "` must be TRUE, FALSE, or NA.", call. = FALSE) } list( capture = isTRUE(x), silence = !is.na(x) && !log ) } evaluate/R/replay.R0000644000176200001440000000365314661412557013722 0ustar liggesusers#' Replay a list of evaluated results #' #' Replay a list of evaluated results, as if you'd run them in an R #' terminal. #' #' @param x result from [evaluate()] #' @export #' @examples #' f1 <- function() { #' cat("1\n") #' print("2") #' warning("3") #' print("4") #' message("5") #' stop("6") #' } #' replay(evaluate("f1()")) #' #' f2 <- function() { #' message("Hello") #' plot(1:10) #' message("Goodbye") #' } #' replay(evaluate("f2()")) replay <- function(x) { UseMethod("replay", x) } #' @export replay.list <- function(x) { invisible(lapply(x, replay)) } #' @export replay.default <- function(x) { render(x, TRUE, parent.frame()) } #' @export replay.character <- function(x) { cat(x) } #' @export replay.source <- function(x) { cat(line_prompt(x$src)) } #' @export replay.condition <- function(x) { cat_line(format_condition(x)) } #' @export replay.recordedplot <- function(x) { print(x) } format_condition <- function(x) { if (inherits(x, "message")) { return(gsub("\n$", "", conditionMessage(x))) } if (inherits(x, "error")) { type <- "Error" } else if (inherits(x, "warning")) { type <- "Warning" } call <- conditionCall(x) if (is.null(call)) { header <- paste0(type, ":") } else { header <- paste0(type, " in ", deparse1(call), ":") } body <- conditionMessage(x) paste0(header, "\n", body) } #' Line prompt. #' #' Format a single expression as if it had been entered at the command prompt. #' #' @param x string representing a single expression #' @param prompt prompt for first line #' @param continue prompt for subsequent lines #' @keywords internal #' @return a string line_prompt <- function(x, prompt = getOption("prompt"), continue = getOption("continue")) { lines <- strsplit(x, "\n")[[1]] n <- length(lines) lines[1] <- paste0(prompt, lines[1]) if (n > 1) { lines[2:n] <- paste0(continue, lines[2:n]) } paste0(lines, "\n", collapse = "") } evaluate/R/utils.R0000644000176200001440000000220714661412557013560 0ustar liggesuserscat_line <- function(..., file = stdout()) { cat(paste0(..., "\n", collapse = ""), file = file) } indent <- function(x, by = " ", drop_trailing_nl = TRUE) { if (drop_trailing_nl) { x <- gsub("\n$", "", x) } paste0(by, gsub("\n", paste0("\n", by), x)) } defer <- function(expr, frame = parent.frame(), after = FALSE) { thunk <- as.call(list(function() expr)) do.call(on.exit, list(thunk, TRUE, after), envir = frame) } `%||%` <- function(a, b) if (is.null(a)) b else a env_var_is_true <- function(x) { isTRUE(as.logical(Sys.getenv(x, "false"))) } is_call <- function(x, name) { if (!is.call(x)) { return(FALSE) } is.name(x[[1]]) && as.character(x[[1]]) %in% name } last <- function(x) x[length(x)] seq2 <- function(start, end, by = 1) { if (start > end) { integer() } else { seq(start, end, by = 1) } } can_parse <- function(x) { if (!is.character(x)) { return(TRUE) } tryCatch( { parse(text = x) TRUE }, error = function(e) FALSE ) } deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { paste(deparse(expr, width.cutoff, ...), collapse = collapse) } evaluate/R/evaluation.R0000644000176200001440000000376714661412557014603 0ustar liggesusersnew_evaluation <- function(x) { # Needs explicit list for backwards compatibility 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("") for (component in x) { type <- output_type(component) if (type == "source") { cat_line("Source code: ") cat_line(indent(component$src)) } else if (type == "text") { cat_line("Text output: ") cat_line(indent(component)) } else if (type %in% c("message", "warning", "error")) { cat_line("Condition: ") cat_line(indent(format_condition(component))) } else if (type == "plot") { dl <- component[[1]] cat_line("Plot [", length(dl), "]:") for (call in dl) { fun_call <- call[[2]][[1]] if (hasName(fun_call, "name")) { cat_line(" ", fun_call$name, "()") } else { cat_line(" ", deparse(fun_call)) } } } else { cat_line("Other: ") cat(" ") str(component, indent.str = " ") } } invisible(x) } output_type <- function(x) { if (is.character(x)) { "text" } else if (is.error(x)) { "error" } else if (is.warning(x)) { "warning" } else if (is.message(x)) { "message" } else if (is.recordedplot(x)) { "plot" } else if (is.source(x)) { "source" } else { class(x)[[1]] } } #' Object class tests #' #' @keywords internal #' @rdname is.message #' @export is.message <- function(x) inherits(x, "message") #' @rdname is.message #' @export is.warning <- function(x) inherits(x, "warning") #' @rdname is.message #' @export is.error <- function(x) inherits(x, "error") #' @rdname is.message #' @export is.source <- function(x) inherits(x, "source") #' @rdname is.message #' @export is.recordedplot <- function(x) inherits(x, "recordedplot") evaluate/R/inject-funs.R0000644000176200001440000000321214661412557014642 0ustar liggesusers#' Inject functions into the environment of `evaluate()` #' #' Create functions in the environment specified in the `envir` argument of #' [evaluate()]. This can be helpful if you want to substitute certain #' functions when evaluating the code. To make sure it does not wipe out #' existing functions in the environment, only functions that do not exist in #' the environment are injected. #' @param ... Named arguments of functions. If empty, previously injected #' functions will be emptied. #' @note For expert use only. Do not use it unless you clearly understand it. #' @keywords internal #' @return Invisibly returns previous values. #' @examples library(evaluate) #' # normally you cannot capture the output of system #' evaluate("system('R --version')") #' #' # replace the system() function #' old <- inject_funs(system = function(...) { #' cat(base::system(..., intern = TRUE), sep = "\n") #' }) #' #' evaluate("system('R --version')") #' #' # restore previously injected functions #' inject_funs(old) #' @export inject_funs <- function(...) { funs <- list(...) funs <- funs[names(funs) != ""] old <- the$inject_funs the$inject_funs <- Filter(is.function, funs) invisible(old) } local_inject_funs <- function(envir, frame = parent.frame()) { funs <- the$inject_funs if (length(funs) == 0) { return() } funs_names <- names(funs) funs_new <- !vapply(funs_names, exists, logical(1), envir, inherits = FALSE) funs_names <- funs_names[funs_new] funs <- funs[funs_new] defer(rm(list = funs_names, envir = envir), frame = frame) for (i in seq_along(funs_names)) { assign(funs_names[i], funs[[i]], envir) } invisible() } evaluate/R/watchout.R0000644000176200001440000001040114661412557014251 0ustar liggesuserswatchout <- function(handler = new_output_handler(), new_device = TRUE, debug = FALSE, frame = parent.frame()) { if (new_device) { # Ensure we have a graphics device available for recording, but choose # one that's available on all platforms and doesn't write to disk pdf(file = NULL) dev.control(displaylist = "enable") dev <- dev.cur() defer(dev.off(dev), frame) } # Maintain a list of outputs that we'll grow over time output <- list() i <- 1 push <- function(value) { output[i] <<- list(value) i <<- i + 1 switch(output_type(value), plot = handler$graphics(value), text = handler$text(value), message = handler$message(value), warning = handler$warning(value), error = handler$error(value) ) invisible() } push_source <- function(src, tle) { source <- new_source(src, tle, handler$source) if (!is.null(source)) { push(source) } } # record current devices for plot handling last_plot <- NULL devn <- length(dev.list()) dev <- dev.cur() sink_con <- local_persistent_sink_connection(debug, frame) capture_plot <- function(incomplete = FALSE) { # only record plots for our graphics device if (!identical(dev.cur(), dev)) { return() } # current page is incomplete if (!par("page") && !incomplete) { return() } plot <- recordPlot() if (!makes_visual_change(plot[[1]])) { return() } if (!looks_different(last_plot[[1]], plot[[1]])) { return() } last_plot <<- plot push(plot) invisible() } capture_output <- function() { out <- sink_con() if (!is.null(out)) { push(out) } invisible() } capture_plot_and_output <- function() { capture_plot() capture_output() } print_value <- function(value, visible, envir) { if (!show_value(handler, visible)) { return() } pv <- withVisible(handle_value(handler, value, visible, envir)) capture_plot_and_output() # If the return value is visible, save the value to the output if (pv$visible) { push(pv$value) } } check_devices <- function() { # if dev.off() was called, make sure to restore device to the one opened # when watchout() was called if (length(dev.list()) < devn) { dev.set(dev) } devn <<- length(dev.list()) invisible() } local_console_flusher(capture_output, frame = frame) local_plot_hooks(capture_plot_and_output, frame = frame) list( capture_plot = capture_plot, capture_output = capture_output, capture_plot_and_output = capture_plot_and_output, check_devices = check_devices, push = push, push_source = push_source, print_value = print_value, get = function() new_evaluation(output) ) } # Persistent way to capture output --------------------------------------------- local_persistent_sink_connection <- function(debug = FALSE, frame = parent.frame()) { con <- file("", "w+b") defer(if (isValid(con)) close(con), frame) # try() defaults to using stderr() so we need to explicitly override(#88) old <- options(try.outFile = con) defer(options(old), frame) sink(con, split = debug) sinkn <- sink.number() defer(if (sink.number() >= sinkn) sink(), frame) function() { if (!isValid(con)) { con <<- file("", "w+b") options(try.outFile = con) } if (sink.number() < sinkn) { sink(con) sinkn <<- sink.number() } read_con(con) } } read_con <- function(con, buffer = 32 * 1024) { bytes <- raw() repeat { new <- readBin(con, "raw", n = buffer) if (length(new) == 0) break bytes <- c(bytes, new) } if (length(bytes) == 0) { NULL } else { rawToChar(bytes) } } # isOpen doesn't work for two reasons: # 1. It errors if con has been closed, rather than returning FALSE # 2. If returns TRUE if con has been closed and a new connection opened # # So instead we retrieve the connection from its number and compare to the # original connection. This works because connections have an undocumented # external pointer. isValid <- function(con) { tryCatch( identical(getConnection(con), con), error = function(cnd) FALSE ) } evaluate/R/flush-console.R0000644000176200001440000000217314661412557015203 0ustar liggesusers#' An emulation of `flush.console()` in `evaluate()` #' #' @description #' When [evaluate()] is evaluating code, the text output is diverted into #' an internal connection, and there is no way to flush that connection. This #' function provides a way to "flush" the connection so that any text output can #' be immediately written out, and more importantly, the `text` handler #' (specified in the `output_handler` argument of `evaluate()`) will #' be called, which makes it possible for users to know it when the code #' produces text output using the handler. #' #' This function is supposed to be called inside `evaluate()` (e.g. #' either a direct `evaluate()` call or in \pkg{knitr} code chunks). #' @export flush_console <- function() { if (!is.null(the$console_flusher)) { the$console_flusher() } invisible() } the$console_flusher <- NULL local_console_flusher <- function(flusher, frame = parent.frame()) { old <- set_console_flusher(flusher) defer(set_console_flusher(old), frame) invisible() } set_console_flusher <- function(flusher) { old <- the$console_flusher the$console_flusher <- flusher invisible(old) } evaluate/NAMESPACE0000644000176200001440000000145114661410207013301 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",evaluate_evaluation) S3method(parse_all,"function") S3method(parse_all,call) S3method(parse_all,character) S3method(parse_all,connection) S3method(print,evaluate_evaluation) S3method(replay,character) S3method(replay,condition) S3method(replay,default) S3method(replay,list) S3method(replay,recordedplot) S3method(replay,source) export(create_traceback) export(evaluate) export(flush_console) export(inject_funs) export(is.error) export(is.message) export(is.recordedplot) export(is.source) export(is.warning) export(local_reproducible_output) export(new_output_handler) export(parse_all) export(remove_hooks) export(replay) export(set_hooks) export(trim_intermediate_plots) export(try_capture_stack) import(grDevices) import(graphics) import(utils) evaluate/LICENSE0000644000176200001440000000005614634551613013076 0ustar liggesusersYEAR: 2023 COPYRIGHT HOLDER: evaluate authors evaluate/NEWS.md0000644000176200001440000002715014740317127013171 0ustar liggesusers# evaluate 1.0.3 # evaluate 1.0.2 * Restore correct traceback behaviour (#232). # evaluate 1.0.1 * Fix buglet revealed when using `rlang::abort()` inside of `evaluate()`. # evaluate 1.0.0 * Setting `ACTIONS_STEP_DEBUG=1` (as in a failing GHA workflow) will automatically set `log_echo` and `log_warning` to `TRUE` (#175). * evaluate works on R 3.6.0 once again. * `evaluate()` improvements: * Now terminates on the first error in a multi-expression input, i.e. `1;stop('2');3` will no longer evaluate the third component. This matches console behaviour more closely. * Calls from conditions emitted by top-level code are automatically stripped (#150). * Result has a class (`evaluate_evaluation`/`list`) with a basic print method. * Plots created before messages/warnings/errors are correctly captured (#28). * Handler improvements: * The default `value` handler now evaluates `print()` in a child of the evaluation environment. This largely makes evaluate easier to test, but should make defining S3 methods for print a little easier (#192). * The `source` output handler is now passed the entire complete input expression, not just the first component. * `evalute(include_timing)` has been deprecated. I can't find any use of it on GitHub, and it adds substantial code complexity for little gain. * `is.value()` has been removed since it tests for an object that evaluate never creates. * New `local_reproducible_output()` helper that sets various options and env vars to help ensure consistency of output across environments. * `parse_all()` adds a `\n` to the end of every line, even the last one if it didn't have one in the input. Additionally, it no longer has a default method, which will generate better errors if you pass in something unexpected. * New `trim_intermediate_plots()` drops intermediate plots to reveal the complete/final plot (#206). * `watchout()` is no longer exported; it's really an implementation detail that should never have been leaked to the public interface. # evaluate 0.24.0 * The `source` output handler can now take two arguments (the unparsed `src` and the parsed `call`) and choose to affect the displayed source. * The package now depends on R 4.0.0 in order to decrease our maintenance burden. # Version 0.23 - Prevent existing plots from leaking into `evaluate()` results (thanks, @dmurdoch, yihui/knitr#2297). - If the environment variable `R_EVALUATE_BYPASS_MESSAGES` is set to true, the arguments `keep_message` and `keep_warning` of `evaluate()` will be set to `NA`, regardless of user input, which means messages and warnings will not be captured by `evaluate()`. This provides a possibility to force logging messages and warnings (thanks, @slodge, yihui/yihui.org#1458). # Version 0.22 - Fixed a problem in the internal function `plot_calls()` that made the examples of `recordGraphics` fail to run on its help page (thanks, Kurt Hornik). # Version 0.21 - `evaluate()` gains `log_echo` and `log_warning` arguments. When set to `TRUE` these cause code and warnings (respectively) to be immediately emitted to `stderr()`. This is useful for logging in unattended environments (#118). - Improved the error message when users accidentally called `closeAllConnections()` (thanks, @guslipkin, quarto-dev/quarto-cli#5214). # Version 0.20 - The arguments `keep_message` and `keep_warning` of `evaluate()` can take the value `NA` now, which means `evaluate()` will not capture the messages and they will be sent to the console. This is equivalent to the `FALSE` value before v0.19 (thanks, @gadenbuie, https://github.com/yihui/yihui.org/discussions/1458). # Version 0.19 - In `evaluate()`, `keep_message` and `keep_warning` will completely drop messages and warnings, respectively, when their values are `FALSE`. Previously messages would still be emitted (to the console) even if they take `FALSE` values. - Fixed the bug that `parse_all()` fails with line directives (thanks, @ArcadeAntics, #114). # Version 0.18 - Fixed tests that were still using the deprecated `ggplot2::qplot()`. # Version 0.17 - Adapted a unit test to the next version of **ggplot2** (thanks, @thomasp85, #113). # Version 0.16 - Fixed a bug that an empty **ggplot2** plot could be recorded and incorrectly saved (thanks, @sjspielman, rstudio/rmarkdown#2363). # Version 0.15 - `new_output_handler()` gains a `calling_handlers` argument. These are passed to `withCallingHandlers()` before `evaluate()` captures any conditions. - Fixed #106: do not assume that `is.atomic(NULL)` returns `TRUE` (thanks, @mmaechler). # Version 0.14 - The hooks `persp`, `before.plot.new`, and `before.grid.newpage` set by users will be respected throughout the R session (thanks, @KKPMW, #96). # Version 0.13 - Errors generated by try() are now part of the output (for R >= 3.4). To achieve this, the try.outFile option is set for the duration of all evaluations (thanks, @krlmlr, #91) # Version 0.12 - Removed the stringr dependency (thanks, @mllg, #90). # Version 0.11 - Fix for regression introduced in 0.10.1 in parse_all.call() (fixes #77) - evaluate() now respects options(warn >= 2); all warnings are turned into errors (#81) # Version 0.10.1 - Added parse_all.call() method to use the original source for evaluating call objects (because base::deparse() breaks non-ascii source code) (fixes #74) # Version 0.10 - Added option for the evaluate function to include timing information of ran commands. This information will be subsequently rendered by the replay. Example usage: evaluate::replay(evaluate::evaluate('Sys.sleep(1)', include_timing = TRUE)) - Added a new function `flush_console()` to emulate `flush.console()` in `evaluate()` (#61). - Added a `inject_funs()` function to create functions in the environment passed to the `envir` argument of `evaluate()`. # Version 0.9 - Added an argument `allow_error` to `parse_all()` to allow syntactical errors in R source code when `allow_error = TRUE`; this means `evaluate(stop_on_error = 0 or 1)` will no longer stop on syntactical errors but returns a list of source code and the error object instead. This can be useful to show syntactical errors for pedagogical purposes. # Version 0.8.3 - Added an argument `filename` to evaluate() and parse_all() (thanks, @flying-sheep, #58). # Version 0.8 - Changed package license to MIT. # Version 0.7.2 - replay() fails to replay certain objects such as NULL (#53). # Version 0.7 - R 3.0.2 is the minimal required version for this package now. # Version 0.6 - Plots are no longer recorded when the current graphical device has been changed, which may introduce issues like yihui/knitr#824. - `parse_all()` can parse R code that contains multibyte characters correctly now (#49, yihui/knitr#988) # Version 0.5.5 - Actually use the `text` and `graphics` in `new_output_handler` - Multiple expressions separated by `;` on the same line can be printed as expected when the result returned is visible, e.g. both `x` and `y` will be printed when the source code is `x; y`. In previous versions, only `y` is printed. (thanks, Bill Venables) # Version 0.5.3 ## BUG FIXES - fixed the bug reported at https://github.com/yihui/knitr/issues/722 (repeatedly knitting the same code results in plots being omitted randomly) (thanks, Simon Urbanek) # Version 0.5.1 ## BUG FIXES - under R 2.15.x, evaluate() was unable to filter out the plots triggered by clip() (thanks, Uwe Ligges) # Version 0.5 ## NEW FEATURES - evaluate() is better at telling if a new plot should render a new page due to the new par('page') in R 3.0.2 ## BUG FIXES - fixed yihui/knitr#600: when the last expression in the code is a comment, the previous incomplete plot was not captured - the empty plots produced by strwidth(), strheight(), and clip() are no longer recorded ## MAJOR CHANGES - evaluate() no longer records warnings in case of options(warn = -1); see yihui/knitr#610 - for 'output_handler' in evaluate(), visible values from the 'value' handler will be saved to the output list; this makes it possible for users to save the original values instead of their printed side effects; this change will not affect those who use the default output handlers (#40, thanks, Gabriel Becker) - the 'value' handler in new_output_handler() may take an additional argument that means if the value is visible or not; this makes it possible to save the invisible values as well (#41, thanks, Joroen Ooms) # Version 0.4.7 ## NEW FEATURES - added two arguments keep_warning and keep_message in evaluate() so that it is possible not to capture warnings or messages now ## BUG FIXES - fixed #25: plots can be correctly recorded under a complex layout now (#25, thanks, Jack Tanner and Andy Barbour) - fixed yihui/knitr#582: evaluate() misclassified some plot changes as "par changes" and removed some plots when it should not; now it is better at identifying plot changes dur to par() (thanks, Keith Twombley) # Version 0.4.4 ## BUG FIXES - Perspective plots from `persp()` are captured now (thanks to Harvey Lime and Yihui Xie) - If an error occurs during printing a visible value, evaluate will halt on a cryptic error "operator is invalid for atomic vectors" (#26, fixed by Yihui Xie) - If the internal connection was accidentally closed by the user, a more informative message will show up (#23) - Now the graphical device will always try to record graphics by default (when new_device = TRUE) (#34) - Some empty and incomplete plots caused by par() or layout() will be filtered out correctly for R 3.0 (#35) ## MAINTAINENCE - Yihui Xie is the new maintainer of this package now # Version 0.4.3 ## NEW FEATURES - Added `output_handler` argument to `evaluate`. Should be a `output_handler` object, which is a list of functions for handling each type of result, prior to printing of visible return values. This allows clients to override the console-like printing of values, while still processing them in the correct temporal context. The other handlers are necessary to convey the correct ordering of the output. This essentially provides stream-based processing, as an alternative to the existing deferred processing. - New option, `stop_on_error` which controls behaviour when errors occur. The default value, `0`, acts like you've copied and pasted the code into the console, and continues to execute all code. `1` will stop the code execution and return the results of evaluation up to that point, and `2` will raise an error. ## BUG FIXES - Compound expressions like `x <- 10; x` are now evaluated completely. - Chinese characters on windows now work correctly (thanks to Yihui Xie) - Graphics and output interleaved correctly when generated from a loop or other compound statements - By default, `evaluate` will now open a new graphics device and clean it up afterwards. To suppress that behaviour use `new_device = FALSE` - use `show` to display S4 objects. # Version 0.4.2 - replace deprecated `.Internal(eval.with.vis)` with correct `withVisible` - `evaluate` gains `debug` argument # Version 0.4.1 - use `test_package` to avoid problems with latest version of `testthat` # Version 0.4 - Use plot hooks to capture multiple plots created in a loop or within a function. (Contributed by Yihui Xie) # Version 0.3 - Import `stringr` instead of depending on it. - Test plot recording only in the presence of interactive devices. # Version 0.2 - try_capture_stack and create_traceback do a much better job of removing infrastructure calls from the captured traceback - visible results are automatically evaluated and their outputs are captured. This is particularly important for lattice and ggplot graphics, which otherwise require special handling. It also correctly captures warnings, errors and messages raised by the print method. evaluate/README.md0000644000176200001440000000312214634551613013345 0ustar liggesusers# evaluate [![R-CMD-check](https://github.com/r-lib/evaluate/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/evaluate/actions/workflows/R-CMD-check.yaml) [![CRAN status](https://www.r-pkg.org/badges/version/evaluate)](https://CRAN.R-project.org/package=evaluate) [![Downloads from the RStudio CRAN mirror](https://cranlogs.r-pkg.org/badges/evaluate)](https://cran.r-project.org/package=evaluate) [![Codecov test coverage](https://codecov.io/gh/r-lib/evaluate/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/evaluate?branch=main) evaluate provides tools that allow you to recreate the parsing, evaluation and display of R code, with enough information that you can accurately recreate what happens at the command line. Evaluate + replay works very similarly to `source()`, but is written in such a way to make it easy to adapt for other output formats, such as html or latex. ```R library(evaluate) ``` There are three components to the `evaluate` package: * `parse_all()`, a version of parse that keeps expressions with their original source code, maintaining formatting and comments. * `evaluate()`, which evaluates each expression produced by `parse_all()`, tracking all output, messages, warnings, and errors as their occur, and interleaving them in the correct order with the original source and value of the expression. * `replay()`, which outputs these pieces in a way that makes it look like you've entered the code at the command line. This function also serves as a template for other output formats. evaluate/man/0000755000176200001440000000000014661412557012646 5ustar liggesusersevaluate/man/new_output_handler.Rd0000644000176200001440000000537614645307216017053 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/output-handler.R \name{new_output_handler} \alias{new_output_handler} \alias{output_handler} \title{Custom output handlers} \usage{ new_output_handler( source = identity, text = identity, graphics = identity, message = identity, warning = identity, error = identity, value = render, calling_handlers = list() ) } \arguments{ \item{source}{Function to handle the echoed source code under evaluation. This function should take two arguments (\code{src} and \code{expr}), and return an object that will be inserted into the evaluate outputs. \code{src} is the unparsed text of the source code, and \code{expr} is the complete input expression (which may have 0, 1, 2, or more components; see \code{\link[=parse_all]{parse_all()}} for details). Return \code{src} for the default evaluate behaviour. Return \code{NULL} to drop the source from the output.} \item{text}{Function to handle any textual console output.} \item{graphics}{Function to handle graphics, as returned by \code{\link[=recordPlot]{recordPlot()}}.} \item{message}{Function to handle \code{\link[=message]{message()}} output.} \item{warning}{Function to handle \code{\link[=warning]{warning()}} output.} \item{error}{Function to handle \code{\link[=stop]{stop()}} output.} \item{value}{Function to handle the values returned from evaluation. \itemize{ \item If it has one argument, it called on visible values. \item If it has two arguments, it handles all values, with the second argument indicating whether or not the value is visible. \item If it has three arguments, it will be called on all values, with the the third argument given the evaluation environment which is needed to look up print methods for S3 objects. }} \item{calling_handlers}{List of \link[=withCallingHandlers]{calling handlers}. These handlers have precedence over the exiting handler installed by \code{\link[=evaluate]{evaluate()}} when \code{stop_on_error} is set to 0.} } \value{ A new \code{output_handler} object } \description{ An \code{output_handler} handles the results of \code{\link[=evaluate]{evaluate()}}, including the values, graphics, conditions. Each type of output is handled by a particular function in the handler object. } \details{ The handler functions should accept an output object as their first argument. The return value of the handlers is ignored, except in the case of the \code{value} handler, where a visible return value is saved in the output list. Calling the constructor with no arguments results in the default handler, which mimics the behavior of the console by printing visible values. Note that recursion is common: for example, if \code{value} does any printing, then the \code{text} or \code{graphics} handlers may be called. } evaluate/man/try_capture_stack.Rd0000644000176200001440000000075014634551613016662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/traceback.R \name{try_capture_stack} \alias{try_capture_stack} \title{Try, capturing stack on error} \usage{ try_capture_stack(quoted_code, env) } \arguments{ \item{quoted_code}{code to evaluate, in quoted form} \item{env}{environment in which to execute code} } \description{ This is a variant of \code{\link[=tryCatch]{tryCatch()}} that also captures the call stack if an error occurs. } \keyword{internal} evaluate/man/evaluate-package.Rd0000644000176200001440000000215714634551613016336 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/evaluate-package.R \docType{package} \name{evaluate-package} \alias{evaluate-package} \title{evaluate: Parsing and Evaluation Tools that Provide More Details than the Default} \description{ Parsing and evaluation tools that make it easy to recreate the command line behaviour of R. } \seealso{ Useful links: \itemize{ \item \url{https://evaluate.r-lib.org/} \item \url{https://github.com/r-lib/evaluate} \item Report bugs at \url{https://github.com/r-lib/evaluate/issues} } } \author{ \strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} Authors: \itemize{ \item Yihui Xie (\href{https://orcid.org/0000-0003-0645-5666}{ORCID}) } Other contributors: \itemize{ \item Michael Lawrence [contributor] \item Thomas Kluyver [contributor] \item Jeroen Ooms [contributor] \item Barret Schloerke [contributor] \item Adam Ryczkowski [contributor] \item Hiroaki Yutani [contributor] \item Michel Lang [contributor] \item Karolis Koncevičius [contributor] \item Posit Software, PBC [copyright holder, funder] } } \keyword{internal} evaluate/man/is.message.Rd0000644000176200001440000000056514637613621015177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/evaluation.R \name{is.message} \alias{is.message} \alias{is.warning} \alias{is.error} \alias{is.source} \alias{is.recordedplot} \title{Object class tests} \usage{ is.message(x) is.warning(x) is.error(x) is.source(x) is.recordedplot(x) } \description{ Object class tests } \keyword{internal} evaluate/man/trim_intermediate_plots.Rd0000644000176200001440000000121314661410207020046 0ustar liggesusers% 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) } evaluate/man/evaluate.Rd0000644000176200001440000000671314661412557014752 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/evaluate.R \name{evaluate} \alias{evaluate} \title{Evaluate input and return all details of evaluation} \usage{ evaluate( input, envir = parent.frame(), enclos = NULL, debug = FALSE, stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE, log_echo = FALSE, log_warning = FALSE, new_device = TRUE, output_handler = NULL, filename = NULL, include_timing = FALSE ) } \arguments{ \item{input}{input object to be parsed and evaluated. May be a string, file connection or function. Passed on to \code{\link[=parse_all]{parse_all()}}.} \item{envir}{environment in which to evaluate expressions.} \item{enclos}{when \code{envir} is a list or data frame, this is treated as the parent environment to \code{envir}.} \item{debug}{if \code{TRUE}, displays information useful for debugging, including all output that evaluate captures.} \item{stop_on_error}{A number between 0 and 2 that controls what happens when the code errors: \itemize{ \item If \code{0}, the default, will continue running all code, just as if you'd pasted the code into the command line. \item If \code{1}, evaluation will stop on first error without signaling the error, and you will get back all results up to that point. \item If \code{2}, evaluation will halt on first error and you will get back no results. }} \item{keep_warning, keep_message}{A single logical value that controls what happens to warnings and messages. \itemize{ \item If \code{TRUE}, the default, warnings and messages will be captured in the output. \item If \code{NA}, warnings and messages will not be captured and bubble up to the calling environment of \code{evaluate()}. \item If \code{FALSE}, warnings and messages will be completed supressed and not shown anywhere. } Note that setting the envvar \code{R_EVALUATE_BYPASS_MESSAGES} to \code{true} will force these arguments to be set to \code{NA}.} \item{log_echo, log_warning}{If \code{TRUE}, will immediately log code and warnings (respectively) to \code{stderr}. This will be force to \code{TRUE} if env var \code{ACTIONS_STEP_DEBUG} is \code{true}, as when debugging a failing GitHub Actions workflow.} \item{new_device}{if \code{TRUE}, will open a new graphics device and automatically close it after completion. This prevents evaluation from interfering with your existing graphics environment.} \item{output_handler}{an instance of \code{\link[=output_handler]{output_handler()}} that processes the output from the evaluation. The default simply prints the visible return values.} \item{filename}{string overrriding the \code{\link[base:srcfile]{base::srcfile()}} filename.} \item{include_timing}{Deprecated.} } \description{ Compare to \code{\link[=eval]{eval()}}, \code{evaluate} captures all of the information necessary to recreate the output as if you had copied and pasted the code into a R terminal. It captures messages, warnings, errors and output, all correctly interleaved in the order in which they occured. It stores the final result, whether or not it should be visible, and the contents of the current graphics device. } \examples{ evaluate(c( "1 + 1", "2 + 2" )) # Not that's there's a difference in output between putting multiple # expressions on one line vs spreading them across multiple lines evaluate("1;2;3") evaluate(c("1", "2", "3")) # This also affects how errors propagate, matching the behaviour # of the R console evaluate("1;stop(2);3") evaluate(c("1", "stop(2)", "3")) } evaluate/man/flush_console.Rd0000644000176200001440000000160014634551613015772 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/flush-console.R \name{flush_console} \alias{flush_console} \title{An emulation of \code{flush.console()} in \code{evaluate()}} \usage{ flush_console() } \description{ When \code{\link[=evaluate]{evaluate()}} is evaluating code, the text output is diverted into an internal connection, and there is no way to flush that connection. This function provides a way to "flush" the connection so that any text output can be immediately written out, and more importantly, the \code{text} handler (specified in the \code{output_handler} argument of \code{evaluate()}) will be called, which makes it possible for users to know it when the code produces text output using the handler. This function is supposed to be called inside \code{evaluate()} (e.g. either a direct \code{evaluate()} call or in \pkg{knitr} code chunks). } evaluate/man/replay.Rd0000644000176200001440000000110614634551613014424 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/replay.R \name{replay} \alias{replay} \title{Replay a list of evaluated results} \usage{ replay(x) } \arguments{ \item{x}{result from \code{\link[=evaluate]{evaluate()}}} } \description{ Replay a list of evaluated results, as if you'd run them in an R terminal. } \examples{ f1 <- function() { cat("1\n") print("2") warning("3") print("4") message("5") stop("6") } replay(evaluate("f1()")) f2 <- function() { message("Hello") plot(1:10) message("Goodbye") } replay(evaluate("f2()")) } evaluate/man/set_hooks.Rd0000644000176200001440000000146014634551613015131 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hooks.R \name{set_hooks} \alias{set_hooks} \alias{remove_hooks} \title{Set and remove hooks} \usage{ set_hooks(hooks, action = "append") remove_hooks(hooks) } \arguments{ \item{hooks}{a named list of hooks - each hook can either be a function or a list of functions.} \item{action}{\code{"replace"}, \code{"append"} or \code{"prepend"}} } \description{ This interface wraps the base \code{\link[=setHook]{setHook()}} function to provide a return value that makes it easy to undo. } \examples{ new1 <- list(before.plot.new = function() print("Plotted!")) new2 <- list(before.plot.new = function() print("Plotted Again!")) set_hooks(new1) set_hooks(new2) plot(1) remove_hooks(new1) plot(1) remove_hooks(new2) plot(1) } \keyword{internal} evaluate/man/create_traceback.Rd0000644000176200001440000000065014634551613016375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/traceback.R \name{create_traceback} \alias{create_traceback} \title{Generate a traceback from a list of calls} \usage{ create_traceback(callstack) } \arguments{ \item{callstack}{stack of calls, as generated by (e.g.) \code{\link[base:sys.parent]{base::sys.calls()}}} } \description{ Generate a traceback from a list of calls } \keyword{internal} evaluate/man/line_prompt.Rd0000644000176200001440000000100214634551613015453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/replay.R \name{line_prompt} \alias{line_prompt} \title{Line prompt.} \usage{ line_prompt(x, prompt = getOption("prompt"), continue = getOption("continue")) } \arguments{ \item{x}{string representing a single expression} \item{prompt}{prompt for first line} \item{continue}{prompt for subsequent lines} } \value{ a string } \description{ Format a single expression as if it had been entered at the command prompt. } \keyword{internal} evaluate/man/inject_funs.Rd0000644000176200001440000000223514661412557015446 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/inject-funs.R \name{inject_funs} \alias{inject_funs} \title{Inject functions into the environment of \code{evaluate()}} \usage{ inject_funs(...) } \arguments{ \item{...}{Named arguments of functions. If empty, previously injected functions will be emptied.} } \value{ Invisibly returns previous values. } \description{ Create functions in the environment specified in the \code{envir} argument of \code{\link[=evaluate]{evaluate()}}. This can be helpful if you want to substitute certain functions when evaluating the code. To make sure it does not wipe out existing functions in the environment, only functions that do not exist in the environment are injected. } \note{ For expert use only. Do not use it unless you clearly understand it. } \examples{ library(evaluate) # normally you cannot capture the output of system evaluate("system('R --version')") # replace the system() function old <- inject_funs(system = function(...) { cat(base::system(..., intern = TRUE), sep = "\n") }) evaluate("system('R --version')") # restore previously injected functions inject_funs(old) } \keyword{internal} evaluate/man/parse_all.Rd0000644000176200001440000000442614661412557015105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parse_all.R \name{parse_all} \alias{parse_all} \title{Parse, retaining comments} \usage{ parse_all(x, filename = NULL, allow_error = FALSE) } \arguments{ \item{x}{object to parse. Can be a string, a file connection, or a function. If a connection, will be opened and closed only if it was closed initially.} \item{filename}{string overriding the file name} \item{allow_error}{whether to allow syntax errors in \code{x}} } \value{ A data frame two columns, \code{src} and \code{expr}, and one row for each complete input in \code{x}. A complete input is R code that would trigger execution when typed at the console. This might consist of multiple expressions separated by \verb{;} or one expression spread over multiple lines (like a function definition). \code{src} is a character vector of source code. Each element represents a complete input expression (which might span multiple line) and always has a terminal \verb{\\n}. \code{expr} is a list-column of \link{expression}s. The expressions can be of any length, depending on the structure of the complete input source: \itemize{ \item If \code{src} consists of only only whitespace and/or comments, \code{expr} will be length 0. \item If \code{src} a single scalar (like \code{TRUE}, \code{1}, or \code{"x"}), name, or function call, \code{expr} will be length 1. \item If \code{src} contains multiple expressions separated by \verb{;}, \code{expr} will have length two or more. } The expressions have their srcrefs removed. If there are syntax errors in \code{x} and \code{allow_error = TRUE}, the data frame will have an attribute \code{PARSE_ERROR} that stores the error object. } \description{ Works very similarly to parse, but also keeps original formatting and comments. } \examples{ # Each of these inputs are single line, but generate different numbers of # expressions source <- c( "# a comment", "x", "x;y", "x;y;z" ) parsed <- parse_all(source) lengths(parsed$expr) str(parsed$expr) # Each of these inputs are a single expression, but span different numbers # of lines source <- c( "function() {}", "function() {", " # Hello!", "}", "function() {", " # Hello!", " # Goodbye!", "}" ) parsed <- parse_all(source) lengths(parsed$expr) parsed$src } evaluate/man/local_reproducible_output.Rd0000644000176200001440000000233214640776677020423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reproducible-output.R \name{local_reproducible_output} \alias{local_reproducible_output} \title{Control common output options} \usage{ local_reproducible_output( width = 80, color = FALSE, unicode = FALSE, hyperlinks = FALSE, rstudio = FALSE, frame = parent.frame() ) } \arguments{ \item{width}{Value of the \code{"width"} option.} \item{color}{Determines whether or not cli/crayon colour should be used.} \item{unicode}{Should we use unicode characaters where possible?} \item{hyperlinks}{Should we use ANSI hyperlinks?} \item{rstudio}{Should we pretend that we're running inside of RStudio?} \item{frame}{Scope of the changes; when this calling frame terminates the changes will be undone. For expert use only.} } \description{ Often when using \code{evaluate()} you are running R code with a specific output context in mind. But there are many options and env vars that packages will take from the current environment, meaning that output depends on the current state in undesirable ways. This function allows you to describe the characteristics of the desired output and takes care of setting the options and environment variables for you. } evaluate/DESCRIPTION0000644000176200001440000000335414740323162013575 0ustar liggesusersType: Package Package: evaluate Title: Parsing and Evaluation Tools that Provide More Details than the Default Version: 1.0.3 Authors@R: c( person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), person("Yihui", "Xie", role = "aut", comment = c(ORCID = "0000-0003-0645-5666")), person("Michael", "Lawrence", role = "ctb"), person("Thomas", "Kluyver", role = "ctb"), person("Jeroen", "Ooms", role = "ctb"), person("Barret", "Schloerke", role = "ctb"), person("Adam", "Ryczkowski", role = "ctb"), person("Hiroaki", "Yutani", role = "ctb"), person("Michel", "Lang", role = "ctb"), person("Karolis", "Koncevičius", role = "ctb"), person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: Parsing and evaluation tools that make it easy to recreate the command line behaviour of R. License: MIT + file LICENSE URL: https://evaluate.r-lib.org/, https://github.com/r-lib/evaluate BugReports: https://github.com/r-lib/evaluate/issues Depends: R (>= 3.6.0) Suggests: callr, covr, ggplot2 (>= 3.3.6), lattice, methods, pkgload, rlang, knitr, testthat (>= 3.0.0), withr Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2025-01-10 22:27:28 UTC; hadleywickham Author: Hadley Wickham [aut, cre], Yihui Xie [aut] (), Michael Lawrence [ctb], Thomas Kluyver [ctb], Jeroen Ooms [ctb], Barret Schloerke [ctb], Adam Ryczkowski [ctb], Hiroaki Yutani [ctb], Michel Lang [ctb], Karolis Koncevičius [ctb], Posit Software, PBC [cph, fnd] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2025-01-10 23:00:02 UTC