change argument names inside a function r - r

I'm trying to adjust the names of an argument inside a function. I want to create a procedure that takes the body of a function, looks for x, changes every x into x0, and then restores the function to what it was before. To provide an example:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
# Give f new formals
formals(f) = setNames(vector("list", length(form_new)), form_new)
# Copy function body
bod = as.list(body(f))
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod)
}
# return from list to call ?
body(f) = as.call(list(bod))
f(1, 1) # produces an error
So far, this code will change all variable names from x to x0 and from y to y0. However, the final output of bod is a character vector and not a call. How can I now change this back to a call?
Thanks in advance!

Surely there is a better way to do what you are trying to do that doesn't require modifying functions. That being said, you definetly don't want to be replacing variables by regular expressions, that could have all sorts of problems. Generally, trying to manipulate code as strings is going to lead to problems, for example, a function like tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }, where there are strings and variable names overlap, will lead to the wrong results.
Here is a function that takes a recursive approach (Recall) to traverse the expression tree (recursion could be avoided using a 'stack' type structure, but it seems more difficult to me).
## Function to replace variables in function body
## expr is `body(f)`, keyvals is a lookup table for replacements
rep_vars <- function(expr, keyvals) {
if (!length(expr)) return()
for (i in seq_along(expr)) {
if (is.call(expr[[i]])) expr[[i]][-1L] <- Recall(expr[[i]][-1L], keyvals)
if (is.name(expr[[i]]) && deparse(expr[[i]]) %in% names(keyvals))
expr[[i]] <- as.name(keyvals[[deparse(expr[[i]])]])
}
return( expr )
}
## Test it
f <- function(x, y) -x^2 + x + -y^2 + y
newvals <- c('x'='x0', 'y'='y0') # named lookup vector
newbod <- rep_vars(body(f), newvals)
newbod
# -x0^2 + x0 + -y0^2 + y0
## Rename the formals, and update the body
formals(f) <- pairlist(x0=bquote(), y0=bquote())
body(f) <- newbod
## The new 'f'
f
# function (x0, y0)
# -x0^2 + x0 + -y0^2 + y0
f(2, 2)
# [1] -4
With a more difficult function, where you want to avoid modifying strings or the other variables named yy and xx for example,
tricky <- function(x, y) { tst <- "x + y"; -xx*x + yy*y }
formals(tricky) <- pairlist(x0=bquote(), y0=bquote())
body(tricky) <- rep_vars(body(tricky), newvals)
tricky
# function (x0, y0)
# {
# tst <- "x + y"
# -xx * x0 + yy * y0
# }
#

There are a few ways to go here. Following your code, I would go with something like this:
f = function(x, y) -x^2 + x + -y^2 + y
# Take old names
form_old = names(formals(f))
# Make new names
form_new = paste0(form_old, 0)
deparse(body(f)) -> bod
for (i in 1:length(form_new)) {
bod = gsub(form_old[i], form_new[i], bod, fixed = TRUE)
}
formals(f) = setNames(vector("list", length(form_new)), form_new)
body(f) <- parse(text = bod)
f(1, 1)

Related

How do I add arguments for a function used as an input to another function in R?

I have a global function of roughly the form:
demo_fcn <- function(f, x1,x2){
r = x1 - x2
return(f(r))
}
I want to create this function in a general way so that users can add their own f with their own custom inputs, so long as there is an input slot for r. Say we take f to be the following function
f <- function(input, factor){
out = input^factor
return(out)
}
In this case, input = r, so that the user is able to call
demo_fcn(f(factor=2),x1=2,x2=3)
I get the error
Error in f(factor = 2) : argument "input" is missing, with no default
The desired outcome here should be the following code running
r = 2-3
f(input=r, factor=2)
The end goal is to implement this in a more complicated function, with multiple arguments for both demo_fcn and f
demo_fcn <- function(f, x1,x2){
r1 = x1 - x2
r2 = x1+x2
return(f(r1,r2))
}
f <- function(input1, input2, factor1,factor2){
out = input^factor1 + input2^factor2
return(out)
}
One way is to pass a function (not a function call), and use ... in the top function to pass additional arguments.
demo_fcn <- function(f, x1, x2, ...) {
r = x1 - x2
f(r, ...)
}
f <- function(input, factor){
out = input^factor
out
}
demo_fcn(f, x1=2, x2=5, factor=2)
# [1] 9
If you want to have multiple such functions, then you can do:
demo_fcn <- function(f1, f2, x1, x2, f1opts = NULL) {
r = x1 - x2
do.call(f, c(list(r), f1opts))
}
demo_fcn(f, x1=2, x2=5, f1opts=list(factor=2))
Yet another alternative, taking from curve, which may match more closely what you're hoping for.
demo_fcn <- function(expr, x1, x2, xname = "x") {
r = x1 - x2
sexpr <- substitute(expr)
if (is.name(sexpr)) {
expr <- call(as.character(sexpr), as.name(xname))
} else {
if (!((is.call(sexpr) || is.expression(sexpr)) && xname %in%
all.vars(sexpr)))
stop(gettextf("'expr' must be a function, or a call or an expression containing '%s'",
xname), domain = NA)
expr <- sexpr
}
ll <- list(x = r)
names(ll) <- xname
eval(expr, envir = ll, enclos = parent.frame())
}
demo_fcn(f(x, factor=2), x1=2, x2=5)
# [1] 9
See ?curve for more explanation of xname=, but in short: use x in your call to f(.) though it does not use any object named x in the local or other environment, it is just a placeholder. If you prefer, you can change to xname="input" and demo_fcn(f(input,factor=2),...) for the same effect, but realize that in that call, input is still a placeholder, not a reference to an object.

Change a function to a numeric value

I have a function called in the example fn_example_1 that needs to change with a parameter that comes from another function (n).
It needs to have a fixed part that never changes, and a variable part that gets longer with n, as an example:
# this is the function that needs to change
fn_example_1 <- function(x, mod) {
# -- this part is fixed
mod$a <- x^2 # fixed
# -- this part can change with n
mod$b[5,5, k] <- x + 1 # variable
mod$b[6, 6, k] <- x + 1 # variable
# mod$b[7,7, k] <- x + 1 # if n = 3 ecc..
# k is an arg from a third function, more on that later..
mod
}
This is what I have in mind, basically a wrapper function that gives back a different version of fn_example_1 that depens on n.
fn_wrap_example <- function(fn, n) {
# something
# something
# I've thought about a long if else, of course with a max value for n.
return(fn)
}
fn_wrap_example(fn_example_1, n = 2) # call to the wrapper
It is crucial that fn_wrap_example returns a function, this will be an argument to a third function. As a semplification n can have a max value, ie: 20.
The key is that fn_example_1 is a function that changes with n.
Here is how you can modify a function in your wrapper:
fn_factory <- function(n) {
fn <- function(x, mod) {
# -- this part is fixed
mod$a <- x^2 # fixed
x #place holder
# k is an arg from a third function, more on that later..
mod
}
ins <- switch(n,
"1" = quote(mod$b[5,5, k] <- x + 1),
"2" = quote(mod$b[6, 6, k] <- x + 1)
)
body(fn)[[3]] <- ins
return(fn)
}
fn_factory(2)
#function (x, mod)
#{
# mod$a <- x^2
# mod$b[6, 6, k] <- x + 1
# mod
#}
#<environment: 0x0000000008334eb8>
I seriously doubt you need this, but it can of course be done.
What you are looking for is called a closure.
https://www.r-bloggers.com/closures-in-r-a-useful-abstraction/
http://adv-r.had.co.nz/Functional-programming.html
Simple example:
power <- function(exponent) {
function(x) {
x ^ exponent
}
}
square <- power(2)
square(2)

Finding derivate of function in R

I am using R and trying to make an function by giving 2 parameters which are function and x, try to look for the answer of the function. But I kept getting error. I do not want to use any packages just solely R base.
Heres the Code so far.
test2 <- function(x) {
func <- expression(x)
der<- D(eval(func), 'x')
return(der(x))
}
test2(function(x) return(x^2))
I kept getting this error: "expression must not be type 'closure'"
Is there any way that I can structure of the function?
Here's a slight adjustment to get the derivation function working:
test2 <- function(x) D(parse(text=x), "x")
test2("sin(cos(x + y^2))")
# -(cos(cos(x + y^2)) * sin(x + y^2))
test2("x^2")
# 2 * x
test2("x^3")
# 3 * x^2
Use substitute to pass the expression to D:
test2 <- function(e, d) D(substitute(e), deparse(substitute(d)))
test2(sin(cos(x + y^2)), x)
#-(cos(cos(x + y^2)) * sin(x + y^2))
You cannot pass a function to D since it's designed for creating derivatives symbolically, which means it needs expressions containing simple functions known to D.
The function f returns a character vector, and string_der gives the derivative. (I used string manipulation inside since it seems you want to pass an argument.)
string_der <- function(x) {
D(parse(text = x), "x")
}
library(stringr)
f <- function(x) {
str <- "sin(cos(z + y^2))"
str <- str_replace(str, "z", x)
return(str)
}
string_der(f(x = "x"))
# -(cos(cos(x + y^2)) * sin(x + y^2))
I guess following is pretty much Adam Queck has done. It uses quote and let's you pass an object wrapped in quote.
quote_der <- function(x) {
D(eval(x), 'x')
}
f <- function(x) {
qt <- substitute(expression(sin(cos(z + y^2))), list(z = x))
return(qt)
}
quote_der(f(x = quote(x)))
#-(cos(cos(x + y^2)) * sin(x + y^2))
Assuming that:
the function passed as the argument has a one-line body and
if x is not specified it defaults to the name of the first argument to the input function
then we can write
test3 <- function(fun, x = names(formals(fun))[1]) D(body(fun), x)
test3(function(x) x^2)
## 2 * x

Substitute formal arguments in a function factory r

I'm trying to make a function factory to make functions with custom formal argument names. The idea is to supply a string to the factory, which in turn substitutes it both in the formals and in the body of the function returned. I've managed to do it using eval(parse(text=paste())) , but I read elsewhere that this bad practice. How can I get the same output while avoiding doing evalparse?
MyLinearRateFunctions<-function(varX){
eval(parse(text=paste("function(a,b,",
varX,
") 1/(a + b*",
varX,
")",sep="")
))
}
(LinearRateMPG<-MyLinearRateFunctions('mpg'))
# function(a,b,mpg) 1/(a + b*mpg)
# <environment: 0x11c2f2a00>
(LinearRateCYL<-MyLinearRateFunctions('cyl'))
# function(a,b,cyl) 1/(a + b*cyl)
# <environment: 0x11e4cb908>
(LinearRateDISP<-MyLinearRateFunctions('disp'))
# function(a,b,disp) 1/(a + b*disp)
# <environment: 0x11e47eae8>
There may be a more succinct way to get there, but here's one idea:
fn <- function(x) {
f <- eval(bquote(function(a, b) 1 / (a + b * .(as.name(x)))))
formals(f) <- c(formals(f), setNames(alist(dummy = ), x))
f
}
In the first line of fn(), we use bquote() to substitute x into the math expression. We need to evaluate that (with eval()) to turn it from a call into a function. Then in the second line, we add the third argument to the formal argument list. The final line returns the function.
fn("mpg")
# function (a, b, mpg)
# 1/(a + b * mpg)
# <environment: 0x4f05c78>
fn("cyl")
# function (a, b, cyl)
# 1/(a + b * cyl)
# <environment: 0x4f9ba28>
Quick check:
fn("mpg")(1, 2, 3)
# [1] 0.1428571
1 / (1 + 2 * 3)
# [1] 0.1428571
And THANK YOU for asking for a better alternative to eval(parse(text = ...)), it definitely is bad practice.
Here is an alternative which uses pryr::make_function. This has the added benefit of setting the function "environment" to the calling environment of the "function factory" call
fn2 <- function(x) {
fbody <- bquote(1 / (a + b * .(as.name(x))))
fargs <- setNames(alist(,,),c('a','b',x))
pryr::make_function(fargs,fbody, env=parent.frame(2))
}
While this looks like it avoids a call to eval, it is simply hidden within make_function
This uses only base R and no eval. First set up a function to use as a template and then change the formals, set up the body and set the environment.
factory <- function(x, envir = parent.frame()) {
fun <- function(a, b, x) {}
names(formals(fun))[[3]] <- x
body(fun) <- substitute(1/(a+b*x), list(x = as.name(x)))
environment(fun) <- envir
fun
}
# test
myfun <- factory("m")
giving:
> myfun
function (a, b, m)
1/(a + b * m)

Functions in R - using eval() and parse() to plot expressions in rgl

I am very new to R. I am trying to create a function where the user is able to input expressions into arguments. These inputs are then used in plot3d through the rgl package. The function I have so far is :
flight_sim <- function(xval, yval, zval)
{
# Evaluate arguments and convert them into expressions
eval(parse(text = zval))
z <- data.frame(zval)
eval(parse(text = xval))
x <- data.frame(xval)
eval(parse(text = yval))
y <- data.frame(yval)
flight_path <- as.data.frame(cbind(x,y,z))
}
I have a readline() and switch() command :
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
Where custom() just prompts the user via readline() to enter x, y and z values, which is then followed by eval() and parse() and it works fine.
The problem I've been having is that x and y need to be functions of z, and this causes an error :
Error in parse(text = xval) : object 'z' not found
I thought by making the flight_sim function evaluate the zval argument first that it would fix it, however as I'm new to R I'm just getting more and more lost.
I hope what I have explained here makes some sense. I appreciate any help that can be provided.
Nothing is being passed as text in your example so using parse() doesn't seem necessary. If you want to delay evaulation, the best way would be to use substitute to grab the parameters as promises and then evaluate them in the context of your fliht_sim function. Here's what that would look like
flight_sim <- function(xval, yval, zval) {
z <- eval(substitute(zval))
x <- eval(substitute(xval))
y <- eval(substitute(yval))
data.frame(x,y,z)
}
userplot="2"
x <- switch(userplot,"1"=flight_sim( sin(z), 1-cos(z), seq(0,20, pi/32) ),
"2"=flight_sim( z*cos(6*z), z*sin(6*z), seq(0,10, pi/64) ),
"3"=flight_sim( sin(z)*cos(20*z), sin(z)*sin(20*z), seq(0,pi,pi/399)),
"4"=custom())
head(x)
# x y z
# 1 0.00000000 0.00000000 0.00000000
# 2 0.04697370 0.01424932 0.04908739
# 3 0.08162934 0.05454298 0.09817477
# 4 0.09342212 0.11383519 0.14726216
# 5 0.07513972 0.18140332 0.19634954
# 6 0.02405703 0.24425508 0.24543693
If I'm interpreting your question correctly, it seems like you'd need to redefine your function. To the best of my knowledge, you can't define an argument in the function definition as a function of another argument. You'd need to do that inside the body of the function. So you'd want something like this:
flight_sim <- function(userplot) {
if (userplot == "1") {
z <- seq(0, 20, pi / 32)
x <- sin(z)
y <- 1 - cos(z)
} else if (userplot == "2") {
z <- seq(0, 10, pi / 64)
x <- z * cos(6 * z)
y <- z * sin(6 * z)
} else if (userplot == "3") {
z <- seq(0, pi, pi / 399)
x <- sin(z) * cos(20 * z)
y <- sin(z) * sin(20 * z)
} else if (userplot == "4") {
x <- readline("Please enter a function for the x-value: ")
y <- readline("Please enter a function for the y-value: ")
z <- readline("Please enter a function for the z-value: ")
eval(parse(text = z)) # have to evaluate z first since x and y are functions of z
eval(parse(text = x))
eval(parse(text = y))
} else {
valid_response <- FALSE
while (!valid_response) {
userplot <- readline("Please enter a valid response (1-4): ")
if (userplot %in% 1:4) {
valid_response <- TRUE
flight_sim(userplot)
}
}
}
dat <- data.frame(x, y, z)
return(dat)
}
cat('Select the flight path you wish to plot from the list below :
1. Helix
2. Conical
3. Spherical
4. Define your own flight path...')
userplot <- readline('Enter number here : ') # Allow user to enter choice from above
dat <- flight_sim(userplot)
head(dat)
x y z
1 0.000000000000000000 0.000000000000000000 0.000000000000000000
2 0.046973698885313400 0.014249315773629733 0.049087385212340517
3 0.081629338302900922 0.054542980081485989 0.098174770424681035
4 0.093422122547587999 0.113835185692147969 0.147262155637021552
5 0.075139716235543288 0.181403322008714424 0.196349540849362070
6 0.024057025623845932 0.244255080177979672 0.245436926061702587
In the code above, I've also included one last else statement to catch inappropriate responses from your users. If they enter a choice that could break your code, it will now catch that and ask them to reenter their response.

Resources