>#R version 3.1.1 (2014-07-10) -- "Sock it to Me"
> library(pryr)
> f1 <- function() { cat("hi1\n"); 1 }
> f2 <- function() { cat("hi2\n"); 2 }
This is what I would like to have but with e = globalenv:
> e <- new.env()
> delayedAssign("x", f1(), assign.env = e)
> substitute(x, e)
f1()
If I try substitute it does not work (according to doc, there is no substitute in globalenv):
> delayedAssign("x", f1(), assign.env = globalenv())
> substitute(x, globalenv())
x
subs from pryr doesn not work either because it evaluates the promise:
> subs(x, globalenv())
hi1
[1] 1
in fact it evaluates all promises, because it converts globalenv to a list:
> delayedAssign("x", f1(), assign.env = globalenv())
> delayedAssign("y", f2(), assign.env = globalenv())
> subs(x, globalenv())
hi1
hi2
[1] 1
>
To sum up: Is it possible to have something like substitute that works with promises in all environments including globalenv?
UPDATE
I could not figure out how to do this within R, so I wrote (more precisely lifted from the R code) the following C func
SEXP get_no_eval(SEXP symbol, SEXP envir) {
SEXP t;
if (!Rf_isString(symbol) || Rf_length(symbol)!=1)
Rf_error("symbol is not a string");
if (!Rf_isEnvironment(envir))
Rf_error("envir is not an environment");
if (envir==R_NilValue)
Rf_error("envir is NULL");
t = Rf_findVar(Rf_install(CHAR(STRING_ELT(symbol, 0))), envir);
if (t != R_UnboundValue) {
if (TYPEOF(t) == PROMSXP) {
do {
t = PREXPR(t);
} while(TYPEOF(t) == PROMSXP);
if (NAMED(t) < 2) SET_NAMED(t, 2);
return t;
}
else if (TYPEOF(t) == DOTSXP)
Rf_error("'...' used in an incorrect context");
return t;
}
Rf_error("symbol not found");
return R_NilValue;
}
Now, continuing my example from above I can do:
> delayedAssign("x", f1(), assign.env = globalenv())
> get_no_eval("x", globalenv())
f1()
Not exactly substitute but works for what I needed.
Related
How can I simply tell R to retry a statement a few times if it errors? E.g. I was hoping to do something like:
tryCatch(dbGetQuery(...), # Query database
error = function(e) {
if (is.locking.error(e)) # If database is momentarily locked
retry(times = 3) # retry dbGetQuery(...) 3 more times
else {
# Handle other errors
}
}
)
I usually put the try block in a loop,
and exit the loop when it no longer fails or the maximum number of attempts is reached.
some_function_that_may_fail <- function() {
if( runif(1) < .5 ) stop()
return(1)
}
r <- NULL
attempt <- 1
while( is.null(r) && attempt <= 3 ) {
attempt <- attempt + 1
try(
r <- some_function_that_may_fail()
)
}
I wrote a quick function that allows you to easily retry an operating a configurable number of times, with a configurable wait between attempts:
library(futile.logger)
library(utils)
retry <- function(expr, isError=function(x) "try-error" %in% class(x), maxErrors=5, sleep=0) {
attempts = 0
retval = try(eval(expr))
while (isError(retval)) {
attempts = attempts + 1
if (attempts >= maxErrors) {
msg = sprintf("retry: too many retries [[%s]]", capture.output(str(retval)))
flog.fatal(msg)
stop(msg)
} else {
msg = sprintf("retry: error in attempt %i/%i [[%s]]", attempts, maxErrors,
capture.output(str(retval)))
flog.error(msg)
warning(msg)
}
if (sleep > 0) Sys.sleep(sleep)
retval = try(eval(expr))
}
return(retval)
}
So you can just write val = retry(func_that_might_fail(param1, param2), maxErrors=10, sleep=2) to retry calling that function with those parameters, give up after 10 errors, and sleep 2 seconds between attempts.
Also, you can redefine the meaning of what an error looks like by passing a different function as parameter isError, which by default will catch an error signaled with stop. This is useful if the function being called does something else on error, such as returning FALSE or NULL.
This is the alternative I've found so far that results in clearer, more readable code.
Hope this helps.
A solution without pre-assigning values and using for instead of while:
some_function_that_may_fail <- function(i) {
if( runif(1) < .5 ) stop()
return(i)
}
for(i in 1:10){
try({
r <- some_function_that_may_fail(i)
break #break/exit the for-loop
}, silent = FALSE)
}
r will be equal to the number of tries that were needed. If you dont want the output of the errors set silent to TRUE
Here's a function to generate a custom condition to respond to
locked <- function(message="occurred", ...) {
cond <- simpleCondition(message, ...)
class(cond) <- c("locked", class(cond))
cond
}
and a function implemented to allow (an infinite number of) restarts
f <- function() {
cnt <- 0L
repeat {
again <- FALSE
cnt <- cnt + 1L
withRestarts({
## do work here, and if needed...
signalCondition(locked())
}, retry=function() {
again <<- TRUE
})
if (!again) break
}
cnt
}
and the use of withCallingHandlers (to keep the context where the condition was signaled active unlike tryCatch) to handle the locked condition
withCallingHandlers({
n_tries <- 0L
f()
}, locked=function(e) {
n_tries <<- n_tries + 1L
if (n_retries < 3)
invokeRestart("retry")
})
I have put together the code and make it package: retry
f <- function(x) {
if (runif(1) < 0.9) {
stop("random error")
}
x + 1
}
# keep retring when there is a random error
retry::retry(f(1), when = "random error")
#> [1] 2
# keep retring until a requirement is satisified.
retry::retry(f(1), until = function(val, cnd) val == 2)
#> [1] 2
# or using one sided formula
retry::retry(f(1), until = ~ . == 2, max_tries = 10)
#> [1] 2
I like setting my object as an error from the start, also sometimes useful to add some sleep time if you're having connection problems:
res <- simpleError("Fake error to start")
counter <- 1
max_tries <- 10
# Sys.sleep(2*counter)
while(inherits(res, "error") & counter < max_tries) {
res <- tryCatch({ your_fun(...) },
error = function(e) e)
counter <- counter + 1
}
I have defined the next function
inequalizer <- function(x,caracter) {
if(caracter=="X") {
function(y) {y[1] < x}
} else if(caracter=="Y") {
function(y) {y[2] < x}
} else {
function(y) {y[3] < x}
}
}
which returns one function depending on the input parameters x and caracter. I have another function where I call this function recursively , whose arguments depend on some initial data.
This function returned by "inequalizer" is saved as
function(y) {y[2] < x}
<bytecode: 'code'>
<environment: 'code'>
I want to know if there is some way to save it with the literal argument passed to x. So if those parameters are x=1 caracter="Y" I would get
function(y) {y[2] < 1}
<bytecode: 'code'>
<environment: 'code'>
Maybe store x as attr
inequalizer <- function(x, caracter) {
if(caracter=="X") {
foo = function(y) {y[1] < x}
attr(foo, "x") = x
foo
} else if(caracter=="Y") {
foo = function(y) {y[2] < x}
attr(foo, "x") = x
foo
} else {
foo = function(y) {y[3] < x}
attr(foo, "x") = x
foo
}
}
myf = inequalizer(5, "X")
myf
#function(y) {y[1] < x}
#<environment: 0x000000001c12e2d0>
#attr(,"x")
#[1] 5
I am trying to write a very simple function wrapper in R, that will accept f and return g where g returns zero whenever the first argument is negative. I have the following code
wrapper <- function(f) {
function(x, ...) {
if( x <= 0 ) { 0 }
else { f(x, ...) }
}
}
Thge wrapper works as expected, but is there are way to maintain the function signature
> wdnorm <- wrapper(dnorm)
> args(dnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> args(wdnorm)
function (x, ...)
NULL
I would like to do something like this (but obviously it doesn't work)
args(g) <- args(f)
is this possible in R?
Here is what you want. Tho, do you really need this?
wrapper <- function(f) {
f2 = function(x) {
if (x <= 0) { 0 }
else { do.call(f, as.list( match.call())[-1]) }
}
formals(f2) = formals(f)
f2
}
wdnorm <- wrapper(dnorm)
args(dnorm)
args(wdnorm)
wdnorm(-5)
wdnorm(5)
output
> args(dnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> args(wdnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> wdnorm(-5)
[1] 0
> wdnorm(5)
[1] 1.48672e-06
I have been using DEoptim for some time to test different parameters for a hydrology algorithm. The code is mainly written in R, but there is a function written in Rcpp. If I run DEoptim in non-parallel mode, it runs fine, but if I run in parallel mode (i.e. paralleltype=1) the code returns an error saying it can't find my Rcpp function. So the Rcpp function looks like this:
loadcppfunctions <- function() {
eastfunc <<- 'NumericMatrix eastC(NumericMatrix e, NumericMatrix zerocolmatrix, NumericMatrix zerorowmatrix) {
int ecoln = e.ncol();
int ecolnlessone = ecoln - 1;
int erown = e.nrow();
int erownlessone = erown - 1;
NumericMatrix eout(e.nrow(),e.ncol()) ;
for (int j = 0;j < ecoln;j++) {
if (j > 0) {
eout(_,j) = e(_,j-1);
} else {
eout(_,j) = e(_,0);
}
}
eout(_,0) = zerocolmatrix(_,0);
return eout;
}'
eastC <<- cppFunction(eastfunc)
}
and then I just use:
loadcppfunctions()
Later in the code I call this function as follows:
movefdrerunoff <- eastC(fdrerunoff, zerocolmatrix, zerorowmatrix)
As I say, it all works fine - but if I run DEoptim as follows:
ans <- DEoptimone(Calibrate,lower,upper,DEoptim.control(trace=TRUE,parallelType=1,parVar=c(parVarnames),packages=c("raster","rgdal","maptools","matrixcalc","Rcpp","RcppArmadillo")))
It fails saying:
Error in checkForRemoteErrors(val) :
7 nodes produced errors; first error: could not find function "eastC"
So how can I make DEoptim see this function when all the other R based functions are fine.
Thanks, Antony Walker
I found that by adding the Rcpp function inside the main DEoptim function (Calibrate) worked. The Calibrate function looked like:
Calibrate <- function(x) {
eastfunc <<- 'NumericMatrix eastC(NumericMatrix e, NumericMatrix zerocolmatrix, NumericMatrix zerorowmatrix) {
int ecoln = e.ncol();
int ecolnlessone = ecoln - 1;
int erown = e.nrow();
int erownlessone = erown - 1;
NumericMatrix eout(e.nrow(),e.ncol()) ;
for (int j = 0;j < ecoln;j++) {
if (j > 0) {
eout(_,j) = e(_,j-1);
} else {
eout(_,j) = e(_,0);
}
}
eout(_,0) = zerocolmatrix(_,0);
return eout;
}'
eastC <<- cppFunction(eastfunc)
cmax <<- x[1]
Cr <<- x[2]
Cl <<- x[3]
Crb <<- x[4]
Clb <<- x[5]
returnflowriver <<- x[6]
returnflowland <<- x[7]
kd <<- x[8]
startyear()
-NashSutcliffe
}
and then running DEoptim as:
ans <- DEoptimone(Calibrate,lower,upper,DEoptim.control(trace=TRUE,parallelType=1,parVar=c(parVarnames),packages=c("raster","rgdal","maptools","matrixcalc","Rcpp","RcppArmadillo","moveCpp")))
I have multiple functions handing around arguments that may be missing.
e.g. i have
mainfunction <- function(somearg) {
mytest(somearg)
fun <- function() { subfunction(somearg) }
fun()
}
with the interesting aspect that the only interaction of mytest(somearg) with the arg is that it tests if the argument isn’t missing:
mytest = function(somearg) {
print(missing(somearg))
}
subfunction then again tests if it’s missing and treats it accordingly:
subfunction = function(somearg) {
if (missing(somearg))
somearg = NULL
else
somearg = matrix(somearg, cols = 2)
# somearg is used here…
}
the kicker is that, with somearg missing, this doesn’t work: matrix(somearg, cols = 2) throws
argument "somearg" is missing, with no default
during debugging, i found the following:
at the start of mainfunction, missing(somearg) returns TRUE
in mytest, missing(somearg) returns TRUE
insubfunction, missing(somearg) returns FALSE (!!!!)
therefore the matrix branch is hit, but in reality, somearg is missing, so it fails…
wat.
the #BenBolker way:
mainfunction <- function(somearg = NULL) {
mytest(somearg)
fun <- function() { subfunction(somearg) }
fun()
}
mytest = function(somearg) {
print(is.null(somearg))
}
subfunction = function(somearg) {
if (is.null(somearg))
somearg = 1:10
else
somearg = matrix(somearg, ncol = 2)
somearg
}
Another way, using explicit missing argument
mainfunction <- function(somearg) {
is_missing <- missing(somearg)
mytest(is_missing)
fun <- function() { subfunction(somearg, is_missing) }
fun()
}
mytest = function(x) { print(x) }
subfunction = function(somearg, is_arg_missing) {
if (is_arg_missing)
somearg = 1:10
else
somearg = matrix(somearg, ncol = 2)
somearg
}
A third way, using plain missing arg passing:
mainfunction <- function(somearg) {
is_missing <- missing(somearg)
mytest(somearg)
fun <- function() {
if (is_missing) subfunction() else
subfunction(somearg)
}
fun()
}
mytest = function(somearg) {
print(missing(somearg))
}
subfunction = function(somearg) {
if (missing(somearg))
somearg = 1:10
else
somearg = matrix(somearg, ncol = 2)
somearg
}