#' Function Returning Nothing
#'
#' Return nothing via \code{\link[base]{invisible}()}.
#'
#' @param x R object to be returned invisibly.
#'
#' @seealso \code{\link[base]{invisible}}
#'
#' @examples
#' nop()
#'
#' @export
nop <- function(x=NULL)
{
return (invisible(x))
}
#' Resolve Triple-Dot (...) Argument inside Function Body
#'
#' Breaks up a triple-dot (\code{...}) argument of a function call into more accessible objects.
#'
#' @param ... A \code{...} argument composed of all non-formal arguments of a function call, where \code{...} must be a formal parameter of the function.
#' @param evaluate Logical: return \code{...} object not only as a list of symbols, but also a list of those symbols expanded by \code{eval()}.
#'
#' @return A list of objects mostly related to the non-formal arguments of a function call:
#' \item{calling_function}{The name (if available) of the calling function.}
#' \item{current_function}{The name (if available) of the current function.}
#' \item{current_formals}{A character vector of the names of the formal parameters of the current function.}
#' \item{arguments}{A list of objects, as symbols, contained in \code{...}, with named elements for named arguments.}
#' \item{evaluated}{A list of objects contained in \code{...}, with named elements for named arguments.}
#' \item{as_character}{The objects contained in \code{...} coerced into a character vector, with named elements for named arguments.}
#' \item{named_dots}{The names of the arguments contained in \code{...}, with blank strings for unnamed arguments.}
#' \item{all_named_args}{All named arguments of the function call, including formal arguments.}
#'
#' @examples
#' x <- function(a, b, ...) browser()
#' x(a=666, fish="trout", frog=10, bob=3.14, TRUE, "ouch", FALSE)
#' dots <- get_dots(...)
#' dots
#'
#' @export
get_dots <- function(..., evaluate=FALSE)
{
caller <- sys.function(which=-1L)
formalArguments <- NULL
if (!is.null(caller)) {
callerName <- as.list(sys.call(-1L))[[1L]]
formalArguments <- names(formals(caller))
}
#unevaluated <- substitute(...()) # List of '...' name-value pairs.
unevaluated <- eval(substitute(alist(...))) # Also: match.call(expand.dots=FALSE)$`...`; however,...
## ... the act of passing the dots into 'get_dots()' turns some unevaluated variables into ..1, ..2, etc. (non-atomic types?).
## https://stackoverflow.com/questions/13353847/how-to-expand-an-ellipsis-argument-without-evaluating-it-in-r
dotsAsCharacter <- unlist(sapply(unevaluated, deparse, simplify=TRUE))
dotsNames <- names(dotsAsCharacter)
if (is.null(dotsNames))
dotsNames <- rep("", length(dotsAsCharacter))
rv <- list()
if (!is.null(sys.call(-2L)))
rv$calling_function <- as.list(sys.call(-2L))[[1L]]
rv$current_function <- callerName
rv$current_formals <- formalArguments
#rv$... <- environment()$`...`
rv$arguments <- as.list(unevaluated)
if (evaluate)
rv$evaluated <- list(...)
rv$as_character <- dotsAsCharacter
rv$named_dots <- dotsNames
whichDots <- which(formalArguments == "...")
if (length(whichDots) == 0L)
whichDots <- ifelse(length(formalArguments) == 0L, 1L, length(formalArguments))
temp <- append(formalArguments, dotsNames[dotsNames != ""], after=whichDots)
rv$all_named_args <- temp[temp != "..."]
return (rv)
}
#' @export
args_list <- function(which=-1L)
{
a <- NULL
sysFun <- sys.function(which)
if (!is.null(sysFun)) {
formalArguments <- formals(sysFun)
formalArguments$... <- NULL # Remove dots.
actualArguments <- as.list(match.call(sysFun, call=sys.call(which)))[-1L]
a <- modifyList(formalArguments, actualArguments)
}
a
}
make_current_timestamp <- function(fmt="%Y-%m-%d", use_seconds=FALSE, seconds_sep='+')
{
sysTime <- Sys.time()
timestamp <- format(sysTime, fmt)
if (use_seconds)
timestamp <- paste(timestamp, sprintf("%05d", lubridate::period_to_seconds(hms(format(Sys.time(), "%H:%M:%S")))), sep=seconds_sep)
return (timestamp)
}
#' Evaluate Function inside an Environment and Extract and Save Any Useful Variables from Its Body
#'
#' Puts a function's body and its arguments into an environment for evaluation, and afterwards allows extraction of any variables from the body, not just a return value.
#'
#' @param fun The function to be evaluated.
#' @param ... Arguments to be passed into \code{fun}.
#' @param arguments A list of additional arguments for passing into \code{fun}; can be used e.g. when the formal arguments of \code{fun} conflict with those of the current function.
#' @param envir Environment where \code{variables} will be copied after \code{fun} has been evaluated. For \code{action = "save"}, also names what variables in the evaluation environment will be \code{save()}d to an external file.
#' @param file_path For \code{action = c("save", "load")}, the path to the file to which the \code{variables} in \code{envir} will be written, or from which objects will be extracted to \code{envir}. If \code{timestamp = TRUE}, the file name provides a base name to which a timestamp is appended.
#' @param variables A character string naming variables among the arguments to, or in the body of, \code{fun} that will be extracted from the evaluation environment. If any of the strings are named, those names with carry the variables' values in \code{envir}.
#' @param copy_args Logical: Should all named arguments to \code{fun} also be extracted from the evaluation environment (and for \code{action = "save"}, saved)?
#' @param timestamp A logical value deciding whether a current timestamp (default format \code{\%Y-\%m-\%d+[seconds after midnight]}) should be appended to the base file name given as part of \code{file_path}.
#' @param action A character string denoting the purpose of calling \code{cordon()} in the first place:
#' \tabular{ll}{
#' run \tab Evaluate \code{fun} and extract variables, but don't load or save them. \cr
#' save \tab Evaluate \code{fun}, extract variables, and save them to an external file. \cr
#' load \tab Load saved data from \code{file_path}. If \code{timestamp = TRUE}, load the most recent version according to the timestamped file name.\cr
#' skip \tab Do nothing, i.e. prevent \code{fun} from being evaluated at all. \cr
#' archive \tab Not implemented.
#' }
#'
#' @return The environment in which the body of \code{fun} was evaluated.
#'
#' @examples
#' \dontrun{
#' f <- function(x="frog", ...) { args <- get_dots(...)$arguments; nines <- args$beast + 333; bite <- args$bite; return (nop()) }
#' e <- cordon(f, bite="me", 3.14, beast=666, TRUE, envir=globalenv(), variables="nines")
#' get("nines", envir=globalenv())
#' e$bite
#' ls(e, all=TRUE)
#' }
#'
#' @export
cordon <- function(fun, ..., arguments=list(), envir=environment(), file_path=NULL, variables=NULL, copy_args=FALSE, timestamp=TRUE, timestamp...=list(), action=c("run", "save", "load", "skip", "archive"), evaluate_dots=TRUE, create_path_dir=TRUE, verbose=TRUE)
{
action <- match.arg(action)
run_ <- action == "run" || action == "save" || action == "load"
save_ <- action == "save"
load_ <- action == "load"
archive_ <- action == "archive"
timestampArgs <- list(
use_seconds = TRUE,
seconds_sep = '+'
)
timestampArgs <- modifyList(timestampArgs, timestamp...)
if (archive_) {
if (is.null(file_path))
stop("Archive file path must be specified.")
if (!(file.info(file_path)$isdir)) file_path <- dirname(file_path)
if (verbose) cat("Loading archive file \"" %_% filePath %_% "\".... ")
archive("load", file_path) # 'archive()' not implemented yet.
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
else if (load_) {
filePath <- file_path
if (timestamp) {
## Get list of files in directory of 'file_path'.
fileExt <- file_ext(file_path)
dirName <- dirname(file_path)
timestampRe <- "_\\d{4}-\\d{2}-\\d{2}(?:\\" %_% timestampArgs$seconds_sep %_% "\\d{5})?"
## Find all versions of the file according to their timestamp extensions.
filePaths <- sort(grep("^.*?" %_% timestampRe %_% "\\." %_% fileExt %_% "$", list.files(dirName, pattern="^" %_% Hmisc::escapeRegex(file_path_sans_ext(basename(file_path))) %_% timestampRe %_% "\\." %_% fileExt %_% "$", full.names=FALSE), perl=TRUE, value=TRUE), decreasing=TRUE)
filePaths <- paste(dirName, filePaths, sep="/")
if (length(filePaths) > 0L)
## Use the most recent version of the file according to its timestamp extension.
filePath <- filePaths[1L]
}
if (verbose) cat("Loading data file \"" %_% filePath %_% "\".... ")
load(file=filePath, envir=envir)
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
else if (run_) {
evalEnv <- new.env()
## Add default arguments of 'fun' to argument list.
argList <- as.list(formals(fun))
hasDots <- FALSE
if (!is.null(argList[["..."]])) hasDots <- TRUE
argList[["..."]] <- NULL
dots <- get_dots(..., evaluate=evaluate_dots)
## Add '...' arguments to argument list.
dotsArguments <- dots$arguments
if (evaluate_dots) dotsArguments <- dots$evaluated
argList <- modifyList(argList, dotsArguments[dots$named_dots != ""]) # Replace duplicate named arguments with those from '...' and add new named arguments.
argList <- c(argList, dotsArguments[dots$named_dots == ""]) # Tack on unnamed arguments from '...'.
## Add 'arguments' to 'argList'.
argList <- modifyList(argList, arguments[names(arguments) != ""]) # Replace duplicate named arguments with those from 'arguments' and add new named arguments.
argList <- c(argList, arguments[names(arguments) == ""]) # Tack on unnamed arguments from 'arguments'.
temp <- fun
body(temp) <- as.call(c(as.name("{"), expression(return (environment()))))
## Return environment containing complete set of new arguments, including '...', for 'fun()'.
evalEnv <- do.call(temp, argList)
## Evaluate the body of 'fun()' in the environment created.
eval(body(fun), envir=evalEnv)
## Pick out the variables to keep.
if (is.null(variables))
variables <- setdiff(ls(evalEnv, all=TRUE), c(names(formals(fun))))
## N.B. Not used yet.
variableNames <- variables
if (!is.null(names(variables)))
variableNames[names(variables) != ""] <- names(variables)[names(variables) != ""]
argEnv <- as.environment(argList[names(argList) != ""]) # Can only save named arguments.
if (!is.null(file_path)) {
if (save_) {
filePath <- file_path
if (create_path_dir && !dir.exists(dirname(file_path)))
dir.create(dirname(file_path), recursive = TRUE)
if (timestamp)
filePath <- paste(file_path_sans_ext(file_path), do.call("make_current_timestamp", timestampArgs), sep='_') %_% '.' %_% file_ext(file_path)
if (verbose) cat("Saving data file \"" %_% filePath %_% "\".... ")
save(list=variables, file=filePath, envir=evalEnv)
if (copy_args)
append_rda(filePath, objects=ls(argEnv, all=TRUE), envir=argEnv)
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
}
for (v in variables)
assign(v, get(v, envir=evalEnv), envir=envir)
if (copy_args) {
for (a in ls(argEnv, all=TRUE))
assign(a, get(a, envir=argEnv), envir=envir)
}
return (invisible(evalEnv))
}
}
#' @export
cordon2 <- function(fun, ..., arguments=list(), envir=environment(), file_path=NULL, variables=NULL, copy_args=FALSE, timestamp=TRUE, timestamp...=list(), action=c("run", "save", "load", "skip", "archive"), evaluate_dots=FALSE, verbose=TRUE)
{
action <- match.arg(action)
run_ <- action == "run" || action == "save" || action == "load"
save_ <- action == "save"
load_ <- action == "load"
archive_ <- action == "archive"
timestampArgs <- list(
use_seconds = TRUE,
seconds_sep = '+'
)
timestampArgs <- modifyList(timestampArgs, timestamp...)
if (archive_) {
if (is.null(file_path))
stop("Archive file path must be specified.")
if (!(file.info(file_path)$isdir)) file_path <- dirname(file_path)
if (verbose) cat("Loading archive file \"" %_% filePath %_% "\".... ")
archive("load", file_path) # 'archive()' not implemented yet.
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
else if (load_) {
filePath <- file_path
if (timestamp) {
## Get list of files in directory of 'file_path'.
fileExt <- file_ext(file_path)
dirName <- dirname(file_path)
timestampRe <- "_\\d{4}-\\d{2}-\\d{2}(?:\\" %_% timestampArgs$seconds_sep %_% "\\d{5})?"
## Find all versions of the file according to their timestamp extensions.
filePaths <- sort(grep("^.*?" %_% timestampRe %_% "\\." %_% fileExt %_% "$", list.files(dirName, pattern="^" %_% file_path_sans_ext(basename(file_path)) %_% timestampRe %_% "\\." %_% fileExt %_% "$", full.names=FALSE), perl=TRUE, value=TRUE), decreasing=TRUE)
filePaths <- paste(dirName, filePaths, sep="/")
if (length(filePaths) > 0L)
## Use the most recent version of the file according to its timestamp extension.
filePath <- filePaths[1L]
}
if (verbose) cat("Loading data file \"" %_% filePath %_% "\".... ")
load(file=filePath, envir=envir)
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
else if (run_) {
evalEnv <- new.env()
dots <- get_dots(..., evaluate=evaluate_dots)
## Add '...' arguments to argument list.
if (!evaluate_dots)
dotsArguments <- dots$arguments
else
dotsArguments <- dots$evaluated
argList <- modifyList(dotsArguments, arguments[names(arguments) != ""]) # Replace duplicate named arguments with those from 'arguments' and add new named arguments.
argList <- c(argList, arguments[names(arguments) == ""]) # Tack on unnamed arguments from 'arguments'.
tempFun <- fun
body(tempFun) <- as.call(c(as.name("{"), expression(return (environment()))))
## Return environment containing complete set of new arguments, including '...', for 'fun()'.
evalEnv <- do.call(tempFun, argList)
## Evaluate the body of 'fun()' in the environment created.
eval(body(fun), envir=evalEnv)
## Pick out the variables to keep.
if (is.null(variables))
variables <- setdiff(ls(evalEnv, all=TRUE), c(names(formals(fun))))
argEnv <- as.environment(argList[names(argList) != ""]) # Can only save named arguments.
if (!is.null(file_path)) {
if (save_) {
filePath <- file_path
if (timestamp)
filePath <- paste(file_path_sans_ext(file_path), do.call("make_current_timestamp", timestampArgs), sep='_') %_% '.' %_% file_ext(file_path)
if (verbose) cat("Saving data file \"" %_% filePath %_% "\".... ")
save(list=variables, file=filePath, envir=evalEnv)
if (copy_args)
append_rda(filePath, objects=ls(argEnv, all=TRUE), envir=argEnv)
if (verbose) { cat("Done.", fill=TRUE); flush.console() }
}
}
for (v in variables)
assign(v, get(v, envir=evalEnv), envir=envir)
if (copy_args) {
for (a in ls(argEnv, all=TRUE))
assign(a, get(a, envir=argEnv), envir=envir)
}
return (invisible(evalEnv))
}
}
#' @export
eval_js = function(..., envir=parent.frame(), enclos=if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv())
{
dots <- get_dots(..., evaluate=TRUE)
expr <- unlist(dots$evaluated)
if (is.list(expr)) {
if (is.function(expr[[1L]])) # If first '...' argument is a function, execute it with other '...' arguments as its own.
return (do.call(expr[[1L]], tail(expr, -1L)))
for (i in expr) {
if (is.expression(i) || is.language(i)) {
return (eval(i, envir, enclos)) # Returns only the first expression found.
}
}
}
expr <- paste(expr, collapse=' ')
if (typeof(expr) != "character")
return (expr)
expr <- parse(text=expr)
eval(expr, envir, enclos)
}
## Return all combinations of successive vectors in their given order.
#' @export
combine_groups <- function(x, combine_fun=base::paste, ...)
{
comb_factory <- function(...)
{
## Make sure that '...' comes from 'comb_factory()' by NOT giving it as a formal argument of the following function:
function(x, y) { as.vector(t(outer(x, y, FUN=combine_fun, ...))) }
}
comb <- comb_factory(...)
Reduce(comb, x)
}
## usage:
# colParts <- list(c("Global", "NH", "SH", "Tropics", "NH Extratropic", "SH Extratropic", "NH Polar", "SH Polar"), c("", " Land", " Ocean"))
# combine_groups(colParts, sep="")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.