#' @import evaluate
## probably overkill but this is the most robust way I can think of to
## be absolutely sure that the value handler is *always and only* hit when
## for the return value, because evaluate doesn't class or specially
## mark it and it can in principle be any class. It also returns
## unclassed character vectors for captured text
setClass("ev_output", list(value = "ANY"))
setClass("ev_source", contains = "ev_output")
setClass("ev_message", contains = "ev_output")
setClass("ev_text", contains = "ev_output")
setClass("ev_graphics", contains = "ev_output")
setClass("ev_warning", contains = "ev_output")
setClass("ev_error", contains = "ev_output")
setClass("ev_value", contains = "ev_output",
list(visible = "logical"))
make_evhandler = function(source = NULL,
text = NULL,
graphics = NULL,
message = NULL,
warning = NULL,
error = NULL,
value = NULL
) {
x = list()
count = 1
.evfunmaker = function(clname, extrafun = NULL, clear = FALSE) {
function(val, visible) {
if(!is.null(extrafun))
extrafun(val)
if(clear) {
x <<- list()
count <<- 1
}
if(clname == "ev_value")
x[[count]] <<- new(clname, value = val,
visible = visible)
else
x[[count]] <<- new(clname, value = val)
count <<- count + 1
}
}
new_output_handler(
source = .evfunmaker("ev_source", source, clear = TRUE),
text = .evfunmaker("ev_text", text),
graphics = .evfunmaker("ev_graphics", graphics),
message = .evfunmaker("ev_message", message),
warning = .evfunmaker("ev_warning", warning),
error = .evfunmaker("ev_error", error),
value = function(val, visible) {.evfunmaker("ev_value", value)(val, visible); x}
)
}
#' @title Make an 'evaluate'-based evaluation function
#' @description Create an evaluation function appropiate for use with
#' RCacheSuite that uses Wickham's evaluate function as the
#' underlying mechanism
#' @param source An additional source handler to call before the one
#' we use internally, or NULL (default)
#' @param text An additional text handler to call before the one we
#' use internally, or NULL (default)
#' @param graphics An additional graphics handler to call before the
#' one we use internally, or NULL (default)
#' @param message An additional message handler to call before the one
#' we use internally, or NULL (default)
#' @param warning An additional warning handler to call before the one
#' we use internally, or NULL (default)
#' @param error An additional error handler to call before the one we
#' use internally, or NULL (default)
#' @param value An additional value handler to call before the one we
#' use internally, or NULL (default)
#' @return A function which can be used as an evaluator with the
#' RCacheSuite machinery
#' @export
make_evaluate_ef = function(source = NULL,
text = NULL,
graphics = NULL,
message = NULL,
warning = NULL,
error = NULL,
value = NULL
) {
evhandler = make_evhandler(source, text, graphics, message, warning, error, value)
function(code, env, evaled = FALSE, last = FALSE, stop_on_error = 1, ...) {
res = evaluate(code, env, stop_on_error = stop_on_error,
output_handler = evhandler, ...)
## the last element is the value, which with this
## handler is the full list of captured elements
res[[length(res)]]
}
}
#' @export
#' @param stop_on_error integer. Passed to evaluate.
#' @rdname evalhandlers
evaluate_ef = make_evaluate_ef()
setGeneric("handle_ev_out", function(outobj) standardGeneric("handle_ev_out"))
## handling source 'output' is a no-op for now. Could 'echo' it to
## console if we wanted to...
setMethod("handle_ev_out", "ev_source",
function(outobj) NULL)
## for some reason the source output handler isn't working here.
setOldClass("source")
setMethod("handle_ev_out", "source",
function(outobj) NULL)
setMethod("handle_ev_out", "ev_message",
function(outobj) message(outobj@value))
setMethod("handle_ev_out", "ev_warning",
function(outobj) warning(outobj@value))
setMethod("handle_ev_out", "ev_error",
function(outobj) warning(outobj@value))
setMethod("handle_ev_out", "ev_text",
function(outobj) cat(outobj@value))
setMethod("handle_ev_out", "ev_graphics",
function(outobj) redrawPlot(outobj@value))
setMethod("handle_ev_out", "ev_value",
function(outobj) outobj@value)
#' @export
#' @rdname evalhandlers
evaluate_rh = function(val, graphics, env, evaled = FALSE, ...) {
## we ignore the graphics argument because that is handled
## differently by evaluate and we just piggyback that.
##
## no need to worry about recreating assignments here
## evalWithCache takes care of that regardless of
## handler
##
## the value will always be the last one
## that's what we want to return, but recreate all
## the captured side-effects firsti
lapply(head(val, -1), handle_ev_out)
handle_ev_out(tail(val, 1)[[1]])
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.