In the book, the exercise is on page 10/23 of the Environments chapter, after section Iteration vs. Recursion. It is
Modify where() to find all environments that contain a binding for
name.
Here, where() is from the pryr package. First of all, to be sure I understand what is asked: Say I have the name mean. This could refer to:
> mean
function (x, ...)
UseMethod("mean")
<bytecode: 0x2234b58>
<environment: namespace:base>
But also, say I assign a value to a variable of the same name:
> mean <- 3
> mean
[1] 3
So, now (please correct me if I'm wrong), the former mean is bound by the baseenv() whereas the latter is bound by globalenv(). Correct?
> ls(as.environment(globalenv()))
[1] "mean"
> which(ls(as.environment(baseenv()))=="mean")
[1] 671
So I wrote:
where2 <- function(k, name, env) {
stopifnot(is.character(name), length(name) == 1)
# Why does this only work when calling 'where' from
# the 'pryr' package?
# env <- to_env(env)
# Hopefully the same as 'to_env'.
# env <- as.environment(env)
# Successful case.
if(exists(name, env, inherits=FALSE)) {
k <- list(k, env)
where2(k, name, parent.env(env))
}
# Base case or search one level up.
if(identical(env, emptyenv())) {
stop("Can't find ", name, call.=FALSE)
} else {
where2(k, name, parent.env(env))
}
}
inspired by the where function from the pryr package.
I was hoping I could now do (at the R prompt):
> source("./where2.r")
> mean <- 3
> k <- list()
> where2(k, "mean", parent.frame())
Error: Can't find mean
and get a list containint the base- and global environments.
What should I do differently and how?
This function solves the problem:
where_2 = function (name, env = parent.frame(), env_list = list())
{
stopifnot(is.character(name), length(name) == 1)
env <- as.environment(env)
if (identical(env, emptyenv())) {
if (length(env_list) == 0) {
stop("Can't find ", name, call.=FALSE)
} else {
return(env_list)
}
} else if (exists(name, env, inherits = FALSE)) {
env_list = append(env_list, env)
where_2(name, parent.env(env), env_list = env_list)
}
else {
where_2(name, parent.env(env), env_list = env_list)
}
}
Related
I want to override the behavior of the dollar operator, so that if I have
x <- new.env()
x$foo <- 3
will e.g. call something. I tried to look for possible functions such as $, but my knowledge of the internals is not good enough.
I tried this:
`$` <- function(a, b) {
res <- .Primitive("$")(a, b);
print(res);
if(is.null(res)) { print("null!") };
return(res)
}
It kind of seem to work, but:
> x$foobar
NULL
[1] "null!"
NULL
> x$foobar <- 3
> x$foobar
NULL
[1] "null!"
NULL
>
So it seems to stay null despite the override.
Normal behavior of R's environments:
myenv <- new.env(parent = emptyenv())
myenv$foo <- 3
class(myenv)
# [1] "environment"
myenv$foo
# [1] 3
myenv$foobar
# NULL
Let's define a super-class (I'll name it environment2, feel free to be creative here) and override $ for that class:
class(myenv) <- c("environment2", "environment")
`$.environment2` <- function(x, name) {
stopifnot(name %in% names(x))
NextMethod()
}
myenv$foo
# [1] 3
myenv$foobar
# Error in `$.environment2`(myenv, foobar) : name %in% names(x) is not TRUE
You can easily clean up that error if you'd like, either using an if statement with stop, or (in R-4 or newer) naming the conditions in stopifnot.
`$.environment2` <- function(x, name) {
if (!name %in% names(x)) stop("something meaningful", call. = FALSE)
NextMethod()
}
`$.environment2` <- function(x, name) {
stopifnot(
"something meaningful" = name %in% names(x)
)
NextMethod()
}
### both render
myenv$foobar
# Error in `$.environment2`(myenv, foobar) : something meaningful
They are relatively equivalent, but with if/stop, you can reduce the error context:
`$.environment2` <- function(x, name) {
if (!name %in% names(x)) stop("something meaningful", call. = FALSE)
NextMethod()
}
myenv$foobar
# Error: something meaningful
I'm currently doing Advanced-R, 18 Expressions.
Topic is about 18.5.2 Finding all variables created by assignment, but the given code doesn't work in the case of pairlist.
I followed all the given codes, but the results are not quite same with what I expect.
To begin with, in order to figure out what the type of the input, expr_type() is needed.
expr_type <- function(x) {
if(rlang::is_syntactic_literal(x)) {
"constant"
} else if (is.symbol(x)) {
"symbol"
} else if (is.call(x)) {
"call"
} else if (is.pairlist(x)) {
"pairlist"
} else {
typeof(x)
}
}
And the author, hadley, coupled this with a wrapper around the switch function.
switch_expr <- function(x, ...) {
switch(expr_type(x),
...,
stop("Don't know how to handle type ", typeof(x), call. = FALSE)
)
}
In the case of base cases, symbol and constant, is trivial because neither represents assignment.
find_assign_rec <- function(x) {
switch_expr(x,
constant = ,
symbol = character()
)
}
In the case of recursive cases, especially for pairlists, he suggested
flat_map_chr <- function(.x, .f, ...) {
purrr::flatten_chr(purrr::map(.x, .f, ...))
}
So summing up, it follows
find_assign_rec <- function(x) {
switch_expr(x,
# Base cases
constant = ,
symbol = character(),
# Recursive cases
pairlist = flat_map_chr(as.list(x), find_assign_rec),
)
}
find_assign <- function(x) find_assign_rec(enexpr(x))
Then, I expect in the case of pl <- pairlist(x = 1, y = 2), find_assign(pl) should return #> [1] "x" "y"
But the actual output is character(0)
What is wrong with this?
Surely this is possible, but I can't seem to find how to do it:
I'd like to have a default of a function input, but override the default and get() a variable from the global environment if it exists in the global environment. If it doesn't exist in the global environment, take the default of the function, with any setting in the function being top level and overriding them all.
Ideally it would work like this made-up non-working function:
###Does not work, desired example
myfunc <- function(x=30){
if(exists.in.global.env(x)){x <- get(x)}
###Top level is tough
if(x.is.defined.as.function.input=TRUE ????){x <- x.defined.as.input}
}else{ x <- 30}
return(x)
}
So that if I do:
myfunc()
[1] 30
But if I create x I want it to override the default x=30 of the function and take the global environment value instead:
x <- 100
myfunc()
[1] 100
But if I have x defined inside the function, I'd like that to be top level, i.e. override everything else even if x is defined globally:
x <- 100
myfunc(x=300)
[1] 300
Thanks in advance!
You can modify your function to check if x exists in the .GlobalEnv and get it from there if it does, otherwise return the default value.
myfunc <- function(x = 30) {
if ("x" %in% ls(envir = .GlobalEnv)) {
get("x", envir = .GlobalEnv)
} else {
x
}
}
So if "x" %in% ls(envir = .GlobalEnv) is FALSE it would return
myfunc()
[1] 30
If x is found it would return it. if x <- 100:
myfunc()
[1] 100
Edit after comment
If you want to make sure to only return x from the global environment if x is not specified as an argument to myfunc, you can use missing(). It returns TRUE if x was not passed and FALSE if it was:
myfunc <- function(x = 30) {
if ("x" %in% ls(envir = .GlobalEnv) & missing(x)) {
get("x", envir = .GlobalEnv)
} else {
x
}
}
So for your example:
x <- 100
myfunc(x=300)
[1] 300
The simplest method would be to set an appropriate default argument:
myfunc <- function(x=get("x", globalenv())
{
x
}
> x <- 100
> f()
[1] 100
> f(30)
[1] 30
> rm(x)
> f()
Error in get("x", globalenv()) : object 'x' not found
I know about methods(), which returns all methods for a given class. Suppose I have x and I want to know what method will be called when I call foo(x). Is there a oneliner or package that will do this?
The shortest I can think of is:
sapply(class(x), function(y) try(getS3method('foo', y), silent = TRUE))
and then to check the class of the results... but is there not a builtin for this?
Update
The full one liner would be:
fm <- function (x, method) {
cls <- c(class(x), 'default')
results <- lapply(cls, function(y) try(getS3method(method, y), silent = TRUE))
Find(function (x) class(x) != 'try-error', results)
}
This will work with most things but be aware that it might fail with some complex objects. For example, according to ?S3Methods, calling foo on matrix(1:4, 2, 2) would try foo.matrix, then foo.numeric, then foo.default; whereas this code will just look for foo.matrix and foo.default.
findMethod defined below is not a one-liner but its body has only 4 lines of code (and if we required that the generic be passed as a character string it could be reduced to 3 lines of code). It will return a character string representing the name of the method that would be dispatched by the input generic given that generic and its arguments. (Replace the last line of the body of findMethod with get(X(...)) if you want to return the method itself instead.) Internally it creates a generic X and an X method corresponding to each method of the input generic such that each X method returns the name of the method of the input generic that would be run. The X generic and its methods are all created within the findMethod function so they disappear when findMethod exits. To get the result we just run X with the input argument(s) as the final line of the findMethod function body.
findMethod <- function(generic, ...) {
ch <- deparse(substitute(generic))
f <- X <- function(x, ...) UseMethod("X")
for(m in methods(ch)) assign(sub(ch, "X", m, fixed = TRUE), "body<-"(f, value = m))
X(...)
}
Now test it. (Note that the one-liner in the question fails with an error in several of these tests but findMethod gives the expected result.)
findMethod(as.ts, iris)
## [1] "as.ts.default"
findMethod(print, iris)
## [1] "print.data.frame"
findMethod(print, Sys.time())
## [1] "print.POSIXct"
findMethod(print, 22)
## [1] "print.default"
# in this example it looks at 2nd component of class vector as no print.ordered exists
class(ordered(3))
## [1] "ordered" "factor"
findMethod(print, ordered(3))
## [1] "print.factor"
findMethod(`[`, BOD, 1:2, "Time")
## [1] "[.data.frame"
I use this:
s3_method <- function(generic, class, env = parent.frame()) {
fn <- get(generic, envir = env)
ns <- asNamespace(topenv(fn))
tbl <- ns$.__S3MethodsTable__.
for (c in class) {
name <- paste0(generic, ".", c)
if (exists(name, envir = tbl, inherits = FALSE)) {
return(get(name, envir = tbl))
}
if (exists(name, envir = globalenv(), inherits = FALSE)) {
return(get(name, envir = globalenv()))
}
}
NULL
}
For simplicity this doesn't return methods defined by assignment in the calling environment. The global environment is checked for convenience during development. These are the same rules used in r-lib packages.
So I'm changing the class of some functions that I'm building in R in order to add a description attribute and because I want to use S3 generics to handle everything for me. Basically, I have a structure like
foo <- function(x) x + 1
addFunction <- function(f, description) {
class(f) <- c("addFunction", "function")
attr(f, "description") <- description
f
}
foo <- addFunction(foo, "Add one")
and then I do stuff like
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
This works fine, but it's not that elegant. I'm wondering if it is possible to define a new class of functions such that instances of this class can be defined in a syntax similar to the function syntax. In other words, is it possible to define addFunction such that foo is generated in the following way:
foo <- addFunction(description = "Add one", x) {
x + 1
}
(or something similar, I have no strong feelings about where the attribute should be added to the function)?
Thanks for reading!
Update: I have experimented a bit more with the idea, but haven't really reached any concrete results yet - so this is just an overview of my current (updated) thoughts on the subject:
I tried the idea of just copying the function()-function, giving it a different name and then manipulating it afterwards. However, this does not work and I would love any inputs on what is happening here:
> function2 <- `function`
> identical(`function`, function2)
[1] TRUE
> function(x) x
function(x) x
> function2(x) x
Error: unexpected symbol in "function2(x) x"
> function2(x)
Error: incorrect number of arguments to "function"
As function() is a primitive function, I tried looking at the C-code defining it for more clues. I was particularly intrigued by the error message from the function2(x) call. The C-code underlying function() is
/* Declared with a variable number of args in names.c */
SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP rval, srcref;
if (TYPEOF(op) == PROMSXP) {
op = forcePromise(op);
SET_NAMED(op, 2);
}
if (length(args) < 2) WrongArgCount("function");
CheckFormals(CAR(args));
rval = mkCLOSXP(CAR(args), CADR(args), rho);
srcref = CADDR(args);
if (!isNull(srcref)) setAttrib(rval, R_SrcrefSymbol, srcref);
return rval;
}
and from this, I conclude that for some reason, at least two of the four arguments call, op, args and rho are now required. From the signature of do_function() I am guessing that the four arguments passed to do_function should be a call, a promise, a list of arguments and then maybe an environment. I tried a lot of different combinations for function2 (including setting up to two of these arguments to NULL), but I keep getting the same (new) error message:
> function2(call("sum", 2, 1), NULL, list(x=NULL), baseenv())
Error: invalid formal argument list for "function"
> function2(call("sum", 2, 1), NULL, list(x=NULL), NULL)
Error: invalid formal argument list for "function"
This error message is returned from the C-function CheckFormals(), which I also looked up:
/* used in coerce.c */
void attribute_hidden CheckFormals(SEXP ls)
{
if (isList(ls)) {
for (; ls != R_NilValue; ls = CDR(ls))
if (TYPEOF(TAG(ls)) != SYMSXP)
goto err;
return;
}
err:
error(_("invalid formal argument list for \"function\""));
}
I'm not fluent in C at all, so from here on I'm not quite sure what to do next.
So these are my updated questions:
Why do function and function2 not behave in the same way? Why
do I need to call function2 using a different syntax when they are
deemed identical in R?
What are the proper arguments of function2
such that function2([arguments]) will actually define a function?
Some keywords in R such as if and function have special syntax in the way that the underlying functions get called. It's quite easy to use if as a function if desired, e.g.
`if`(1 == 1, "True", "False")
is equivalent to
if (1 == 1) {
"True"
} else {
"False"
}
function is trickier. There's some help on this at a previous question.
For your current problem here's one solution:
# Your S3 methods
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
# Creates the pairlist for arguments, handling arguments with no defaults
# properly. Also brings in the description
addFunction <- function(description, ...) {
args <- eval(substitute(alist(...)))
tmp <- names(args)
if (is.null(tmp)) tmp <- rep("", length(args))
names(args)[tmp==""] <- args[tmp==""]
args[tmp==""] <- list(alist(x=)$x)
list(args = as.pairlist(args), description = description)
}
# Actually creates the function using the structure created by addFunction and the body
`%{%` <- function(args, body) {
stopifnot(is.pairlist(args$args), class(substitute(body)) == "{")
f <- eval(call("function", args$args, substitute(body), parent.frame()))
class(f) <- c("addFunction", "function")
attr(f, "description") <- args$description
f
}
# Example. Note that the braces {} are mandatory even for one line functions
foo <- addFunction(description = "Add one", x) %{% {
x + 1
}
foo(1)
#[1] 2