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)
I have a character string:
FUN.n = "exp( 3 * x^2 + 2 * x + 1)";
I want to cast it as a function:
myFunction = castAsFunction ( FUN.n );
So that I can access it like:
myFunction(x)
and it will evaluate appropriately.
FUN.n = "exp( 3 * x^2 + 2 * x + 1)";
myFunction = castAsFunction ( FUN.n );
# [...]
myFunction = function(x)
{
exp( 3 * x^2 + 2 * x + 1);
}
x = -3:3;
myFunction(x);
# [1] 3.6e+09 8.1e+03 7.4e+00 2.7e+00 4.0e+02 2.4e+07 5.8e+14
I have tried as.function and eval(parse(text and none of them behave as I would expect.
I am looking for a variadic solution.
We could actually create a function called castAsFunction. We would need to give it not only a string as function body, but also the formal arguments. It feels like the function could be simplified, but it works with the example above.
FUN.n = "exp( 3 * x^2 + 2 * x + 1)"
x = -3:3
castAsFunction <- function(body, ...) {
dots <- match.call(expand.dots = FALSE)$...
form_ls <- rep(list(bquote()), length(dots))
names(form_ls) <- as.character(dots)
f <- function(){}
formals(f) <- form_ls
body(f) <- str2lang(body)
environment(f) <- parent.frame()
f
}
myfun <- castAsFunction(FUN.n, x)
myfun
#> function (x)
#> exp(3 * x^2 + 2 * x + 1)
myfun(x)
#> [1] 3.584913e+09 8.103084e+03 7.389056e+00 2.718282e+00 4.034288e+02
#> [6] 2.415495e+07 5.834617e+14
Created on 2021-02-18 by the reprex package (v0.3.0)
Is there any function or method that coerces a function object into an expression in R?
Suppose I have u = function (x, y) 2 * x^0.8 * y^0.2. What I would like to achieve is convert u into a call or expression object. Example, 2 * x^0.8 * y^0.2 with mode(.) == 'call' or expression(2 * x^0.8 * y^0.2)
I know that you can do something like:
str2lang(deparse(u)[[2]])
2 * x^0.8 * y^0.2
deparse can still be made to work for cases when functions have several lines.
ff = function(x, y) {
x = x + 1
y = y + 1
return(x+y)
}
str2lang(paste(deparse(ff)[-1], collapse='\n'))
{
x = x + 1
y = y + 1
return(x + y)
}
Is there a better way already implemented in R?
Use body. No packages are used.
b <- body(ff)
# test
eval(b, list(x = 3, y = 10))
## [1] 15
# compare to ff
ff(x = 3, y = 10)
## [1] 15
Not sure why I am getting a non-numeric argument binary operator error. Do I have some type mismatch going on?
for (j in 1:length(theta)) {
val = exp(y * sum(theta * random_data_vector) * y * random_data_vector[i])
val = val / (1 + exp(y * sum(theta * random_data_vector)))
theta[j] = theta[j] - (alpha * val)
}
Error:
Error in theta * random_data_vector :
non-numeric argument to binary operator
Values:
> head(theta)
[1] 0.02435863 -0.74310189 -0.63525839 0.56554085 -0.20599967 0.43164130
> head(random_data_vector)
[1] 0 0 0 0 0 0
> y
V9437
785 1
After FIRST iteration of for loop, theta looks like this:
> head(theta)
[[1]]
[1] NA
[[2]]
[1] -0.2368957
[[3]]
[1] 0.697332
[[4]]
[1] 0.6104201
[[5]]
[1] 0.8182983
[[6]]
[1] 0.7093492
For more information, the above is a snippet from my entire function I am trying to create around stochastic gradient descent.
data is a set of rows grabbed from a CSV
labels is 1 row grabbed from a CSV
alpha is a float
mnist = read.csv('mnist_train.csv', header=FALSE)
data = mnist[,mnist[nrow(mnist),]==0 | mnist[nrow(mnist),]==1, drop=FALSE]
labels = data[785,]
data = data[1:784,]
train = function(data, labels, alpha) {
theta = runif(nrow(data),-1,1)
decay_rate = .01
random_column_indexes = sample(ncol(data))
idx = 1
limit = length(random_column_indexes)
threshold = 1e-5
delta = 1000000
for (n in 1:ncol(data)) {
if (delta <= threshold) {
break
}
i = random_column_indexes[n]
random_data_vector = data[, i]
y = labels[i]
previous_theta = theta
for (j in 1:length(theta)) {
val = exp(y * sum(theta * random_data_vector) * y * random_data_vector[i])
val = val / (1 + exp(y * sum(theta * random_data_vector)))
theta[j] = theta[j] - (alpha * val)
}
alpha = alpha - decay_rate
delta = abs(previous_theta - theta)
}
return(theta)
}
I consider that the problem has to do with the subsetting of your objects. From the link you provided in the comments I see that your data is a data.frame object and you subset it using [. If you check the type of any data.frame e.g. typeof(iris) you can see that it is a "list".
When you use y = labels[i], your object will be a list, that's because:
when [ is applied to a list it always returns a list: it never gives you the contents of the list. To get the contents, you need [[ Advanced R by Hadley Wickham
Declare y as y <- labels[[i]] or subset labels from your data.frame as a vector doing as.numeric(data[785,])
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)),")" )))
}