#' Find the environment which defines a name.
#'
#' `locate` starts at a given environment, and searches enclosing
#' environments for a name. It returns the first enclosing environment
#' which defines `sym`.
#' @param sym A name. For `locate` the argument is used literally. For
#' `locate_` it should be a [name] or list of names.
#' @param env Which environment to begin searching from.
#' @param mode Either `"any"` or `"function"`. `"any"` finds the
#' lowest enclosing environment which gives any definiton for `sym`.
#' `"function"` searches for an environment which defines `sym` as a
#' function. This may force lazy arguments in the process, in the
#' same way as [get].
#' @param ... Further arguments passed to methods.
#' @return An environment object which defines `sym`, if one is found.
#' @note To locate where `...` is bound, you can wrap it in parens, as
#' `locate( (...) )`.
#' @examples
#' # Here is how to implement R's `<<-` operator, using `locate_`:
#' `%<<-%` <- function(lval, rval) {
#' lval_ <- arg(lval)
#' name <- expr(lval_)
#' target.env <- locate_(name, parent.env(env(lval_)))
#' assign(as.character(name), rval, envir=target.env)
#' }
#'
#' x <- "not this one"
#' local({
#' x <- "this one"
#' local({
#' x <- "not this one either"
#' x %<<-% "this works like builtin <<-"
#' })
#' print(x)
#' })
#' print(x)
#' @export
locate <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any",
...) {
sym_ <- arg_expr_(quote(sym), environment())
locate_(sym = sym_, env = env, mode = mode, ...)
}
#' @description
#' `locate_` is the normally evaluating method; `locate(x)` is
#' equivalent to `locate_(quo(x))` or `locate_(quote(x), environment())`.
#' @rdname locate
#' @export
locate_ <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any", ...) {
# Default arguments vs. s3 dispatch pitfall!
# because UseMethod is going to force "sym",
# which would make output of arg_env_ invalid,
# I need to force "env" first...
force(env)
# and dispatch from a call with no default args
locate.dispatch(sym=sym, env=env, mode=mode, ...)
}
locate.dispatch <- function(sym, env, mode, ...) {
UseMethod("locate_")
}
#' @return
#' If `sym` is a list (of [name]s) or a [dots] object, `locate_(sym)`
#' returns a list.
#' @rdname locate
#' @export
locate_.list <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any", ...) {
force(env)
lapply(sym, locate_, env=env, mode=mode, ...)
}
#' @description
#' When `sym` is a [quotation] or [dots], any `env` argument is ignored.
#' @rdname locate
#' @export
locate_.quotation <- function(sym,
env = "ignored",
mode = "any",
...) {
locate_(sym=expr(sym), env=env(sym), mode = mode, ...)
}
#' @rdname locate
#' @note If you use a literal character argument, as in `locate("x",
#' environment())`, you must also provide the environment argument
#' explicitly; `locate("x")` won't work in compiled
#' functions. However using a literal name like `locate(x)` will
#' work OK. See note under [arg].
#' @export
locate_.character <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any",
...) {
if (length(sym) == 1) {
locate_.name(sym=as.name(sym), env=env, mode=mode, ...)
} else {
# The "intuitive" thing here might be to return a list:
# lapply(FUN=locate_.character, x, env=env, mode=mode, ...)
# However this would not be type-stable (is "x" a vector of length
# 1 or a singleton?)
stop("use locate_.list for character vectors")
}
}
# not exported.
`locate_.call` <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any",
...) {
locate_(sym[[2]], env=env, mode=mode)
}
#' @export
#' @rdname locate
`locate_.(` <- `locate_.call`
#' @export
#' @rdname locate
locate_.dots <- function(sym,
env = "ignored",
mode = "any",
...) {
structure(lapply(sym, locate_, ...), class="dots")
}
#' @rdname locate
#' @param ifnotfound What is returned if the symbol is not found. By
#' default an exception is raised.
#' @useDynLib nseval _locate
#' @export
locate_.name <- function(sym,
env = arg_env_(quote(sym), environment()),
mode = "any",
ifnotfound = stop("Binding ", deparse(sym), " not found")) {
.Call("_locate",
sym,
env,
switch(mode,
"any" = FALSE,
"function" = TRUE)
) %||% ifnotfound
}
#' Unwrap variable references.
#'
#' Given an un[forced] [quotation] whose expression is a bare variable
#' name, `unwrap` follows the variable reference, and returns a
#' quotation. When the argument is forced or has a nontrivial
#' expression `unwrap` has no effect.
#'
#' There are two good use cases for `unwrap(x, recursive=TRUE)`. One
#' is to derive plot labels (the most inoccuous use of
#' metaprogramming). Another is to check for missingness (this is what
#' R's [missing] and does as well).
#'
#' Using `unwrap(x, recursive=TRUE)` in other situations can get you
#' into confusing situations -- effectively you are changing the
#' behavior of a parent function that may be an unknown number of
#' levels up the stack, possibly turning a standard-evaluating
#' function into nonstandard-evaluating function. So recursive
#' unerapping is not the default behavior.
#' @export
#' @param x a [quotation] to unwrap.
#' @param recursive Default `FALSE` unwraps exactly once. If
#' `TRUE`, unwrap as far as possible (until a forced promise or
#' nontrivial expression is found.)
#' @return The [quotation] method returns a [quotation].
#' @examples
#' # different levels of unwrapping:
#' f <- function(x) { g(x) }
#' g <- function(y) { h(y) }
#' h <- function(z) {
#' print(arg(z))
#' print(unwrap(quo(z)))
#' print(unwrap(unwrap(quo(z))))
#' print(unwrap(quo(z), recursive=TRUE))
#' }
#'
#' w <- 5
#' f(w)
unwrap <- function(x, recursive=FALSE) {
UseMethod("unwrap")
}
#' @export
unwrap.quotation <- function(x, recursive=FALSE) {
.Call("_unwrap_quotation", x, recursive)
}
#' @export
#' @rdname unwrap
#' @return The [dots] method returns a dots object with each quotation unwrapped.
unwrap.dots <- function(x, recursive=FALSE) {
structure(lapply(x, function(x) .Call("_unwrap_quotation", x, recursive)),
class="dots")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.