Create list of functions without eval/parse - r

I have 3 vectors of equal length y, h and hp defined as follows:
y <- c(2, 5, 6)
h <- c(4, 25, 35)
hp <- c(3, 10, 12)
The values are simply illustrative.
I want to create an output list final_list of functions in x as follows
function(x) y + (h - hp) * x
(only ideal illustrative output shown):
[[1]]
[1] function(x) 2 + (1) * x
[[2]]
[1] function(x) 5 + (15) * x
[[3]]
[1] function(x) 6 + (23) * x
I am aware that this can be done with eval/parse, but this does not produce transparent output for the functions.
I would like to create the functions from these 3 vectors and output without using eval/parse. If this is possible I would be really happy to learn and be impressed!

You can use Map() with substitute(). The middle expressions are not yet evaluated, but I don't think that's such a big deal. They will be evaluated when the functions are called. Basically we just assemble the function in parts.
funs <- Map(
function(a, b, c) {
f <- function(x) x
body(f) <- substitute(y + (h - hp) * x, list(y = a, h = b, hp = c))
f
},
a = y, b = h, c = hp
)
funs
# [[1]]
# function (x)
# 2 + (4 - 3) * x
# <environment: 0x4543fd0>
#
# [[2]]
# function (x)
# 5 + (25 - 10) * x
# <environment: 0x4549e20>
#
# [[3]]
# function (x)
# 6 + (35 - 12) * x
# <environment: 0x454e5d8>
Now let's call the functions -
sapply(funs, function(a) a(1))
# [1] 3 20 29
Note: If you really need those middle expressions evaluated in the function bodies, you can use the following instead.
make <- function(a, b, c) {
d <- b - c
f <- function(x) x
body(f) <- substitute(y + (e) * x, list(y = a, e = d))
f
}
funs <- Map(make, y, h, hp)

y <- c(2,5,6)
h <- c(4, 25, 35)
hp <- c(3, 10, 12)
fun_create <- function(y, h, hp){
fun <- function(x){y + (h - hp)*x}
return(fun)
}
out <- mapply(y, h, hp, FUN = fun_create)
The output doesn't give what you might expect but it works correctly:
> out
[[1]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282ee40>
[[2]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282e610>
[[3]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x282dde0>
> out[[1]](1)
[1] 3

Just using the function-function will succeed if it is executed in the correct environment.
> mapply( function(y,h,hp) function(x){ y+(h-hp)*x }, y,h,hp)
[[1]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb570828710>
[[2]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb570823718>
[[3]]
function (x)
{
y + (h - hp) * x
}
<environment: 0x7fb57081b5c8>
> myfuns[[1]](x=1:10)
[1] 3 4 5 6 7 8 9 10 11 12
> 2+(h[1]-hp[1])*1:10
[1] 3 4 5 6 7 8 9 10 11 12
> myfuns[[2]](x=1:10)
[1] 20 35 50 65 80 95 110 125 140 155
Each of those function definitions (actually closures) carries along the first matching values that existed at the time of its creation when the interpreted traveled along the search path.
> environment(myfuns[[1]])[["y"]]
[1] 2
> environment(myfuns[[1]])[["h"]]
[1] 4
> environment(myfuns[[1]])[["hp"]]
[1] 3

Related

R formula: wrap all variables in a transformation

I have a formula with an arbitrary number of variables on the left and right-hand sides:
a + b * c ~ d + e
This formula can include various operators like + or *. I would like to wrap each variable of the formula in a transformation. For example, if my transformation is called Factor, then the formula above becomes:
Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
Notice that it preserved the same signs.
1) rrapply We can use rrapply to recursively walk the formula and surround every node that is a syntactic name with Factor(...). Alternately we could use is.word <- function(x) grepl("^\\w+$", x) to check for names that only contain word characters.
library(rrapply)
fo <- a + b * c ~ d + e
is.word <- function(x) make.names(x) == x
insert.Factor <- function(x) substitute(Factor(x), list(x = x))
rrapply(fo, is.word, insert.Factor)
## Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
If we can have formulas such as
fo2 <- a + b * c ~ I(d) + e
and we want I(Factor(d)) rather than Factor(I)(Factor(d)) then use this for is.word:
is.word <- function(x) make.names(x) == x && format(x) %in% all.vars(fo2)
2) gsub Convert to character string, perform the substitution and convert back. The input, fo, is defined above.
formula(gsub("(\\w+)", "Factor(\\1)", format(fo)), environment(fo))
## Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
3) Transform data frame If these variables will be obtained from a data frame DF then we could transform its columns and leave the formula as is.
DF[] <- lapply(DF, Factor)
Here is a way to update a formula with a recursive function:
update_formula <- function(x){
if(length(x) == 3){
x[[2]] <- update_formula(x[[2]])
x[[3]] <- update_formula(x[[3]])
return(x)
}else{
return(substitute(Factor(var), list(var = x)))
}
}
f <- a + b * c ~ d + e
update_formula(f)
# Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
The main idea is that each binary operator corresponds to a list of length 3. For example:
> as.list(f)
[[1]]
`~`
[[2]]
a + b * c
[[3]]
d + e
> as.list(f[[2]])
[[1]]
`+`
[[2]]
a
[[3]]
b * c
> as.list(f[[3]])
[[1]]
`+`
[[2]]
d
[[3]]
e
So we update the second and third component each time we encounter a binary operator.
To apply arbitrary transformation:
update_formula2 <- function(x, trans){
if(length(x) == 3){
x[[2]] <- update_formula2(x[[2]], trans)
x[[3]] <- update_formula2(x[[3]], trans)
return(x)
}else{
return(substitute(fun(var), list(fun = trans, var = x)))
}
}
f <- a + b * c ~ d + e
update_formula2(f, quote(Factor))
# Factor(a) + Factor(b) * Factor(c) ~ Factor(d) + Factor(e)
update_formula2(f, quote(log))
# log(a) + log(b) * log(c) ~ log(d) + log(e)

R: How to write a function that replaces a function call with another function call?

E.g. I want to transform the code
mean(x)
to
fn(x)
everytime I see mean in the code.
replace_mean <- function(code) {
substitute(code, list(mean = fn)) # doesn't work
substitute(substitute(code), list(mean = fn)) # doesn't work
}
the above two approaches don't work. E.g.
replace_mean(list(mean(y), mean(x)))
What's the best way to do function replacement using NSE in R?
Base R Solutions preferred.
Update example output
replace(mean(x)) # fn(x)
replace(list(a = mean(x), mean(ok))) # list(a=fn(x), fn(ok)))
The following function, when passed mean(x) and some fn such as sqrt as its two arguments returns the call object fn(x), i.e. sqrt(x), replacing occurrences of mean with fn.
replace_mean <- function(code, fn) {
do.call("substitute", list(substitute(code), list(mean = substitute(fn))))
}
Examples
1) Basic example
e <- replace_mean(mean(x), sqrt)
e
## sqrt(x)
x <- 4
eval(e)
## [1] 2
2) more complex expression
ee <- replace_mean(mean(x) + mean(x*x), sqrt)
ee
## sqrt(x) + sqrt(x * x)
x <- 4
eval(ee)
## [1] 6
3) apply replace_mean to body of f creating g
f <- function(x) mean(x) + mean(x*x)
g <- f
body(g) <- do.call("replace_mean", list(body(f), quote(sqrt)))
g
## function (x)
## sqrt(x) + sqrt(x * x)
x <- 4
g(x)
## [1] 6
One way is much more ugly and relies on string manipulation to generate the code you want to run and then evaluating it.
replace_mean <- function(code) {
code_subbed = substitute(code)
# constructu the code I want
code_subbed_subbed = sprintf("substitute(%s, list(mean=quote(fn)))", deparse(code_subbed))
eval(parse(text = code_subbed_subbed))
}
replace_mean(list(mean(x), a= mean(ok)))

Can last command executed be retrieved within an r script

Is there a function that will recall the last line executed within an R script? For example, if such a function existed and was called "echoLast", I am interested in using this in the following manner:
y <-3,
whi <- 4,
x <- 5
wlo <- 6
sum <- y * whi + x * wlo
last.command <- echoLast()
print(paste(last.command,sum,y,whi,x,wlo))
which would result in output of:
"sum <- y * whi + x * wlo 32 2 1 5 6"
Thank you
You can try something like:
f <- function() {
lv <- .Last.value
fname <- tempfile()
savehistory(fname)
lastcmd <- head(tail(readLines(fname), 2), 1)
parts <- strsplit(gsub("[^[:alnum:] ]", "", lastcmd), " +")[[1]]
vars <- as.list.environment(.GlobalEnv)
c(list(Last.command=lastcmd, Last.value=lv), vars[names(vars) %in% parts])
}
y <- 3
whi <- 4
x <- 5
wlo <- 6
sum <- y * whi + x * wlo
f()
output:
$`Last.command`
[1] "sum <- y * whi + x * wlo"
$Last.value
[1] 42
$x
[1] 5
$y
[1] 3
$sum
[1] 42
$whi
[1] 4
$wlo
[1] 6
Caveat: does not when it is run from source

How to use multiple result values from a function in R?

I have the following code in R:
a <- 2
evaluate <- function(x){
b <- 2*x
c <- 3*x
d <- 4*x
out <- list("b" = b, "c" = c, "d" = d)
return(out)
}
evaluate(a)
I obtain something like
$b
[1] 4
$c
[1] 6
$d
[1] 8
How can I compute something like b + c + d ?
so many options
# with
with(evaluate(a), b + c + d)
[1] 18
# unlist the unnamed output object
sum(unlist(evaluate(a)))
[1] 18
# subset a named output object
result <- evaluate(a)
result$b + result$c + result$d
[1] 18
# subset an unnamed output object
evaluate(a)$b + evaluate(a)$c + evaluate(a)$d
[1] 18
# custom function with fancy arguments
f <- function(...) {
args <- unlist(...)
sum(args)
}
f(evaluate(a))
[1] 18
Also, +1 from: #Gregor (double-bracket list subsetting)
result[["b"]] + result[["c"]] + result[["d"]]
[1] 18
In R you can access list members using $ operator, followed by member name so, in your code, for example:
result = evaluate(a)
result$b + result$c + result$d
Your function returns a list. You could return a vector and then use the sum() function to compute the sum of the elements in the vector. If you must use a list, the 'Reduce()` function can work.
l <- list(2, 3, 4)
v <- c(2,3,4)
sum(v) # returns 9
Reduce("+", l) # returns 9

How to define a flexible 'function expression' in R

Is it possible to write a flexible function expression?
I want to use input arguments to control the expression of function.
For example
input arg -> function
c(1,1) -> func1 = function(x) x+1
c(1,3,2) -> func2 = function(x) x^2+3*x+2
c(6,8,-1) -> func3 = function(x) 6*x^2+8*x-1
makepoly <- function(b)
{
p <- rev(seq_along(b) - 1)
function(x)
{
xp <- outer(x, p, '^')
rowSums(xp * rep(b, each=length(x)))
}
}
# x^2 + 2x + 3
f <- makepoly(1:3)
f(0:4)
[1] 3 6 11 18 27
Here is my take on this task
create_poly <- function(coef)
paste(rev(coef),
paste("x", seq_along(coef) - 1, sep = "^"),
sep = "*", collapse = " + ")
make_polyfun <- function(input) {
myfun <- paste("function(x)", create_poly(input))
eval(parse(text = myfun))
}
With the example the OP gave we have :
make_polyfun(c(1, 1))
## function(x) 1*x^0 + 1*x^1
## <environment: 0x243a540>
make_polyfun(c(1, 3, 2))
## function(x) 2*x^0 + 3*x^1 + 1*x^2
## <environment: 0x1bd46e0>
make_polyfun(c(6, 8, 1))
## function(x) 1*x^0 + 8*x^1 + 6*x^2
## <environment: 0x22a59c0>
You can use polynom
library(polynom)
as.polynomial(c(2,3,1))
2 + 3*x + x^2
as.polynomial(c(6,8,1)
1 + 8*x + 6*x^2
EDIT you can of course coerce the result to a function using the genericas.function.polynomial. better here you can use ,as.polylist` to create many polynomials given a list of coefficients lists. For example:
lapply(as.polylist(list(c(2,3,1),c(6,8,1),c(6,8,-1))),
as.function)
[[1]]
function (x)
{
w <- 0
w <- 1 + x * w
w <- 3 + x * w
w <- 2 + x * w
w
}
<environment: 0x00000000113bd778>
[[2]]
function (x)
{
w <- 0
w <- 1 + x * w
w <- 8 + x * w
w <- 6 + x * w
w
}
<environment: 0x0000000011524168>
[[3]]
function (x)
{
w <- 0
w <- -1 + x * w
w <- 8 + x * w
w <- 6 + x * w
w
}
<environment: 0x0000000011527f28>
It's not clear how general you want to be from OP. For the particular case of polynomials, you can do:
f = function(x, coeffs) {
sum(outer(x, seq_along(coeffs) - 1, `^`) * coeffs)
}
f(2, c(1,2,3)) # 1 + 2*x + 3*x^2, with x = 2
#[1] 17
I read this as the desire to make functions and I think the agstudy/eddi responses would probably do this, but I thought trying it from scratch might be instructive:
poly.maker <- function(coefs) { func <- function(x){} #empty func in x
body(func) <- parse(text= paste( seq_along(coefs),"*x^",
(length(coefs)-1):0,collapse="+" ) )
return(func) }
func2 <- poly.maker(c(1,2,3)) # return a function
func2(3) # now test it out
#[1] 18
Note I needed to swap the order to agree with the OP request, which I only noticed after getting different results than #dickoa. This seems less clunky:
poly.make2 <- function(coefs) { func <- function(x){}
body(func) <- bquote(sum(.(coefs)*x^.( (length(coefs)-1):0 ) ) )
return(func) }
func <- poly.make2(c(1,2,5))
func
#function (x)
#sum(c(1, 2, 5) * x^c(2L, 1L, 0L))
#<environment: 0x29023d508>
func(3)
#[1] 20
One liner:
polymaker2 <- function(coefs)
{
eval(parse(text=paste0( "function(x) sum(x^(",length(coefs)-1,":0) * ",capture.output(dput(coefs)),")" )))
}
Vectorized form:
polymaker3 <- function(coefs)
{
eval(parse(text=paste0( "function(x) colSums(t(outer(x, ",length(coefs)-1,":0, `^`))*",capture.output(dput(coefs)),")" )))
}

Resources