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 <[email protected]> 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@R: c( + person("Hadley", "Wickham", role = "aut"), + person("Yihui", "Xie", role = c("cre", "ctb"), email = "[email protected]"), + 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 <[email protected]> +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 <[email protected]> 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 <[email protected]> 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 <[email protected]> Fri, 20 Jun 2014 23:52:57 +0200 - -r-cran-evaluate (0.5.1-1) unstable; urgency=low - - * Initial release (closes: #732364) - - -- Andreas Tille <[email protected]> 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 <[email protected]> -Uploaders: Andreas Tille <[email protected]> -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 <[email protected]> -Upstream-Name: evaluate -Source: https://cran.r-project.org/package=evaluate - -Files: * -Copyright: 2005-2016 Hadley Wickham <[email protected]> -License: GPL-2+ - -Files: debian/* -Copyright: 2013-2016 Andreas Tille <[email protected]> -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 _______________________________________________ debian-med-commit mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/debian-med-commit
