Consider:
guy <- new.env(FALSE)
guy$stuff <- mean
guy$lib <- library
guy$stole_this_data <- mtcars
ls(guy)
How can I evaluate an expression within an environment inside a function?
For instance I can do with(guy, args(stuff)) to the below and return:
> with(guy, args(stuff))
function (x, ...)
NULL
But within a functon:
foo <- function(env, fun) {
with(env, args(fun))
}
foo(guy, stuff)
## > foo(guy, stuff)
## Error in args(fun) : could not find function "stuff"
Try this:
> foo <- function(env, fun) eval(substitute(args(fun)), env)
> foo(guy, stuff)
function (x, ...)
NULL
ADDED. Regarding the comment below here is an example where zz is not in env or its ancestors (but is in foo2 and in f, the caller of foo2) and it does give a not found error as the comment wished:
> foo2 <- function(env, fun, zz = 1) eval(substitute(fun), env)
> f <- function() { zz <- 100; foo2(guy, zz+1) }
> f()
Error in eval(expr, envir, enclos) : object 'zz' not found
If you want to continue to use the with construct, this is an alternative:
foo <- function(env, fun) {
fun <- substitute(fun)
eval(bquote(with(env, {
.(fun)
})))
}
Related
Consider the function
f <- function(x, X) mean(c(x,X))
How can I automatically (by manipulation of f()) change the signature of f() such that it can be used with lapply(), i.e., without returning the following obvious error?
lapply(X=list(1), FUN=f, X=1)
Error in lapply(X = list(1), FUN = f, X = 1) :
formal argument "X" matched by multiple actual arguments
The approach I used so far is to remove all arguments from f(), assign them into an environment, and evaluatef() in that environment.
integrateArgs <- function (f, args)
{
form <- formals(f)
if (!is.null(form))
for (i in seq_along(form)) assign(names(form)[i], form[[i]])
if (!is.null(args))
for (i in seq_along(args)) assign(names(args)[i], args[[i]])
ff <- function() {
}
parent.env(environment(ff)) <- parent.env(environment(f))
body(ff) <- body(f)
if (any(names(form) == "..."))
formals(ff) <- form[names(form) == "..."]
ff
}
fnew <- integrateArgs(f, list(x=1, X=4))
lapply(list(fnew), function(x) x())
[[1]]
[1] 2.5
However, that approach leads to the following error if f() is a function from another R package that calls compiled code.
fnew2 <- integrateArgs(dnorm, list(x=1, mean=4))
lapply(list(fnew2), function(x) x())
Error in x() (from #1) : object 'C_dnorm' not found
Are there better solutions?
As suggested in a comment by MrFlick, one solution is
library(purrr)
integrateArgs <- function(f, args){
do.call(partial, c(list(f), args))
}
fnew2 <- integrateArgs(dnorm, list(x=1, mean=4))
lapply(list(fnew2), function(x) x())
[[1]]
[1] 0.004431848
The following similar approach does not require the package purrr:
integrateArgs <- function(f, args){
do.call(function(f, ...) {
eval(call("function", NULL,
substitute(f(...))), envir = environment(f))},
c(f = list(f), args))
}
fnew2 <- integrateArgs(dnorm, list(x=1, mean=4))
lapply(list(fnew2), function(x) x())
[[1]]
[1] 0.004431848
A similar approach is now used in optimParallel version 0.7-4 to execute functions in parallel using parallel::parLapply(): https://cran.r-project.org/package=optimParallel
I want to create an S3 generic in the global environment from a function. I took a look at R.methodsS3::setGenericS3.default and came up with the following:
create_generic <- function(nm) {
src <- sprintf("%s <- function(obj, ...) UseMethod(\"%s\")", nm, nm)
expr <- parse(text = src)
print(expr)
eval(expr, env = .GlobalEnv)
}
create_generic("cat")
#> expression(cat <- function(obj, ...) UseMethod("cat"))
cat
#> function (obj, ...)
#> UseMethod("cat")
This works how I'd like it to. However, I've been trying to make this work using quotation and I'm stuck:
library(rlang)
create_generic2 <- function(nm) {
expr <- expr(!!sym(nm) <- function(obj, ...) UseMethod(!!nm))
print(expr)
eval(expr, env = .GlobalEnv)
}
create_generic2("dog")
#> dog <- function(obj, ...) UseMethod("dog")
dog
#> function(obj, ...) UseMethod(!!nm)
This makes use of tidyeval since that's what I'm familiar with, but I'd like to see what this looks like in base R.
I'm interested in any version of this that works without the string manipulation in create_generic.
In base R:
create_generic <- function(fun_name) {
new_fun <- function(obj, ...) UseMethod(fun_name)
assign(fun_name, new_fun, envir = .GlobalEnv)
}
cat("hi\n")
# hi
create_generic("cat")
cat("hi\n")
# Error in UseMethod(fun_name) :
# no applicable method for 'cat' applied to an object of class "character"
cat.character <- base::cat
cat("hi\n")
# hi
You can also use expr_interp() to use unquoting operators within functions:
create_generic <- function(name, env = globalenv()) {
gen <- expr_interp(function(obj, ...) {
UseMethod(!!name)
})
environment(gen) <- env
assign(name, gen, envir = env)
}
The prefix is expr_ because it is (internally) generic over expression wrappers, e.g. formulas and functions.
This is my function:
f <- function(a, b, ...){
c(as.list(environment()), list(...))
}
If I call f(a = 2) no error will be raised, although b is missing. I would like to get an error in this case:
Error in f(a = 2) : argument "b" is missing, with no default
What piece of dynamic and efficient code I must add such that this error be raised? I was thinking something in line of the following: force(as.symbol(names(formals()))).
Note: In case you wonder why I need this kind of function: It is a way to standardize the kinds of lists. Such a list must have a and b, and possibly other keys. I could play with objects too...
Solutions: See Carl's answer or comments below.
f <- function(a, b, ...){
sapply(ls(environment()), get, envir = environment(), inherits = FALSE)
c(as.list(environment()), list(...))
}
Or
f <- function(a, b, ...){
stopifnot(all(setdiff(names(formals()), '...') %in% names(as.list(match.call()[-1]))))
c(as.list(environment()), list(...))
}
An idea... first check for all arguments that exist in the any function anonymously... meaning regardless of the functions, get the arguments into a list with no preset requirements:
#' A function to grab all arguments of any calling environment.. ie.. a function
#'
#'
#' \code{grab.args}
#'
grab.args <- function() {
envir <- parent.frame()
func <- sys.function(-1)
call <- sys.call(-1)
dots <- match.call(func, call, expand.dots=FALSE)$...
c(as.list(envir), dots)
}
Then, in whatever function you use it for.. store the initial arguments on a list does_have, then find all the arguments that are pre-defined in the environment with should_have, loop through the list to match names and find if any are missing values... if any are... create the error with the names that are missing, if not... do your thing...
#' As an example
#'
f <- function(a, b, ...){
does_have <- grab.args()
should_have <- ls(envir = environment())
check_all <- sapply(should_have, function(i){
!nchar(does_have[[i]])
})
if(any(mapply(isTRUE, check_all))){
need_these <- paste(names(which(mapply(isTRUE,check_all))), collapse = " and ")
cat(sprintf('Values needed for %s', need_these))
}else {
does_have
}
}
Outputs for cause....
> f(mine = "yours", a = 3)
Values needed for b
> f(b = 12)
Values needed for a
> f(hey = "you")
Values needed for a and b
Edit to throw an actual error...
f <- function(a,b,...){
Filter(missing, sapply(ls(environment()), get, environment()))
}
> f(a = 2, wtf = "lol")
Error in FUN(X[[i]], ...) : argument "b" is missing, with no default
suppose I have
library(functional)
f = function(x, p) { x^p }
f2 = Curry(f, p=2)
Is there a way to find out what p was set to given only f2?
See if this is useful. Essentially the p argument is carried in the environment of the body of Curry()-ied function:
> body(f2)
do.call(FUN, c(.orig, list(...)))
> body(f2)[[1]]
do.call
> body(f2)[[3]]
c(.orig, list(...))
> body(f2)[[3]][[2]]
.orig
> eval(body(f2)[[3]][[2]])
Error in eval(expr, envir, enclos) : object '.orig' not found
> eval(body(f2)[[3]][[2]], environment(f2) )
$p
[1] 2
As BrodieG comments these could be used in a programming attack on the problem:
> environment(f2)$.orig
$p
[1] 2
> environment(f2)$.orig$p
[1] 2
To see why I didn't stumble upon that initially compare:
> ls( envir=environment(f2) )
[1] "FUN"
> ls( envir=environment(f2) ,all.names=TRUE)
[1] "..." ".orig" "FUN"
The ls function only displays items whose initial characters are not "dots" unless the all.names parameter is set to TRUE.
So this is also imformative:
> environment(f2) $FUN
function(x, p) { x^p }
I want to create a function that will retry an expression if it fails. Here's my working version:
retry <- function(.FUN, max.attempts=3, sleep.seconds=1) {
x <- NULL
if(max.attempts > 0) {
f <- substitute(.FUN)
x <- try(eval(f))
if(class(x) == "try-error") {
Sys.sleep(sleep.seconds)
return(suppressWarnings(retry(.FUN, max.attempts-1)))
}
}
x
}
retry(stop("I'm here"))
If I remove the suppressWarnings() function above, then I get a set of warnings on each recursive call. Does anyone know what I'm doing wrong that would cause that?
Here's an example that can be run repeatedly:
retry({ tmp <- function() { if(rnorm(1) < 0) stop("I'm here") else "success" }; tmp() })
I'm not sure if I can describe the cause exactly, but I've isolated the problem and can fix it. The basic problem is the recursion: retry(.FUN, max.attempts-1) - when the recursive call calls substitute(.FUN) it's going to have go up a level of the call stack to figure out what the value of .FUN is - it has to restart the evaluation of a promise (the delayed execution of function arguments) a level up.
A fix is to just do the substitution once:
retry <- function(.FUN, max.attempts = 3, sleep.seconds = 0.5) {
expr <- substitute(.FUN)
retry_expr(expr, max.attempts, sleep.seconds)
}
retry_expr <- function(expr, max.attempts = 3, sleep.seconds = 0.5) {
x <- try(eval(expr))
if(inherits(x, "try-error") && max.attempts > 0) {
Sys.sleep(sleep.seconds)
return(retry_expr(expr, max.attempts - 1))
}
x
}
f <- function() {
x <- runif(1)
if (x < 0.5) stop("Error!") else x
}
retry(f())
To create functions that you can use flexibly, I highly recommend minimising the use of substitute. In my experience, you're usually best off having one function that does the substitution, and another that does all the work. This makes it possible to use the function when called from another function:
g1 <- function(fun) {
message("Function starts")
x <- retry(fun)
message("Function ends")
x
}
g1(f())
# Function starts
# Error in eval(expr, envir, enclos) : object 'fun' not found
# Error in eval(expr, envir, enclos) : object 'fun' not found
# Error in eval(expr, envir, enclos) : object 'fun' not found
# Error in eval(expr, envir, enclos) : object 'fun' not found
# Function ends
g2 <- function(fun) {
message("Function starts")
expr <- substitute(fun)
x <- retry_expr(expr)
message("Function ends")
x
}
g2(f())
# Function starts
# Error in f() : Error!
# Function ends
# [1] 0.8079241
Not sure about why you get the warnings... but if use a for loop they disappear.
retry <- function(.FUN, max.attempts=3, sleep.seconds=1)
{
x <- NULL
for (i in 1:max.attempts)
{
f <- substitute(.FUN)
x <- try(eval(f))
if (class(x) == "try-error")
{
Sys.sleep(sleep.seconds)
}
else
{
return (x)
}
}
x
}