###########################################################################/**
# @RdocFunction withSink
#
# @title "Evaluate an R expression while temporarily diverting output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{expr}{The R expression to be evaluated.}
# \item{file}{A writable @connection or a @character string naming the
# file to write to.}
# \item{append}{If @TRUE, the diverted output is appended to the file,
# otherwise not.}
# \item{type}{A @character string specifying whether to divert output
# sent to the standard output or the standard error.
# See @see "base::sink" for details.}
# \item{substitute}{If @TRUE, argument \code{expr} is
# \code{\link[base]{substitute}()}:ed, otherwise not.}
# \item{envir}{The @environment in which the expression should be evaluated.}
# }
#
# \value{
# Returns the results of the expression evaluated.
# }
#
# \details{
# Upon exit (also on errors), this function will close the requested
# "sink". If additional sinks (of any type) where also opened during
# the evaluation, those will also be closed with a warning.
# }
#
# @author
#
# @examples "../incl/withSink.Rex"
#
# \seealso{
# Internally, @see "base::sink" is used to divert any output.
# }
#
# @keyword IO
# @keyword programming
#*/###########################################################################
withSink <- function(expr, file, append=FALSE, type=c("output", "message"), substitute=TRUE, envir=parent.frame()) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validate arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'expr':
if (substitute) expr <- substitute(expr)
# Argument 'envir':
if (!is.environment(envir))
throw("Argument 'envir' is not a list: ", class(envir)[1L])
# Argument 'append':
append <- as.logical(append)
# Argument 'type':
type <- match.arg(type)
# Argument 'file':
fileT <- NULL
if (is.null(file)) {
throw("Argument 'file' must be either a connection of a character string: NULL")
} else if (inherits(file, "connection")) {
## info <- summary(con)
## if (!info[["can write"]]) {
## throw("Argument 'file' is a connection but not writable: ", info[["description"]])
## }
} else {
file <- as.character(file)
file <- Arguments$getWritablePathname(file)
# WORKAROUND:
# sink(..., type="message") does not allow to sink to an unopen file.
if (type == "message") {
fileT <- file(file, open=ifelse(append, "wt", "w"))
on.exit({
if (!is.null(fileT)) close(fileT)
})
file <- fileT
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Record entry sinks
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
idx0 <- list()
for (tt in c("message", "output")) {
idx0[[tt]] <- sink.number(type=tt)
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Divert output
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sink(file=file, append=append, type=type)
# Record index of the opened sink
openedIdx <- sink.number(type=type)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Upon exit, close the requested sink and all other added sinks
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
on.exit({
# Close all opened sinks, including those opened while
# evaluating 'expr'.
maxTries <- 10L
for (tt in c("message", "output")) {
idx <- sink.number(type=tt)
count <- 0L
while (idx > idx0[[tt]]) {
count <- count + 1L
if (count > maxTries) {
throw(sprintf("Failed to close temporarily opened sink %d of type '%s' after trying %d times", idx, tt, maxTries))
}
# Warn if sink was opened by 'expr'
if (idx != openedIdx || tt != type) {
warning(sprintf("Closing unclosed sink #%d of type '%s' that was opened during evaluation.", idx, tt))
}
sink(file=NULL, type=tt)
# Currently opened sink?
idx <- sink.number(type=tt)
}
} # for (tt ...)
# Assert that exit sinks are the same as the entry ones
for (tt in c("message", "output")) {
idx <- sink.number(type=tt)
if (idx != idx0[[tt]]) {
msg <- sprintf("Failed to close temporarily opened sink #%d of type '%s'", idx, tt)
if (tt == "message") {
# Throwing an error when 'message':s are diverted may
# pass unnoticed. At least report the prompt, if it exists.
if (interactive()) {
readline(sprintf("ERROR: %s. Press ENTER to continue...", msg))
}
}
throw(msg)
}
}
if (!is.null(fileT)) {
close(fileT)
fileT <- NULL
}
}, add=FALSE) # on.exit()
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Evaluate expression
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
eval(expr, envir = envir, enclos = baseenv())
} # withSink()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.