[med-svn] [r-cran-evaluate] 08/10: New upstream version 0.10
Andreas Tille
tille at debian.org
Sat Sep 30 08:09:40 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-evaluate.
commit 0129920bf1740d663e265bac779a0c5f0545943b
Author: Andreas Tille <tille at debian.org>
Date: Sat Sep 30 10:06:52 2017 +0200
New upstream version 0.10
---
DESCRIPTION | 34 +++++
LICENSE | 2 +
MD5 | 59 +++++++++
NAMESPACE | 32 +++++
NEWS | 222 ++++++++++++++++++++++++++++++++
R/eval.r | 241 +++++++++++++++++++++++++++++++++++
R/graphics.r | 69 ++++++++++
R/hooks.r | 28 ++++
R/output.r | 85 ++++++++++++
R/parse.r | 172 +++++++++++++++++++++++++
R/replay.r | 117 +++++++++++++++++
R/traceback.r | 43 +++++++
R/watcher.r | 69 ++++++++++
debian/README.test | 8 --
debian/changelog | 30 -----
debian/compat | 1 -
debian/control | 23 ----
debian/copyright | 31 -----
debian/docs | 3 -
debian/rules | 4 -
debian/source/format | 1 -
debian/tests/control | 3 -
debian/tests/run-unit-test | 15 ---
debian/watch | 2 -
man/create_traceback.Rd | 15 +++
man/evaluate.Rd | 52 ++++++++
man/flush_console.Rd | 20 +++
man/inject_funs.Rd | 34 +++++
man/is.message.Rd | 26 ++++
man/line_prompt.Rd | 21 +++
man/new_output_handler.Rd | 47 +++++++
man/parse_all.Rd | 24 ++++
man/replay.Rd | 22 ++++
man/set_hooks.Rd | 25 ++++
man/try_capture_stack.Rd | 17 +++
man/watchout.Rd | 19 +++
tests/test-all.R | 3 +
tests/test-parse.R | 4 +
tests/test-replay.R | 7 +
tests/testthat/comment.r | 2 +
tests/testthat/data.r | 2 +
tests/testthat/error-complex.r | 5 +
tests/testthat/error.r | 2 +
tests/testthat/example-1.r | 22 ++++
tests/testthat/ggplot-loop.r | 6 +
tests/testthat/ggplot.r | 2 +
tests/testthat/interleave-1.r | 4 +
tests/testthat/interleave-2.r | 4 +
tests/testthat/order.r | 16 +++
tests/testthat/parse.r | 6 +
tests/testthat/plot-additions.r | 2 +
tests/testthat/plot-clip.r | 3 +
tests/testthat/plot-last-comment.r | 4 +
tests/testthat/plot-loop.r | 4 +
tests/testthat/plot-multi-layout.r | 7 +
tests/testthat/plot-multi-layout2.r | 9 ++
tests/testthat/plot-multi-missing.r | 4 +
tests/testthat/plot-multi.r | 5 +
tests/testthat/plot-new.r | 5 +
tests/testthat/plot-par.r | 3 +
tests/testthat/plot-par2.r | 5 +
tests/testthat/plot-persp.r | 8 ++
tests/testthat/plot-strwidth.r | 4 +
tests/testthat/plot.r | 1 +
tests/testthat/raw-output.r | 4 +
tests/testthat/test-errors.r | 28 ++++
tests/testthat/test-evaluate.r | 84 ++++++++++++
tests/testthat/test-graphics.r | 141 ++++++++++++++++++++
tests/testthat/test-output-handler.R | 17 +++
tests/testthat/test-output.r | 8 ++
tests/testthat/test-parse.r | 34 +++++
71 files changed, 1960 insertions(+), 121 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..995d3ba
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,34 @@
+Package: evaluate
+Type: Package
+Title: Parsing and Evaluation Tools that Provide More Details than the
+ Default
+Version: 0.10
+Date: 2016-10-10
+Authors at R: c(
+ person("Hadley", "Wickham", role = "aut"),
+ person("Yihui", "Xie", role = c("cre", "ctb"), email = "xie at yihui.name"),
+ person("Michael", "Lawrence", role = "ctb"),
+ person("Thomas", "Kluyver", role = "ctb"),
+ person("Barret", "Schloerke", role = "ctb"),
+ person("Adam", "Ryczkowski", 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/hadley/evaluate
+BugReports: https://github.com/hadley/evaluate/issues
+Depends: R (>= 3.0.2)
+Imports: methods, stringr (>= 0.6.2)
+Suggests: testthat, lattice, ggplot2
+RoxygenNote: 5.0.1
+NeedsCompilation: no
+Packaged: 2016-10-10 21:31:23 UTC; yihui
+Author: Hadley Wickham [aut],
+ Yihui Xie [cre, ctb],
+ Michael Lawrence [ctb],
+ Thomas Kluyver [ctb],
+ Barret Schloerke [ctb],
+ Adam Ryczkowski [ctb]
+Maintainer: Yihui Xie <xie at yihui.name>
+Repository: CRAN
+Date/Publication: 2016-10-11 12:23:58
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f54ab14
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,2 @@
+YEAR: 2008-2016
+COPYRIGHT HOLDER: Hadley Wickham and Yihui Xie
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..977bef4
--- /dev/null
+++ b/MD5
@@ -0,0 +1,59 @@
+59aaac5257800a548aa55e1a9589f44f *DESCRIPTION
+5d74770859214f3b20c7bd9a25cfb2a7 *LICENSE
+7389c055556bacdff27f0bbb23f052cc *NAMESPACE
+399b7eb7f20d1bf932e6dddda6009f0e *NEWS
+557c7937fa25ebd7fa8c7d3e9435451b *R/eval.r
+aafc2bed34385af43269af8e64f1e01e *R/graphics.r
+92ff4620dde1944914335f47d5d71b1f *R/hooks.r
+ec72e3ca7f14677e8f3018a1be7f54d8 *R/output.r
+3e4b8dfa2b0609377dc591eae91d3db0 *R/parse.r
+e8e364a4ff2df3073c15b4c0a65c7c49 *R/replay.r
+97f0d9e1b50256566a00cc6041282e35 *R/traceback.r
+1bcf653622a35ca8e93d23bdf65358e3 *R/watcher.r
+aa072dad614b9b059bfbc67a9620aff5 *man/create_traceback.Rd
+4e10a13f208f22814223a7da695f1ed9 *man/evaluate.Rd
+50d0a0783a627f989f7d8fba01e0c232 *man/flush_console.Rd
+36526afd3364866338ad165b94bc9c08 *man/inject_funs.Rd
+cbb3a6af043a41a8b8b541846718d2a7 *man/is.message.Rd
+4ee15ea5836a2ddf17c4c1395e77061c *man/line_prompt.Rd
+d008953a2b0d6dd8d8953572a5b32bac *man/new_output_handler.Rd
+a08a655bde6b48ba68759a8c3dcd5ccf *man/parse_all.Rd
+ebe2aeb51e3c227e7828f4de2cc91e75 *man/replay.Rd
+ccca4a56f759d354810d6fbdc7d1ec99 *man/set_hooks.Rd
+c396dff730edb18ade42f74991b17909 *man/try_capture_stack.Rd
+20d5eca3698c82aa5a13354056a0547a *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
+8380a85c703130982fdd4710c0030c37 *tests/testthat/test-errors.r
+2a8fab4e9a8727e85c431ea3afe4b16b *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
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..65a6980
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,32 @@
+S3method(parse_all,"function")
+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(replay)
+export(set_hooks)
+export(try_capture_stack)
+import(grDevices)
+import(graphics)
+import(stringr)
+import(utils)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..fe91a1c
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,222 @@
+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`
+
+evaluate 0.4 (2011-11-03)
+=========================
+
+* Use plot hooks to capture multiple plots created in a loop or within a
+ function. (Contributed by Yihui Xie)
+
+evaluate 0.3
+============
+
+* Import `stringr` instead of depending on it.
+
+* Test plot recording only in the presence of interactive devices.
+
+evaluate 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.
diff --git a/R/eval.r b/R/eval.r
new file mode 100644
index 0000000..5722632
--- /dev/null
+++ b/R/eval.r
@@ -0,0 +1,241 @@
+#' Evaluate input and return all details of evaluation.
+#'
+#' Compare to \code{\link{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.
+#'
+#' @export
+#' @param input input object to be parsed and evaluated. May be a string, file
+#' connection or function.
+#' @param envir environment in which to evaluate expressions.
+#' @param enclos when \code{envir} is a list or data frame, this is treated as
+#' the parent environment to \code{envir}.
+#' @param debug if \code{TRUE}, displays information useful for debugging,
+#' including all output that evaluate captures.
+#' @param 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.
+#' @param keep_warning,keep_message whether to record warnings and messages.
+#' @param 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.
+#' @param output_handler an instance of \code{\link{output_handler}} that
+#' processes the output from the evaluation. The default simply prints the
+#' visible return values.
+#' @param filename string overrriding the \code{\link[base]{srcfile}} filename.
+#' @param 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.
+#' @import graphics grDevices stringr 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())
+ 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)
+ }
+ old_hooks <- set_hooks(list(
+ persp = capture_plot,
+ before.plot.new = capture_plot,
+ before.grid.newpage = capture_plot))
+ on.exit(set_hooks(old_hooks, "replace"), 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) {
+ 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 \code{evaluate()}
+#'
+#' Create functions in the environment specified in the \code{envir} argument of
+#' \code{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)
+}
diff --git a/R/graphics.r b/R/graphics.r
new file mode 100644
index 0000000..4ab619c
--- /dev/null
+++ b/R/graphics.r
@@ -0,0 +1,69 @@
+#" 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"]]
+ })
+}
diff --git a/R/hooks.r b/R/hooks.r
new file mode 100644
index 0000000..1d69002
--- /dev/null
+++ b/R/hooks.r
@@ -0,0 +1,28 @@
+#' Set hooks.
+#'
+#' This wraps the base \code{\link{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 \code{"replace"}, \code{"append"} or \code{"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") {
+ stopifnot(is.list(hooks))
+ stopifnot(!is.null(names(hooks)) && all(names(hooks) != ""))
+
+ old <- list()
+ for (hook_name in names(hooks)) {
+ old[[hook_name]] <- getHook(hook_name)
+ setHook(hook_name, hooks[[hook_name]], action = action)
+ }
+
+ invisible(old)
+}
diff --git a/R/output.r b/R/output.r
new file mode 100644
index 0000000..dbb5a7f
--- /dev/null
+++ b/R/output.r
@@ -0,0 +1,85 @@
+#' 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 \code{output_handler} handles the results of \code{\link{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
+#' \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.
+#'
+#' @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
+#' \code{\link{recordPlot}}.
+#' @param message Function to handle \code{\link{message}} output.
+#' @param warning Function to handle \code{\link{warning}} output.
+#' @param error Function to handle \code{\link{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 \code{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()
diff --git a/R/parse.r b/R/parse.r
new file mode 100644
index 0000000..c883ce7
--- /dev/null
+++ b/R/parse.r
@@ -0,0 +1,172 @@
+#' 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
+#' @param filename string overriding the file name
+#' @param allow_error whether to allow syntax errors in \code{x}
+#' @return 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.
+#' @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)))
+ x <- unlist(str_split(x, "\n"), recursive = FALSE, use.names = FALSE)
+ n <- length(x)
+
+ if (is.null(filename))
+ filename <- "<text>"
+ 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 <- "<function>"
+ 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 <- "<function>"
+ parse_all(deparse(body(x)), filename, ...)
+ }
+ }
+}
+
+#' @export
+parse_all.default <- function(x, filename = NULL, ...) {
+ if (is.null(filename))
+ filename <- "<expression>"
+ parse_all(deparse(x), filename, ...)
+}
diff --git a/R/replay.r b/R/replay.r
new file mode 100644
index 0000000..887f0bf
--- /dev/null
+++ b/R/replay.r
@@ -0,0 +1,117 @@
+#' 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 \code{\link{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(str_c(s, line_prompt(x$src)))
+}
+
+#' @export
+replay.warning <- function(x) {
+ message("Warning message:\n", x$message)
+}
+
+#' @export
+replay.message <- function(x) {
+ message(str_replace(x$message, "\n$", ""))
+}
+
+#' @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] <- str_c(prompt, lines[1])
+ if (n > 1)
+ lines[2:n] <- str_c(continue, lines[2:n])
+
+ str_c(lines, "\n", collapse = "")
+}
diff --git a/R/traceback.r b/R/traceback.r
new file mode 100644
index 0000000..3eb94e2
--- /dev/null
+++ b/R/traceback.r
@@ -0,0 +1,43 @@
+#' Generate a traceback from a list of calls.
+#'
+#' @param callstack stack of calls, as generated by (e.g.)
+#' \code{\link[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, str_c, collapse = "\n")
+
+ # Number and indent
+ calls <- str_c(seq_along(calls), ": ", calls)
+ calls <- str_replace(calls, "\n", "\n ")
+ calls
+}
+
+#' Try, capturing stack on error.
+#'
+#' This is a variant of \code{\link{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) {
+ # 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
+ )
+}
diff --git a/R/watcher.r b/R/watcher.r
new file mode 100644
index 0000000..5653f4a
--- /dev/null
+++ b/R/watcher.r
@@ -0,0 +1,69 @@
+#' 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: \code{get_new}, \code{pause},
+#' \code{unpause}, \code{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 <- str_c(new, collapse = "\n")
+ if (!incomplete) out$text <- str_c(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
+ }
+ )
+}
+
+.env = new.env()
+.env$flush_console = function() {}
+
+#' An emulation of flush.console() in evaluate()
+#'
+#' When \code{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).
+#' @export
+flush_console = function() .env$flush_console()
diff --git a/debian/README.test b/debian/README.test
deleted file mode 100644
index 55a9142..0000000
--- a/debian/README.test
+++ /dev/null
@@ -1,8 +0,0 @@
-Notes on how this package can be tested.
-────────────────────────────────────────
-
-To run the unit tests provided by the package you can do
-
- sh run-unit-test
-
-in this directory.
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 7a9cc37..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,30 +0,0 @@
-r-cran-evaluate (0.10-1) unstable; urgency=medium
-
- * New upstream version
- * Convert to dh-r
- * Canonical homepage for CRAN
- * d/watch: version=4
-
- -- Andreas Tille <tille at debian.org> Sat, 12 Nov 2016 08:04:25 +0100
-
-r-cran-evaluate (0.9-1) unstable; urgency=medium
-
- * New upstream version
- * cme fix dpkg-control
- * DEP5 fixes
- * Enhance autopkgtest
-
- -- Andreas Tille <tille at debian.org> Sat, 30 Apr 2016 09:39:01 +0200
-
-r-cran-evaluate (0.5.5-1) unstable; urgency=medium
-
- * New upstream version
- * Add autopkgtest
-
- -- Andreas Tille <tille at debian.org> Fri, 20 Jun 2014 23:52:57 +0200
-
-r-cran-evaluate (0.5.1-1) unstable; urgency=low
-
- * Initial release (closes: #732364)
-
- -- Andreas Tille <tille at debian.org> Tue, 17 Dec 2013 09:22:14 +0100
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index ec63514..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-9
diff --git a/debian/control b/debian/control
deleted file mode 100644
index c88308f..0000000
--- a/debian/control
+++ /dev/null
@@ -1,23 +0,0 @@
-Source: r-cran-evaluate
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 9),
- dh-r,
- r-base-dev,
- r-cran-stringr
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-med/trunk/packages/R/r-cran-evaluate/trunk/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/R/r-cran-evaluate/trunk/
-Homepage: https://cran.r-project.org/package=evaluate
-
-Package: r-cran-evaluate
-Architecture: all
-Depends: ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R parsing and evaluation tools
- Parsing and evaluation tools that provide more details than the default
- to make it easy to recreate the command line behaviour of R.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index ee3c0a0..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,31 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Contact: Yihui Xie <xie at yihui.name>
-Upstream-Name: evaluate
-Source: https://cran.r-project.org/package=evaluate
-
-Files: *
-Copyright: 2005-2016 Hadley Wickham <h.wickham at gmail.com>
-License: GPL-2+
-
-Files: debian/*
-Copyright: 2013-2016 Andreas Tille <tille at debian.org>
-License: GPL-2+
-
-License: GPL-2+
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- .
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- .
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
- .
- On Debian systems, the complete text of the GNU General Public
- License can be found in `/usr/share/common-licenses/GPL-2'.
-
diff --git a/debian/docs b/debian/docs
deleted file mode 100644
index 3adf0d6..0000000
--- a/debian/docs
+++ /dev/null
@@ -1,3 +0,0 @@
-debian/README.test
-debian/tests/run-unit-test
-tests
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/tests/control b/debian/tests/control
deleted file mode 100644
index b044b0c..0000000
--- a/debian/tests/control
+++ /dev/null
@@ -1,3 +0,0 @@
-Tests: run-unit-test
-Depends: @, r-cran-testthat
-Restrictions: allow-stderr
diff --git a/debian/tests/run-unit-test b/debian/tests/run-unit-test
deleted file mode 100644
index 67bc7f4..0000000
--- a/debian/tests/run-unit-test
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh -e
-
-pkg=r-cran-evaluate
-
-if [ "$ADTTMP" = "" ] ; then
- ADTTMP=`mktemp -d /tmp/${pkg}-test.XXXXXX`
-fi
-cd $ADTTMP
-cp -a /usr/share/doc/${pkg}/tests/* $ADTTMP
-find . -name "*.gz" -exec gunzip \{\} \;
-for runtest in `ls *.R` ; do
- # Make sure we are using C locale to pass all tests
- LC_ALL=C R --no-save < $runtest
-done
-rm -rf $ADTTMP/*
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index b6e5c16..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=4
-http://cran.r-project.org/src/contrib/evaluate_([-\d.]*)\.tar\.gz
diff --git a/man/create_traceback.Rd b/man/create_traceback.Rd
new file mode 100644
index 0000000..cd736db
--- /dev/null
+++ b/man/create_traceback.Rd
@@ -0,0 +1,15 @@
+% 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}}}
+}
+\description{
+Generate a traceback from a list of calls.
+}
+\keyword{internal}
diff --git a/man/evaluate.Rd b/man/evaluate.Rd
new file mode 100644
index 0000000..5f6d063
--- /dev/null
+++ b/man/evaluate.Rd
@@ -0,0 +1,52 @@
+% 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.}
+
+\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}} that
+processes the output from the evaluation. The default simply prints the
+visible return values.}
+
+\item{filename}{string overrriding the \code{\link[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}}, \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.
+}
diff --git a/man/flush_console.Rd b/man/flush_console.Rd
new file mode 100644
index 0000000..7b86cc7
--- /dev/null
+++ b/man/flush_console.Rd
@@ -0,0 +1,20 @@
+% 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{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).
+}
diff --git a/man/inject_funs.Rd b/man/inject_funs.Rd
new file mode 100644
index 0000000..ce0bed8
--- /dev/null
+++ b/man/inject_funs.Rd
@@ -0,0 +1,34 @@
+% 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{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}
diff --git a/man/is.message.Rd b/man/is.message.Rd
new file mode 100644
index 0000000..b458f38
--- /dev/null
+++ b/man/is.message.Rd
@@ -0,0 +1,26 @@
+% Please edit documentation in R/output.r
+\name{is.message}
+\alias{is.error}
+\alias{is.message}
+\alias{is.recordedplot}
+\alias{is.source}
+\alias{is.value}
+\alias{is.warning}
+\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}
diff --git a/man/line_prompt.Rd b/man/line_prompt.Rd
new file mode 100644
index 0000000..94e8b2b
--- /dev/null
+++ b/man/line_prompt.Rd
@@ -0,0 +1,21 @@
+% 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}
diff --git a/man/new_output_handler.Rd b/man/new_output_handler.Rd
new file mode 100644
index 0000000..f171fb3
--- /dev/null
+++ b/man/new_output_handler.Rd
@@ -0,0 +1,47 @@
+% 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}}.}
+
+\item{message}{Function to handle \code{\link{message}} output.}
+
+\item{warning}{Function to handle \code{\link{warning}} output.}
+
+\item{error}{Function to handle \code{\link{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}},
+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.
+}
diff --git a/man/parse_all.Rd b/man/parse_all.Rd
new file mode 100644
index 0000000..91240e2
--- /dev/null
+++ b/man/parse_all.Rd
@@ -0,0 +1,24 @@
+% 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}
+
+\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.
+}
diff --git a/man/replay.Rd b/man/replay.Rd
new file mode 100644
index 0000000..9735dcd
--- /dev/null
+++ b/man/replay.Rd
@@ -0,0 +1,22 @@
+% 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}}}
+}
+\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"))))
+}
+}
diff --git a/man/set_hooks.Rd b/man/set_hooks.Rd
new file mode 100644
index 0000000..6751e67
--- /dev/null
+++ b/man/set_hooks.Rd
@@ -0,0 +1,25 @@
+% 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}} 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}
diff --git a/man/try_capture_stack.Rd b/man/try_capture_stack.Rd
new file mode 100644
index 0000000..3324a20
--- /dev/null
+++ b/man/try_capture_stack.Rd
@@ -0,0 +1,17 @@
+% 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}} that also captures the call
+stack if an error occurs.
+}
+\keyword{internal}
diff --git a/man/watchout.Rd b/man/watchout.Rd
new file mode 100644
index 0000000..77a3156
--- /dev/null
+++ b/man/watchout.Rd
@@ -0,0 +1,19 @@
+% 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}
diff --git a/tests/test-all.R b/tests/test-all.R
new file mode 100644
index 0000000..36cf9cc
--- /dev/null
+++ b/tests/test-all.R
@@ -0,0 +1,3 @@
+library(evaluate)
+
+if (require("testthat", quietly = TRUE)) test_check("evaluate")
diff --git a/tests/test-parse.R b/tests/test-parse.R
new file mode 100644
index 0000000..ccae383
--- /dev/null
+++ b/tests/test-parse.R
@@ -0,0 +1,4 @@
+library(evaluate)
+
+# this should not signal an error
+evaluate('x <-', stop_on_error = 0)
diff --git a/tests/test-replay.R b/tests/test-replay.R
new file mode 100644
index 0000000..02a8169
--- /dev/null
+++ b/tests/test-replay.R
@@ -0,0 +1,7 @@
+library(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)
diff --git a/tests/testthat/comment.r b/tests/testthat/comment.r
new file mode 100644
index 0000000..ca63e33
--- /dev/null
+++ b/tests/testthat/comment.r
@@ -0,0 +1,2 @@
+# This test case contains no executable code
+# but it shouldn't throw an error
diff --git a/tests/testthat/data.r b/tests/testthat/data.r
new file mode 100644
index 0000000..fd77217
--- /dev/null
+++ b/tests/testthat/data.r
@@ -0,0 +1,2 @@
+data(barley, package = "lattice")
+barley
diff --git a/tests/testthat/error-complex.r b/tests/testthat/error-complex.r
new file mode 100644
index 0000000..7df4d24
--- /dev/null
+++ b/tests/testthat/error-complex.r
@@ -0,0 +1,5 @@
+f <- function() g()
+g <- function() h()
+h <- function() stop("Error")
+
+f()
diff --git a/tests/testthat/error.r b/tests/testthat/error.r
new file mode 100644
index 0000000..cf133e1
--- /dev/null
+++ b/tests/testthat/error.r
@@ -0,0 +1,2 @@
+stop("1")
+2
diff --git a/tests/testthat/example-1.r b/tests/testthat/example-1.r
new file mode 100644
index 0000000..a2a58e0
--- /dev/null
+++ b/tests/testthat/example-1.r
@@ -0,0 +1,22 @@
+# 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
diff --git a/tests/testthat/ggplot-loop.r b/tests/testthat/ggplot-loop.r
new file mode 100644
index 0000000..a39f681
--- /dev/null
+++ b/tests/testthat/ggplot-loop.r
@@ -0,0 +1,6 @@
+suppressPackageStartupMessages(library(ggplot2))
+for (j in 1:2) {
+ # ggplot2 has been loaded previously
+ print(qplot(rnorm(30), runif(30)))
+}
+
diff --git a/tests/testthat/ggplot.r b/tests/testthat/ggplot.r
new file mode 100644
index 0000000..c281463
--- /dev/null
+++ b/tests/testthat/ggplot.r
@@ -0,0 +1,2 @@
+suppressPackageStartupMessages(library(ggplot2))
+qplot(mpg, wt, data = mtcars)
diff --git a/tests/testthat/interleave-1.r b/tests/testthat/interleave-1.r
new file mode 100644
index 0000000..5904273
--- /dev/null
+++ b/tests/testthat/interleave-1.r
@@ -0,0 +1,4 @@
+for (i in 1:2) {
+ cat(i)
+ plot(i)
+}
diff --git a/tests/testthat/interleave-2.r b/tests/testthat/interleave-2.r
new file mode 100644
index 0000000..af03d33
--- /dev/null
+++ b/tests/testthat/interleave-2.r
@@ -0,0 +1,4 @@
+for (i in 1:2) {
+ plot(i)
+ cat(i)
+}
diff --git a/tests/testthat/order.r b/tests/testthat/order.r
new file mode 100644
index 0000000..852dc60
--- /dev/null
+++ b/tests/testthat/order.r
@@ -0,0 +1,16 @@
+cat("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()
+
diff --git a/tests/testthat/parse.r b/tests/testthat/parse.r
new file mode 100644
index 0000000..efc95a5
--- /dev/null
+++ b/tests/testthat/parse.r
@@ -0,0 +1,6 @@
+f <- function() {
+ for (i in 1:3) {
+ plot(rnorm(100))
+ lines(rnorm(100))
+ }
+}
diff --git a/tests/testthat/plot-additions.r b/tests/testthat/plot-additions.r
new file mode 100644
index 0000000..253b6f9
--- /dev/null
+++ b/tests/testthat/plot-additions.r
@@ -0,0 +1,2 @@
+plot(1:10)
+lines(1:10)
diff --git a/tests/testthat/plot-clip.r b/tests/testthat/plot-clip.r
new file mode 100644
index 0000000..1246cef
--- /dev/null
+++ b/tests/testthat/plot-clip.r
@@ -0,0 +1,3 @@
+plot(rnorm(100), rnorm(100))
+clip(-1, 1, -1, 1)
+points(rnorm(100), rnorm(100), col = 'red')
diff --git a/tests/testthat/plot-last-comment.r b/tests/testthat/plot-last-comment.r
new file mode 100644
index 0000000..2bbd435
--- /dev/null
+++ b/tests/testthat/plot-last-comment.r
@@ -0,0 +1,4 @@
+par(mfrow = c(3, 3))
+for (i in 1:7)
+ image(volcano)
+# comment
diff --git a/tests/testthat/plot-loop.r b/tests/testthat/plot-loop.r
new file mode 100644
index 0000000..10342e0
--- /dev/null
+++ b/tests/testthat/plot-loop.r
@@ -0,0 +1,4 @@
+for (i in 1:3) {
+ plot(rnorm(100))
+}
+
diff --git a/tests/testthat/plot-multi-layout.r b/tests/testthat/plot-multi-layout.r
new file mode 100644
index 0000000..41fb3d5
--- /dev/null
+++ b/tests/testthat/plot-multi-layout.r
@@ -0,0 +1,7 @@
+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))
+}
diff --git a/tests/testthat/plot-multi-layout2.r b/tests/testthat/plot-multi-layout2.r
new file mode 100644
index 0000000..20d1280
--- /dev/null
+++ b/tests/testthat/plot-multi-layout2.r
@@ -0,0 +1,9 @@
+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))
+}
diff --git a/tests/testthat/plot-multi-missing.r b/tests/testthat/plot-multi-missing.r
new file mode 100644
index 0000000..402a974
--- /dev/null
+++ b/tests/testthat/plot-multi-missing.r
@@ -0,0 +1,4 @@
+par(mfrow = c(2, 2))
+plot(1)
+plot(2)
+plot(3)
diff --git a/tests/testthat/plot-multi.r b/tests/testthat/plot-multi.r
new file mode 100644
index 0000000..6ab6557
--- /dev/null
+++ b/tests/testthat/plot-multi.r
@@ -0,0 +1,5 @@
+par(mfrow = c(2, 2))
+plot(1)
+plot(2)
+plot(3)
+plot(4)
diff --git a/tests/testthat/plot-new.r b/tests/testthat/plot-new.r
new file mode 100644
index 0000000..7378260
--- /dev/null
+++ b/tests/testthat/plot-new.r
@@ -0,0 +1,5 @@
+plot.new()
+plot(1:10)
+plot.new()
+plot(1:10)
+plot.new()
diff --git a/tests/testthat/plot-par.r b/tests/testthat/plot-par.r
new file mode 100644
index 0000000..ada6643
--- /dev/null
+++ b/tests/testthat/plot-par.r
@@ -0,0 +1,3 @@
+plot(1)
+par(mar = rep(0, 4))
+plot(2)
diff --git a/tests/testthat/plot-par2.r b/tests/testthat/plot-par2.r
new file mode 100644
index 0000000..e56c85c
--- /dev/null
+++ b/tests/testthat/plot-par2.r
@@ -0,0 +1,5 @@
+barplot(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))
+}
diff --git a/tests/testthat/plot-persp.r b/tests/testthat/plot-persp.r
new file mode 100644
index 0000000..fd93053
--- /dev/null
+++ b/tests/testthat/plot-persp.r
@@ -0,0 +1,8 @@
+x <- 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)
+}
diff --git a/tests/testthat/plot-strwidth.r b/tests/testthat/plot-strwidth.r
new file mode 100644
index 0000000..3739b98
--- /dev/null
+++ b/tests/testthat/plot-strwidth.r
@@ -0,0 +1,4 @@
+x <- strwidth('foo', 'inches')
+y <- strheight('foo', 'inches')
+par(mar = c(4, 4, 1, 1))
+plot(1)
diff --git a/tests/testthat/plot.r b/tests/testthat/plot.r
new file mode 100644
index 0000000..e6e140b
--- /dev/null
+++ b/tests/testthat/plot.r
@@ -0,0 +1 @@
+plot(1:10)
diff --git a/tests/testthat/raw-output.r b/tests/testthat/raw-output.r
new file mode 100644
index 0000000..b5a4446
--- /dev/null
+++ b/tests/testthat/raw-output.r
@@ -0,0 +1,4 @@
+rnorm(10)
+x <- list("I'm a list!")
+suppressPackageStartupMessages(library(ggplot2))
+qplot(mpg, wt, data = mtcars)
diff --git a/tests/testthat/test-errors.r b/tests/testthat/test-errors.r
new file mode 100644
index 0000000..b75fd56
--- /dev/null
+++ b/tests/testthat/test-errors.r
@@ -0,0 +1,28 @@
+context("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()")
+})
diff --git a/tests/testthat/test-evaluate.r b/tests/testthat/test-evaluate.r
new file mode 100644
index 0000000..5f4f647
--- /dev/null
+++ b/tests/testthat/test-evaluate.r
@@ -0,0 +1,84 @@
+context("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("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")
+})
diff --git a/tests/testthat/test-graphics.r b/tests/testthat/test-graphics.r
new file mode 100644
index 0000000..57d68db
--- /dev/null
+++ b/tests/testthat/test-graphics.r
@@ -0,0 +1,141 @@
+context("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"))
+})
diff --git a/tests/testthat/test-output-handler.R b/tests/testthat/test-output-handler.R
new file mode 100644
index 0000000..7f759eb
--- /dev/null
+++ b/tests/testthat/test-output-handler.R
@@ -0,0 +1,17 @@
+context("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)
+})
diff --git a/tests/testthat/test-output.r b/tests/testthat/test-output.r
new file mode 100644
index 0000000..1884848
--- /dev/null
+++ b/tests/testthat/test-output.r
@@ -0,0 +1,8 @@
+context("Output")
+
+test_that("open plot windows maintained", {
+ n <- length(dev.list())
+ evaluate(file("plot.r"))
+ expect_that(length(dev.list()), equals(n))
+})
+
diff --git a/tests/testthat/test-parse.r b/tests/testthat/test-parse.r
new file mode 100644
index 0000000..94ab098
--- /dev/null
+++ b/tests/testthat/test-parse.r
@@ -0,0 +1,34 @@
+context("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))
+ })
+
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-evaluate.git
More information about the debian-med-commit
mailing list