evaluate/0000755000176200001440000000000013473254252012067 5ustar liggesusersevaluate/tests/0000755000176200001440000000000013357673704013241 5ustar liggesusersevaluate/tests/test-parse.R0000644000176200001440000000013112667470562015446 0ustar liggesuserslibrary(evaluate) # this should not signal an error evaluate('x <-', stop_on_error = 0) evaluate/tests/testthat/0000755000176200001440000000000013430172574015070 5ustar liggesusersevaluate/tests/testthat/test-graphics.r0000644000176200001440000001010712576632141020030 0ustar liggesuserscontext("Evaluation: graphics") test_that("single plot is captured", { ev <- evaluate(file("plot.r")) expect_that(length(ev), equals(2)) expect_that(classes(ev), equals(c("source", "recordedplot"))) }) test_that("ggplot is captured", { if (require("ggplot2", quietly = TRUE)) { ev <- evaluate(file("ggplot.r")) expect_that(length(ev), equals(3)) expect_that(classes(ev), equals(c("source", "source", "recordedplot"))) } }) test_that("plot additions are captured", { ev <- evaluate(file("plot-additions.r")) expect_that(length(ev), equals(4)) expect_that(classes(ev), equals(c("source", "recordedplot", "source", "recordedplot"))) }) test_that("blank plots by plot.new() are preserved", { ev <- evaluate(file("plot-new.r")) expect_that(length(ev), equals(10)) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), 5))) }) test_that("base plots in a single expression are captured", { ev <- evaluate(file("plot-loop.r")) expect_that(length(ev), equals(4)) expect_that(classes(ev), equals(c("source", rep("recordedplot", 3)))) }) test_that("ggplot2 plots in a single expression are captured", { if (require("ggplot2", quietly = TRUE)) { ev <- evaluate(file("ggplot-loop.r")) expect_that(length(ev), equals(4)) expect_that(classes(ev), equals(c(rep("source", 2), rep("recordedplot", 2)))) } }) test_that("multirow graphics are captured only when complete", { ev <- evaluate(file("plot-multi.r")) expect_that(classes(ev), equals(c(rep("source", 5), "recordedplot"))) }) test_that("multirow graphics are captured on close", { ev <- evaluate(file("plot-multi-missing.r")) expect_that(classes(ev), equals(c(rep("source", 4), "recordedplot"))) }) test_that("plots are captured in a non-rectangular layout", { ev <- evaluate(file("plot-multi-layout.r")) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), c(1, 3)))) ev <- evaluate(file("plot-multi-layout2.r")) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), c(4, 2)))) }) test_that("changes in parameters don't generate new plots", { ev <- evaluate(file("plot-par.r")) expect_that(classes(ev), equals(c("source", "recordedplot", "source", "source", "recordedplot"))) }) test_that("plots in a loop are captured even the changes seem to be from par only", { ev <- evaluate(file("plot-par2.r")) expect_that(classes(ev), equals(c("source", "recordedplot")[c(1, 2, 1, 1, 2, 2, 2)])) }) test_that("strwidth()/strheight() should not produce new plots", { ev <- evaluate(file("plot-strwidth.r")) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), c(4, 1)))) }) test_that("clip() does not produce new plots", { ev <- evaluate(file("plot-clip.r")) expect_that(classes(ev), equals(c("source", "recordedplot")[c(1, 2, 1, 1, 2)])) }) test_that("perspective plots are captured", { ev <- evaluate(file("plot-persp.r")) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), c(6, 3)))) }) test_that("an incomplete plot with a comment in the end is also captured", { ev <- evaluate(file("plot-last-comment.r")) expect_that(classes(ev), equals(rep(c("source", "recordedplot"), c(3, 1)))) }) # a bug report yihui/knitr#722 test_that("repeatedly drawing the same plot does not omit plots randomly", { expect_true(all(replicate(100, length(evaluate("plot(1:10)"))) == 2)) }) # test_that("no plot windows open", { # graphics.off() # expect_that(length(dev.list()), equals(0)) # evaluate(file("plot.r")) # expect_that(length(dev.list()), equals(0)) # }) test_that("by default, evaluate() always records plots regardless of the device", { op <- options(device = pdf) on.exit(options(op)) ev <- evaluate("plot(1)") expect_that(length(ev), equals(2)) }) test_that("Rplots.pdf files are not created", { op <- options(device = pdf) on.exit(options(op)) evaluate(file("plot.r")) expect_false(file.exists("Rplots.pdf")) }) evaluate/tests/testthat/plot-multi-layout.r0000644000176200001440000000022512576632141020674 0ustar liggesusersfor (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)) } evaluate/tests/testthat/interleave-2.r0000644000176200001440000000004612576632141017551 0ustar liggesusersfor (i in 1:2) { plot(i) cat(i) } evaluate/tests/testthat/test-evaluate.r0000644000176200001440000000644713323440757020053 0ustar liggesuserscontext("Evaluation") test_that("file with only comments runs", { ev <- evaluate(file("comment.r")) expect_that(length(ev), equals(2)) expect_that(classes(ev), equals(c("source", "source"))) }) test_that("data sets loaded", { ev <- evaluate(file("data.r")) if (require("lattice", quietly = TRUE)) expect_that(length(ev), equals(3)) }) # # Don't know how to implement this # test_that("newlines escaped correctly", { # ev <- evaluate("cat('foo\n')") # expect_that(ev[[1]]$src, equals("cat('foo\\n'))")) # }) test_that("terminal newline not needed", { ev <- evaluate("cat('foo')") expect_that(length(ev), equals(2)) expect_that(ev[[2]], equals("foo")) }) test_that("S4 methods are displayed with show, not print", { setClass("A", contains = "function", where = environment()) setMethod("show", "A", function(object) cat("B")) a <- new('A', function() b) ev <- evaluate("a") expect_equal(ev[[2]], "B") }) test_that("errors during printing visible values are captured", { setClass("A", contains = "function", where = environment()) setMethod("show", "A", function(object) stop("B")) a <- new('A', function() b) ev <- evaluate("a") stopifnot("error" %in% class(ev[[2]])) }) test_that("options(warn = -1) suppresses warnings", { ev <- evaluate("op = options(warn = -1); warning('hi'); options(op)") expect_that(classes(ev), equals("source")) }) test_that("options(warn = 0) and options(warn = 1) produces warnings", { ev <- evaluate("op = options(warn = 0); warning('hi'); options(op)") expect_equal(classes(ev), c("source", "simpleWarning")) ev <- evaluate("op = options(warn = 1); warning('hi'); options(op)") expect_equal(classes(ev), c("source", "simpleWarning")) }) # See https://github.com/r-lib/evaluate/pull/81#issuecomment-367685196 # test_that("options(warn = 2) produces errors instead of warnings", { # ev_warn_2 <- evaluate("op = options(warn = 2); warning('hi'); options(op)") # expect_equal(classes(ev_warn_2), c("source", "simpleError")) # }) test_that("output and plots interleaved correctly", { ev <- evaluate(file("interleave-1.r")) expect_equal(classes(ev), c("source", "character", "recordedplot", "character", "recordedplot")) ev <- evaluate(file("interleave-2.r")) expect_equal(classes(ev), c("source", "recordedplot", "character", "recordedplot", "character")) }) test_that("return value of value handler inserted directly in output list", { ev <- evaluate(file("raw-output.r"), output_handler = new_output_handler(value = identity)) if (require("ggplot2", quietly = TRUE)) { expect_equal(classes(ev), c("source", "numeric", "source", "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 }) ev <- evaluate("x<-1:10", output_handler = handler) expect_equal(classes(ev), c("source", "integer")) }) test_that("multiple expressions on one line can get printed as expected", { ev <- evaluate("x <- 1; y <- 2; x; y") expect_equal(classes(ev), c("source", "character", "character")) }) test_that("multiple lines of comments do not lose the terminating \\n", { ev <- evaluate("# foo\n#bar") expect_equal(ev[[1]][["src"]], "# foo\n") }) evaluate/tests/testthat/test-errors.r0000644000176200001440000000216413430172574017547 0ustar liggesuserscontext("Errors") test_that("all code run, even after error", { ev <- evaluate(file("error.r")) expect_that(length(ev), equals(4)) }) test_that("code aborts on error if stop_on_error == 1L", { ev <- evaluate(file("error.r"), stop_on_error = 1L) expect_that(length(ev), equals(2)) }) test_that("code errors if stop_on_error == 2L", { expect_error(evaluate(file("error.r"), stop_on_error = 2L), "1") }) test_that("traceback useful if stop_on_error == 2L", { expect_error(evaluate(file("error-complex.r"), stop_on_error = 2L), "Error") ## Doesn't work because .Traceback not create when code run ## inside try or tryCatch. Can't figure out how to work around. ## tryCatch(..., error = function(e) {}) doesn't have enough info ## in e, or in the call stack. options(error = function() {}) doesn't ## stop error propagation # expect_match(.Traceback[[2]], "h()") # expect_match(.Traceback[[3]], "g()") # expect_match(.Traceback[[4]], "f()") }) test_that("capture messages in try() (#88)", { skip_if(getRversion() < "3.4") ev <- evaluate(file("try.r")) expect_match(ev[[length(ev)]], "Obscure error") }) evaluate/tests/testthat/plot-new.r0000644000176200001440000000006712235534635017025 0ustar liggesusersplot.new() plot(1:10) plot.new() plot(1:10) plot.new() evaluate/tests/testthat/plot.r0000644000176200001440000000001312235534635016225 0ustar liggesusersplot(1:10) evaluate/tests/testthat/interleave-1.r0000644000176200001440000000004612576632141017550 0ustar liggesusersfor (i in 1:2) { cat(i) plot(i) } evaluate/tests/testthat/error-complex.r0000644000176200001440000000011312235534636020047 0ustar liggesusersf <- function() g() g <- function() h() h <- function() stop("Error") f() evaluate/tests/testthat/plot-additions.r0000644000176200001440000000002712235534636020207 0ustar liggesusersplot(1:10) lines(1:10) evaluate/tests/testthat/plot-clip.r0000644000176200001440000000013412235534636017157 0ustar liggesusersplot(rnorm(100), rnorm(100)) clip(-1, 1, -1, 1) points(rnorm(100), rnorm(100), col = 'red') evaluate/tests/testthat/plot-par2.r0000644000176200001440000000032612576632141017075 0ustar liggesusersbarplot(table(mtcars$mpg), main = "All") # should capture all plots in this loop for (numcyl in levels(as.factor(mtcars$cyl))) { barplot(table(mtcars$mpg[mtcars$cyl == numcyl]), main = paste("cyl = ", numcyl)) } evaluate/tests/testthat/comment.r0000644000176200001440000000011712235534636016717 0ustar liggesusers# This test case contains no executable code # but it shouldn't throw an error evaluate/tests/testthat/plot-last-comment.r0000644000176200001440000000007712576632141020637 0ustar liggesuserspar(mfrow = c(3, 3)) for (i in 1:7) image(volcano) # comment evaluate/tests/testthat/plot-multi-layout2.r0000644000176200001440000000031412576632141020755 0ustar liggesuserslayout(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)) } evaluate/tests/testthat/error.r0000644000176200001440000000001412235534635016401 0ustar liggesusersstop("1") 2 evaluate/tests/testthat/raw-output.r0000644000176200001440000000016212235534635017403 0ustar liggesusersrnorm(10) x <- list("I'm a list!") suppressPackageStartupMessages(library(ggplot2)) qplot(mpg, wt, data = mtcars) evaluate/tests/testthat/order.r0000644000176200001440000000026212235534635016370 0ustar liggesuserscat("1\n") print("2") warning("3") print("4") message("5") stop("6") stop("7", call. = FALSE) f <- function(x) { print("8") message("9") warning("10") stop("11") } f() evaluate/tests/testthat/plot-multi.r0000644000176200001440000000006512235534635017364 0ustar liggesuserspar(mfrow = c(2, 2)) plot(1) plot(2) plot(3) plot(4) evaluate/tests/testthat/plot-loop.r0000644000176200001440000000004712512557531017201 0ustar liggesusersfor (i in 1:3) { plot(rnorm(100)) } evaluate/tests/testthat/parse.r0000644000176200001440000000012612576632141016365 0ustar liggesusersf <- function() { for (i in 1:3) { plot(rnorm(100)) lines(rnorm(100)) } } evaluate/tests/testthat/plot-par.r0000644000176200001440000000004512235534634017011 0ustar liggesusersplot(1) par(mar = rep(0, 4)) plot(2) evaluate/tests/testthat/test-output.r0000644000176200001440000000024512235534635017573 0ustar liggesuserscontext("Output") test_that("open plot windows maintained", { n <- length(dev.list()) evaluate(file("plot.r")) expect_that(length(dev.list()), equals(n)) }) evaluate/tests/testthat/test-output-handler.R0000644000176200001440000000074112316662535021150 0ustar liggesuserscontext("Output handlers") 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) }) evaluate/tests/testthat/ggplot-loop.r0000644000176200001440000000022112235534635017513 0ustar liggesuserssuppressPackageStartupMessages(library(ggplot2)) for (j in 1:2) { # ggplot2 has been loaded previously print(qplot(rnorm(30), runif(30))) } evaluate/tests/testthat/plot-strwidth.r0000644000176200001440000000014012576632141020073 0ustar liggesusersx <- strwidth('foo', 'inches') y <- strheight('foo', 'inches') par(mar = c(4, 4, 1, 1)) plot(1) evaluate/tests/testthat/data.r0000644000176200001440000000005112235534635016162 0ustar liggesusersdata(barley, package = "lattice") barley evaluate/tests/testthat/plot-persp.r0000644000176200001440000000031512576632141017360 0ustar liggesusersx <- seq(-10, 10, length = 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 for (i in 1:3) { persp(x, y, z, phi = 30 + i * 10, theta = 30) } evaluate/tests/testthat/plot-multi-missing.r0000644000176200001440000000005512235534636021033 0ustar liggesuserspar(mfrow = c(2, 2)) plot(1) plot(2) plot(3) evaluate/tests/testthat/ggplot.r0000644000176200001440000000011712235534635016550 0ustar liggesuserssuppressPackageStartupMessages(library(ggplot2)) qplot(mpg, wt, data = mtcars) evaluate/tests/testthat/example-1.r0000644000176200001440000000042012235534635017042 0ustar liggesusers# These test cases check that interweave # works for a variety of situations a <- 1 # Comment after an expression b <- 2 { a b } # Here is a comment which should be followed # by two new lines { print(a) # comment in a block print(b) } a; b a; b # Comment evaluate/tests/testthat/test-parse.r0000644000176200001440000000155612667470507017361 0ustar liggesuserscontext("Parsing") test_that("{ not removed", { f <- function() { for (i in 1:3) { plot(rnorm(100)) lines(rnorm(100)) } } expect_that(nrow(parse_all(f)), equals(1)) }) 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')) }) # test some multibyte characters when the locale is UTF8 based if (identical(Sys.getlocale("LC_CTYPE"), "en_US.UTF-8")) { test_that("double quotes in Chinese characters not destroyed", { expect_identical(parse_all(c('1+1', '"你好"'))[2, 1], '"你好"') }) test_that("multibyte characters are parsed correct", { code <- c("ϱ <- 1# g / ml", "äöüßÄÖÜπ <- 7 + 3# nonsense") expect_identical(parse_all(code)$src, append_break(code)) }) } evaluate/tests/testthat/try.r0000644000176200001440000000012213430172574016064 0ustar liggesusersg <- function() f("error") f <- function(x) stop(paste0("Obscure ", x)) try(g()) evaluate/tests/test-replay.R0000644000176200001440000000027612576632141015632 0ustar liggesuserslibrary(evaluate) # replay() should work when print() returns visible NULLs print.FOO_BAR <- function(x, ...) NULL ret <- evaluate('structure(1, class = "FOO_BAR")') print(ret) replay(ret) evaluate/tests/test-all.R0000644000176200001440000000012312576632141015075 0ustar liggesuserslibrary(evaluate) if (require("testthat", quietly = TRUE)) test_check("evaluate") evaluate/NAMESPACE0000644000176200001440000000142313473251771013311 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(parse_all,"function") S3method(parse_all,call) S3method(parse_all,character) S3method(parse_all,connection) S3method(parse_all,default) S3method(replay,character) S3method(replay,default) S3method(replay,error) S3method(replay,list) S3method(replay,message) S3method(replay,recordedplot) S3method(replay,source) S3method(replay,value) S3method(replay,warning) 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.value) export(is.warning) export(new_output_handler) export(parse_all) export(remove_hooks) export(replay) export(set_hooks) export(try_capture_stack) import(grDevices) import(graphics) import(utils) evaluate/NEWS.md0000644000176200001440000002167113444257562013201 0ustar liggesusersVersion 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/R/0000755000176200001440000000000013444255624012272 5ustar liggesusersevaluate/R/graphics.r0000644000176200001440000000357113017341055014251 0ustar liggesusers#" Capture snapshot of current device. #" #" There's currently no way to capture when a graphics device changes, #" except to check its contents after the evaluation of every expression. #" This means that only the last plot of a series will be captured. #" #" @return \code{NULL} if plot is blank or unchanged, otherwise the output of #" \code{\link[grDevices]{recordPlot}}. plot_snapshot <- local({ last_plot <- NULL function(incomplete = FALSE) { if (is.null(dev.list())) return(NULL) if (!incomplete && !par('page')) return(NULL) # current page not complete plot <- recordPlot() if (identical(last_plot, plot) || is_par_change(last_plot, plot)) { return(NULL) } if (is.empty(plot)) return(NULL) last_plot <<- plot plot } }) is_par_change <- function(p1, p2) { calls1 <- plot_calls(p1) calls2 <- plot_calls(p2) n1 <- length(calls1) n2 <- length(calls2) if (n2 <= n1) return(FALSE) i1 <- seq_len(n1) if (!identical(calls1, calls2[i1])) return(FALSE) # also check if the content of the display list is still the same (note we # need p1[[1]][] as well because [] turns a dotted pair list into a list) if (!identical(p1[[1]][i1], p2[[1]][i1])) return(FALSE) last <- calls2[(n1 + 1):n2] all(last %in% empty_calls) } # if all calls are in these elements, the plot is basically empty empty_calls <- c("layout", "par", "clip") empty_calls <- c( "palette", "palette2", sprintf("C_%s", c(empty_calls, "strWidth", "strHeight", "plot_window")) ) is.empty <- function(x) { if (is.null(x)) return(TRUE) pc <- plot_calls(x) if (length(pc) == 0) return(TRUE) all(pc %in% empty_calls) } plot_calls <- function(plot) { el <- lapply(plot[[1]], "[[", 2) if (length(el) == 0) return() sapply(el, function(x) { x <- x[[1]] # grid graphics do not have x$name if (is.null(x[["name"]])) deparse(x) else x[["name"]] }) } evaluate/R/traceback.r0000644000176200001440000000253713430172574014400 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/replay.r0000644000176200001440000000537313430172574013756 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 #' samples <- system.file("tests", "testthat", package = "evaluate") #' if (file_test("-d", samples)) { #' replay(evaluate(file(file.path(samples, "order.r")))) #' replay(evaluate(file(file.path(samples, "plot.r")))) #' replay(evaluate(file(file.path(samples, "data.r")))) #' } replay <- function(x) UseMethod("replay", x) #' @export replay.list <- function(x) { invisible(lapply(x, replay)) } #' @export replay.default <- function(x) { render(x) } #' @export replay.character <- function(x) { cat(x) } #' @export replay.source <- function(x) { s <- if (is.null(attr(x$src,'timing'))) '' else render_timing(attr(x$src, 'timing')) cat(paste0(s, line_prompt(x$src))) } #' @export replay.warning <- function(x) { message("Warning message:\n", x$message) } #' @export replay.message <- function(x) { message(sub("\n$", "", x$message)) } #' @export replay.error <- function(x) { if (is.null(x$call)) { message("Error: ", x$message) } else { call <- deparse(x$call) message("Error in ", call, ": ", x$message) } } #' @export replay.value <- function(x) { if (x$visible) print(x$value) } #' @export replay.recordedplot <- function(x) { print(x) } render_timing <- function(t) { if (max(t) < 0.5) '' else paste0( '[', render_sec(t[[1]] + t[[2]]), # User time + Kernel time ',', render_sec(t[[3]]), # Wall time ']' ) } render_sec <- function(s) { if (s < 0.005) return('<5ms') if (s < 1) return(paste0(round(s,2), 's')) if (s < 10) return(paste0(round(s,1), 's')) sec <- round(s,0) if (sec < 120) return(paste0(sec, 's')) min <- floor(sec/60) sec <- sec - min*60 if (min < 10) return(paste0( min, 'm', formatC(sec, digits = 0, width = 2, format = "f", flag = "0"), 's' )) min <- min + round(sec/60, 0) if (min < 120) return(paste0(min, 'm')) h <- floor(min/60) min <- min - h * 60 if (h < 48) return(paste0( h, 'h', formatC(min, digits = 0, width = 2, format = "f", flag = "0"), 'm' )) d <- floor(h/24) h <- h - d*24 return(paste0(d, 'd', h, 'h')) } #' 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/eval.r0000644000176200001440000002175213444255624013413 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 if `2`, evaluation will halt on first error and you #' will get no results back. If `1`, evaluation will stop on first error #' without signaling the error, and you will get back all results up to that #' point. If `0` will continue running all code, just as if you'd pasted #' the code into the command line. #' @param keep_warning,keep_message whether to record warnings and messages. #' @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 if `TRUE`, evaluate will wrap each input #' expression in `system.time()`, which will be accessed by following #' `replay()` call to produce timing information for each evaluated #' command. #' @import graphics grDevices utils evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE, stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE, new_device = TRUE, output_handler = default_output_handler, filename = NULL, include_timing = FALSE) { stop_on_error <- as.integer(stop_on_error) stopifnot(length(stop_on_error) == 1) parsed <- parse_all(input, filename, stop_on_error != 2L) if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) { source <- new_source(parsed$src) output_handler$source(source) output_handler$error(err) err$call <- NULL # the call is unlikely to be useful return(list(source, err)) } if (is.null(enclos)) { enclos <- if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv() } if (new_device) { # Start new graphics device and clean up afterwards if (identical(grDevices::pdf, getOption("device"))) { dev.new(file = NULL) } else dev.new() dev.control(displaylist = "enable") dev <- dev.cur() on.exit(dev.off(dev)) } # clean up the last_plot object after an evaluate() call (cf yihui/knitr#722) on.exit(assign("last_plot", NULL, envir = environment(plot_snapshot)), add = TRUE) out <- vector("list", nrow(parsed)) for (i in seq_along(out)) { expr <- parsed$expr[[i]] if (!is.null(expr)) expr <- as.expression(expr) out[[i]] <- evaluate_call( expr, parsed$src[[i]], envir = envir, enclos = enclos, debug = debug, last = i == length(out), use_try = stop_on_error != 2L, keep_warning = keep_warning, keep_message = keep_message, output_handler = output_handler, include_timing = include_timing) if (stop_on_error > 0L) { errs <- vapply(out[[i]], is.error, logical(1)) if (!any(errs)) next if (stop_on_error == 1L) break } } unlist(out, recursive = FALSE, use.names = FALSE) } evaluate_call <- function(call, src = NULL, envir = parent.frame(), enclos = NULL, debug = FALSE, last = FALSE, use_try = FALSE, keep_warning = TRUE, keep_message = TRUE, output_handler = new_output_handler(), include_timing = FALSE) { if (debug) message(src) if (is.null(call) && !last) { source <- new_source(src) output_handler$source(source) return(list(source)) } stopifnot(is.call(call) || is.language(call) || is.atomic(call)) # Capture output w <- watchout(debug) on.exit(w$close()) # Capture error output from try() (#88) old_try_outfile <- options(try.outFile = w$get_con()) on.exit(options(old_try_outfile), add = TRUE) source <- new_source(src) output_handler$source(source) output <- list(source) dev <- dev.cur() handle_output <- function(plot = FALSE, incomplete_plots = FALSE) { # if dev.cur() has changed, we should not record plots any more plot <- plot && identical(dev, dev.cur()) out <- w$get_new(plot, incomplete_plots, output_handler$text, output_handler$graphics) output <<- c(output, out) } flush_old <- .env$flush_console; on.exit({ .env$flush_console <- flush_old }, add = TRUE) .env$flush_console <- function() handle_output(FALSE) # Hooks to capture plot creation capture_plot <- function() { handle_output(TRUE) } hook_list <- list( persp = capture_plot, before.plot.new = capture_plot, before.grid.newpage = capture_plot ) set_hooks(hook_list) on.exit(remove_hooks(hook_list), add = TRUE) handle_condition <- function(cond) { handle_output() output <<- c(output, list(cond)) } # Handlers for warnings, errors and messages wHandler <- if (keep_warning) function(wn) { # do not handle the warning as it will be raised as error after if (getOption("warn") >= 2) return() if (getOption("warn") >= 0) { handle_condition(wn) output_handler$warning(wn) } invokeRestart("muffleWarning") } else identity eHandler <- if (use_try) function(e) { handle_condition(e) output_handler$error(e) } else identity mHandler <- if (keep_message) function(m) { handle_condition(m) output_handler$message(m) invokeRestart("muffleMessage") } else identity ev <- list(value = NULL, visible = FALSE) if (use_try) { handle <- function(f) try(f, silent = TRUE) } else { handle <- force } value_handler <- output_handler$value if (include_timing) { timing_fn <- function(x) system.time(x)[1:3] } else { timing_fn <- function(x) {x; NULL}; } if (length(funs <- .env$inject_funs)) { 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] on.exit(rm(list = funs_names, envir = envir), add = TRUE) for (i in seq_along(funs_names)) assign(funs_names[i], funs[[i]], envir) } multi_args <- length(formals(value_handler)) > 1 for (expr in call) { srcindex <- length(output) time <- timing_fn(handle(ev <- withCallingHandlers( withVisible(eval(expr, envir, enclos)), warning = wHandler, error = eHandler, message = mHandler))) handle_output(TRUE) if (!is.null(time)) attr(output[[srcindex]]$src, 'timing') <- time # If visible or the value handler has multi args, process and capture output if (ev$visible || multi_args) { pv <- list(value = NULL, visible = FALSE) value_fun <- if (multi_args) value_handler else { function(x, visible) value_handler(x) } handle(pv <- withCallingHandlers(withVisible( value_fun(ev$value, ev$visible) ), warning = wHandler, error = eHandler, message = mHandler)) handle_output(TRUE) # If the return value is visible, save the value to the output if (pv$visible) output <- c(output, list(pv$value)) } } # Always capture last plot, even if incomplete if (last) { handle_output(TRUE, TRUE) } output } #' 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 #' @examples library(evaluate) #' # normally you cannot capture the output of system #' evaluate("system('R --version')") #' #' # replace the system() function #' inject_funs(system = function(...) cat(base::system(..., intern = TRUE), sep = '\n')) #' #' evaluate("system('R --version')") #' #' inject_funs() # empty previously injected functions #' @export inject_funs <- function(...) { funs <- list(...) funs <- funs[names(funs) != ''] .env$inject_funs <- Filter(is.function, funs) } evaluate/R/hooks.r0000644000176200001440000000251113444255736013603 0ustar liggesusers#' Set hooks. #' #' This 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 #' new <- list(before.plot.new = function() print("Plotted!")) #' hooks <- set_hooks(new) #' plot(1) #' set_hooks(hooks, "replace") #' 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) } #' Remove hooks. #' #' This provides a way to remove previously set hook values. #' #' @inheritParams set_hooks #' @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) 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/watcher.r0000644000176200001440000000427713430172574014121 0ustar liggesusers#' Watch for changes in output, text and graphical. #' #' @param debug activate debug mode where output will be both printed to #' screen and captured. #' @return list containing four functions: `get_new`, `pause`, #' `unpause`, `close`. #' @keywords internal watchout <- function(debug = FALSE) { output <- character() prev <- character() con <- textConnection("output", "wr", local = TRUE) sink(con, split = debug) list( get_new = function(plot = FALSE, incomplete_plots = FALSE, text_callback = identity, graphics_callback = identity) { incomplete <- isIncomplete(con) if (incomplete) cat("\n") out <- list() if (plot) { out$graphics <- plot_snapshot(incomplete_plots) if (!is.null(out$graphics)) graphics_callback(out$graphics) } n0 <- length(prev) n1 <- length(output) if (n1 > n0) { new <- output[n0 + seq_len(n1 - n0)] prev <<- output out$text <- paste0(new, collapse = "\n") if (!incomplete) out$text <- paste0(out$text, "\n") text_callback(out$text) } unname(out) }, pause = function() sink(), unpause = function() sink(con, split = debug), close = function() { if (!isOpen(con)) stop("something bad happened... did you use closeAllConnections()?") sink() close(con) output }, get_con = function() con ) } .env = new.env() .env$flush_console = function() {} #' An emulation of flush.console() in evaluate() #' #' 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. #' @note 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() .env$flush_console() evaluate/R/output.r0000644000176200001440000000655213430172574014022 0ustar liggesusers#' Object class tests #' @export is.message is.warning is.error is.value is.source is.recordedplot #' @aliases is.message is.warning is.error is.value is.source is.recordedplot #' @keywords internal #' @rdname is.message is.message <- function(x) inherits(x, "message") #' @rdname is.message is.warning <- function(x) inherits(x, "warning") #' @rdname is.message is.error <- function(x) inherits(x, "error") #' @rdname is.message is.value <- function(x) inherits(x, "value") #' @rdname is.message is.source <- function(x) inherits(x, "source") #' @rdname is.message is.recordedplot <- function(x) inherits(x, "recordedplot") new_value <- function(value, visible = TRUE) { structure(list(value = value, visible = visible), class = "value") } new_source <- function(src) { structure(list(src = src), class = "source") } classes <- function(x) vapply(x, function(x) class(x)[1], character(1)) render <- function(x) if (isS4(x)) methods::show(x) else print(x) #' 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. #' @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 #' only has one argument, only visible values are handled; if it has more #' arguments, the second argument indicates whether the value is visible. #' @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) { 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) structure(list(source = source, text = text, graphics = graphics, message = message, warning = warning, error = error, value = value), class = "output_handler") } default_output_handler <- new_output_handler() evaluate/R/parse.r0000644000176200001440000001404413430172574013567 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 with columns `src`, the source code, and #' `expr`. If there are syntax errors in `x` and `allow_error = #' TRUE`, the data frame has an attribute `PARSE_ERROR` that stores the #' error object. #' @export parse_all <- function(x, filename = NULL, allow_error = FALSE) UseMethod("parse_all") #' @export parse_all.character <- function(x, filename = NULL, allow_error = FALSE) { # Do not convert strings to factors by default in data.frame() op <- options(stringsAsFactors = FALSE) on.exit(options(op), add = TRUE) if (length(grep("\n", x))) { # strsplit('a\n', '\n') needs to return c('a', '') instead of c('a') x <- gsub("\n$", "\n\n", x) x[x == ""] <- "\n" x <- unlist(strsplit(x, "\n"), recursive = FALSE, use.names = FALSE) } n <- length(x) if (is.null(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 = I(list(expression()))), PARSE_ERROR = exprs )) } else { exprs <- parse(text = x, srcfile = src) } # No code, only comments and/or empty lines ne <- length(exprs) if (ne == 0) { return(data.frame(src = append_break(x), expr = I(rep(list(NULL), n)))) } srcref <- attr(exprs, "srcref", exact = TRUE) # Stard/End line numbers of expressions pos <- do.call(rbind, lapply(srcref, unclass))[, c(1, 3), drop = FALSE] l1 <- pos[, 1] l2 <- pos[, 2] # Add a third column i to store the indices of expressions pos <- cbind(pos, i = seq_len(nrow(pos))) pos <- as.data.frame(pos) # split() does not work on matrices # Split line number pairs into groups: if the next start line is the same as # the last end line, the two expressions must belong to the same group spl <- cumsum(c(TRUE, l1[-1] != l2[-ne])) # Extract src lines and expressions for each group; also record the start line # number of this group so we can re-order src/expr later res <- lapply(split(pos, spl), function(p) { n <- nrow(p) data.frame( src = paste(x[p[1, 1]:p[n, 2]], collapse = "\n"), expr = I(list(exprs[p[, 3]])), line = p[1, 1] ) }) # Now process empty expressions (comments/blank lines); see if there is a # "gap" between the last end number + 1 and the next start number - 1 pos <- cbind(c(1, l2 + 1), c(l1 - 1, n)) pos <- pos[pos[, 1] <= pos[, 2], , drop = FALSE] # Extract src lines from the gaps, and assign empty expressions to them res <- c(res, lapply(seq_len(nrow(pos)), function(i) { p <- pos[i, ] r <- p[1]:p[2] data.frame( src = x[r], expr = I(rep(list(NULL), p[2] - p[1] + 1)), line = r - 1 ) })) # Bind everything into a data frame, order it by line numbers, append \n to # all src lines except the last one, and remove the line numbers res <- do.call(rbind, res) res <- res[order(res$line), ] res$src <- append_break(res$src) res$line <- NULL # For compatibility with evaluate (<= 0.5.7): remove the last empty line (YX: # I think this is a bug) n <- nrow(res) if (res$src[n] == "") res <- res[-n, ] rownames(res) <- NULL res } # YX: It seems evaluate (<= 0.5.7) had difficulties with preserving line breaks, # so it ended up with adding \n to the first n-1 lines, which does not seem to # be necessary to me, and is actually buggy. I'm not sure if it is worth shaking # the earth and work with authors of reverse dependencies to sort this out. Also # see #42. append_break <- function(x) { n <- length(x) if (n <= 1) x else paste(x, rep(c("\n", ""), c(n - 1, 1)), sep = "") } # YX: This hack is because srcfilecopy() uses grepl("\n", fixed = TRUE), which # does not work when the source lines contain multibyte characters that are not # representable in the current locale on Windows (see # https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16264). In our case, we # have already split the lines by \n, so there is no need to do that again like # srcfilecopy() does internally. if (getRversion() <= '3.2.2') srcfilecopy <- function(filename, lines, ...) { src <- base::srcfilecopy(filename, lines = "", ...) src$lines <- lines src } #' @export parse_all.connection <- function(x, filename = NULL, ...) { if (!isOpen(x, "r")) { open(x, "r") on.exit(close(x)) } text <- readLines(x) if (is.null(filename)) filename <- summary(x)$description parse_all(text, filename, ...) } #' @export parse_all.function <- function(x, filename = NULL, ...) { src <- attr(x, "srcref", exact = TRUE) if (is.null(src)) { src <- deparse(body(x)) # Remove { and } n <- length(src) if (n >= 2) src <- src[-c(1, n)] if (is.null(filename)) filename <- "" parse_all(src, filename, ...) } else { src2 <- attr(body(x), "srcref", exact = TRUE) n <- length(src2) if (n > 0) { if (is.null(filename)) filename <- attr(src, 'srcfile')$filename if (n >= 2) { parse_all(unlist(lapply(src2[-1], as.character)), filename, ...) } else { # f <- function(...) {} parse_all(character(0), filename, ...) } } else { if (is.null(filename)) filename <- "" parse_all(deparse(body(x)), filename, ...) } } } #' @export parse_all.default <- function(x, filename = NULL, ...) { if (is.null(filename)) filename <- "" parse_all(deparse(x), filename, ...) } # Calls are already parsed and always length one #' @export parse_all.call <- function(x, filename = NULL, ...) { out <- parse_all.default(x, filename = filename, ...) out$expr <- list(as.expression(x)) out } evaluate/README.md0000644000176200001440000000227513444260000013336 0ustar liggesusers# Evaluate [![Build Status](https://travis-ci.org/r-lib/evaluate.svg)](https://travis-ci.org/r-lib/evaluate) [![Downloads from the RStudio CRAN mirror](https://cranlogs.r-pkg.org/badges/evaluate)](https://cran.r-project.org/package=evaluate) 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. 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/MD50000644000176200001440000000664313473254252012410 0ustar liggesusersef31ab942273ee1a28459533767af3c6 *DESCRIPTION 4d85b280c584cd25a3295bc0fa7c49ce *LICENSE 437c0030837a125263825c691c0b90c7 *NAMESPACE 232478604fa704826fe8fda23adf74c9 *NEWS.md c4b39f17eb9384b669a35136a3122d31 *R/eval.r aafc2bed34385af43269af8e64f1e01e *R/graphics.r 4d6bfdb8870799394ccb6affc752f706 *R/hooks.r 434d218bc077ac10d65b3a011c564bb8 *R/output.r 4bc8214c0a1411ace37a2f36e9254e84 *R/parse.r 32eedee1c5ff92e7413a15b0f2bb5aff *R/replay.r 621066d5bd50b2af562db7ef5a6e58ce *R/traceback.r 596eff492e48e7f1eea0069751faa9b9 *R/watcher.r 3ec4352139763b1d987c384e5d2c54f3 *README.md b6e6ee1f28ceac82a8557de5e7d9f80a *man/create_traceback.Rd dd973be5e436f9fa50d708e7fc3cbead *man/evaluate.Rd dcfdd8b3176035bca65f547574b18580 *man/flush_console.Rd f0f10e028751e4d38a606050f1cca096 *man/inject_funs.Rd 7bbb8ef6f236c5876ab4e4898e12efbd *man/is.message.Rd 9346c6d63cef05f64a62f61926b3123b *man/line_prompt.Rd ed4f1e2bfc9a1d602485d785c4d86eba *man/new_output_handler.Rd 212320089073cddb8a48e2b1ffd89c16 *man/parse_all.Rd e040e2e1d5bd114092351e827e42a68e *man/remove_hooks.Rd 4f7ec39a51becb946cc662dd7bff30ae *man/replay.Rd 1c30486bfe3cbaf446692452a9a020f7 *man/set_hooks.Rd 9b69c48fa0eed4b9a41c5ee352087f53 *man/try_capture_stack.Rd 720a159d26896ae09f15f4e764f572b5 *man/watchout.Rd 7d1137c5d46bfb4567e5300009945ca2 *tests/test-all.R 35c21d767406d7a49427a2faf25c3ddd *tests/test-parse.R 7916e1d386024a89d6e8c8e5aa061bd7 *tests/test-replay.R 446d67f5fc9a97626f757fae3fefcee7 *tests/testthat/comment.r 94750480cbfd8455ba433ab42828023e *tests/testthat/data.r 38a0bd49c764aefce15f4844036ccf02 *tests/testthat/error-complex.r fea574ba53709e7b38a294d855011323 *tests/testthat/error.r 24e9ae27434864fdef5901807e66ea98 *tests/testthat/example-1.r 19234a68f3630d7690a8232714fa5d04 *tests/testthat/ggplot-loop.r 9792e29336dfe5fe654b91a231d4bd1e *tests/testthat/ggplot.r 7f8df2eafe897d4ef3984fa881276903 *tests/testthat/interleave-1.r c46d014984f40ebdad0ee83a4c0b0666 *tests/testthat/interleave-2.r c887105bd174693b5ab37f3c1e92ec10 *tests/testthat/order.r 237f9f25bfab96f6928e6f29297c4827 *tests/testthat/parse.r ea5f897a7a8a861dffbfb4a97f4ba666 *tests/testthat/plot-additions.r 9cf8a8768e36e0e4b9f33c7dae3e2a29 *tests/testthat/plot-clip.r 3eb3a37b6b99567c00e9e252d3cfc079 *tests/testthat/plot-last-comment.r 396ff3413370398b3be86fa9a27ae235 *tests/testthat/plot-loop.r e4085acac5469333f8615cf24ba3c2a8 *tests/testthat/plot-multi-layout.r af1fd71e6872ce27f380da68d9e57638 *tests/testthat/plot-multi-layout2.r 2f5434a4a5a4a9fa0164c21ee9ec52f4 *tests/testthat/plot-multi-missing.r 4b9fd50ee21d4f3da6332ffed48746cb *tests/testthat/plot-multi.r b4952448dc702d1ce95cb57b8d2660f5 *tests/testthat/plot-new.r 6013de5aae712457dedf5a949395a7b4 *tests/testthat/plot-par.r ea7ff46a39730ce982233eb4a603329e *tests/testthat/plot-par2.r 9647c89b1105dba33f01d78992c1a5f8 *tests/testthat/plot-persp.r 07096b6184ee44418a18cbedbe4aa5b6 *tests/testthat/plot-strwidth.r 4cbfd1ffe04ab0562a2514f22a2e049d *tests/testthat/plot.r 7df061829daeba528956cfd392bac1e7 *tests/testthat/raw-output.r 369084284055bfce832dc131c710e62b *tests/testthat/test-errors.r be4eccb8aa6b6d3c810b94dc7095a8f5 *tests/testthat/test-evaluate.r 41bdf3d19acebc48429ac8120a79c757 *tests/testthat/test-graphics.r f558fc2fc0f097cdf455ad5cc1467240 *tests/testthat/test-output-handler.R f0dfe4d4709355498c1d03d06a149a7a *tests/testthat/test-output.r 56af2ed8ebfb5619225ca93b3a71b538 *tests/testthat/test-parse.r 905d85f44018ba83d1eb33636d13b2a4 *tests/testthat/try.r evaluate/DESCRIPTION0000644000176200001440000000272613473254252013604 0ustar liggesusersPackage: evaluate Type: Package Title: Parsing and Evaluation Tools that Provide More Details than the Default Version: 0.14 Authors@R: c( person("Hadley", "Wickham", role = "aut"), person("Yihui", "Xie", role = c("aut", "cre"), email = "xie@yihui.name", 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") ) Description: Parsing and evaluation tools that make it easy to recreate the command line behaviour of R. License: MIT + file LICENSE URL: https://github.com/r-lib/evaluate BugReports: https://github.com/r-lib/evaluate/issues Depends: R (>= 3.0.2) Imports: methods Suggests: testthat, lattice, ggplot2 RoxygenNote: 6.1.1 Encoding: UTF-8 NeedsCompilation: no Packaged: 2019-05-28 15:30:02 UTC; yihui Author: Hadley Wickham [aut], Yihui Xie [aut, cre] (), 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] Maintainer: Yihui Xie Repository: CRAN Date/Publication: 2019-05-28 15:50:02 UTC evaluate/man/0000755000176200001440000000000013444255624012644 5ustar liggesusersevaluate/man/line_prompt.Rd0000644000176200001440000000100213473251771015455 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.Rd0000644000176200001440000000213113473251771015440 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval.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.} } \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 inject_funs(system = function(...) cat(base::system(..., intern = TRUE), sep = "\\n")) evaluate("system('R --version')") inject_funs() # empty previously injected functions } \keyword{internal} evaluate/man/create_traceback.Rd0000644000176200001440000000065113473251771016400 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.calls]{base::sys.calls()}}} } \description{ Generate a traceback from a list of calls. } \keyword{internal} evaluate/man/evaluate.Rd0000644000176200001440000000460313473251771014745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval.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, new_device = TRUE, output_handler = default_output_handler, 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}{if \code{2}, evaluation will halt on first error and you will get no results back. If \code{1}, evaluation will stop on first error without signaling the error, and you will get back all results up to that point. If \code{0} will continue running all code, just as if you'd pasted the code into the command line.} \item{keep_warning, keep_message}{whether to record warnings and messages.} \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}{if \code{TRUE}, evaluate will wrap each input expression in \code{system.time()}, which will be accessed by following \code{replay()} call to produce timing information for each evaluated command.} } \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. } evaluate/man/replay.Rd0000644000176200001440000000116413473251771014432 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{ samples <- system.file("tests", "testthat", package = "evaluate") if (file_test("-d", samples)) { replay(evaluate(file(file.path(samples, "order.r")))) replay(evaluate(file(file.path(samples, "plot.r")))) replay(evaluate(file(file.path(samples, "data.r")))) } } evaluate/man/parse_all.Rd0000644000176200001440000000147513473251771015105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parse.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 with columns \code{src}, the source code, and \code{expr}. If there are syntax errors in \code{x} and \code{allow_error = TRUE}, the data frame has an attribute \code{PARSE_ERROR} that stores the error object. } \description{ Works very similarly to parse, but also keeps original formatting and comments. } evaluate/man/set_hooks.Rd0000644000176200001440000000122413473251771015131 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hooks.r \name{set_hooks} \alias{set_hooks} \title{Set hooks.} \usage{ set_hooks(hooks, action = "append") } \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 wraps the base \code{\link[=setHook]{setHook()}} function to provide a return value that makes it easy to undo. } \examples{ new <- list(before.plot.new = function() print("Plotted!")) hooks <- set_hooks(new) plot(1) set_hooks(hooks, "replace") plot(1) } \keyword{internal} evaluate/man/try_capture_stack.Rd0000644000176200001440000000075113473251771016665 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/watchout.Rd0000644000176200001440000000077013473251771014776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/watcher.r \name{watchout} \alias{watchout} \title{Watch for changes in output, text and graphical.} \usage{ watchout(debug = FALSE) } \arguments{ \item{debug}{activate debug mode where output will be both printed to screen and captured.} } \value{ list containing four functions: \code{get_new}, \code{pause}, \code{unpause}, \code{close}. } \description{ Watch for changes in output, text and graphical. } \keyword{internal} evaluate/man/new_output_handler.Rd0000644000176200001440000000350013473251771017040 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/output.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) } \arguments{ \item{source}{Function to handle the echoed source code under evaluation.} \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. If it only has one argument, only visible values are handled; if it has more arguments, the second argument indicates whether the value is visible.} } \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/flush_console.Rd0000644000176200001440000000156413473251771016005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/watcher.r \name{flush_console} \alias{flush_console} \title{An emulation of flush.console() in 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. } \note{ 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/is.message.Rd0000644000176200001440000000061713473251771015176 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/output.r \name{is.message} \alias{is.message} \alias{is.warning} \alias{is.error} \alias{is.value} \alias{is.source} \alias{is.recordedplot} \title{Object class tests} \usage{ is.message(x) is.warning(x) is.error(x) is.value(x) is.source(x) is.recordedplot(x) } \description{ Object class tests } \keyword{internal} evaluate/man/remove_hooks.Rd0000644000176200001440000000115213473251771015633 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hooks.r \name{remove_hooks} \alias{remove_hooks} \title{Remove hooks.} \usage{ remove_hooks(hooks) } \arguments{ \item{hooks}{a named list of hooks - each hook can either be a function or a list of functions.} } \description{ This provides a way to remove previously set hook values. } \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/LICENSE0000644000176200001440000000007713444260132013070 0ustar liggesusersYEAR: 2008-2019 COPYRIGHT HOLDER: Hadley Wickham and Yihui Xie