I am fairly new to programming in R and I am wondering why this does not work:
w <- c(1,0)
deriv(~x^2+y,c("x","y"),function.arg = TRUE)(w)
I really want to apply the function produced by deriv() on a variable w.
Maybe some background on how to deal with these kinds of "macros" might be helpful...
We can use do.call and pass the 'w' as a list of arguments
do.call(deriv(~x^2+y,c("x","y"),function.arg = TRUE), as.list(w))
Your function exposes two non-default parameters but you only pass one argument. Below would work, if this is your intention:
w <- c(1,0)
deriv( ~ x^2 + y, c("x","y"), function.arg = TRUE)(w, w)
# [1] 2 0
# attr(,"gradient")
# x y
# [1,] 2 1
# [2,] 0 1
Alternatively, set up a default parameter:
w <- c(1,0)
deriv( ~ x^2 + y, c("x","y"), function.arg = function(x, y=2){})(x=w)
# [1] 3 2
# attr(,"gradient")
# x y
# [1,] 2 1
# [2,] 0 1
# MORE READABLE VERSION WITH identity()
myfunc <- deriv( ~x^2 + y, c("x","y"), func = function(x, y=2) identity(x,y))
myfunc(x=w)
Related
I am trying to create a function for theoretical hessian matrix that I can then evaluate at different locations. First I tried setting expressions as values in a matrix or array, but although I could initially set an expression into a matrix I couldn't replace with the value calculated.
hessian_matrix <- function(gx, respect_to){
out_mat <- matrix(0, nrow=length(respect_to), ncol=length(respect_to))
for(i in 1:length(respect_to)){
for(j in 1:length(respect_to)){
dthetad2x <- deriv(D(gx, respect_to[i]), respect_to[j], function.arg=TRUE)
# also tried
# dthetad2x <- as.expression(D(D(gx, respect_to[i])))
out_mat[i,j] <- dthetad2x
}
return(out_mat)
}
Because that didn't work, I decided to create an environment to house the indeces of the hessian matrix as object.
hessian_matrix <- function(gx, respect_to){
out_env <- new.env()
for(i in 1:length(respect_to)){
for(j in 1:length(respect_to)){
dthetad2x <- as.call(D(D(gx, respect_to[i]), respect_to[j]))
assign(paste0(i,j), dthetad2x, out_env)
}
}
return(out_env)
}
g <- expression(x^3-2*x*y-y^6)
h_g <- hessian_matrix(g, respect_to = c('x', 'y'))
This worked, and when I pass this in as a parameter to evaluate I can see the expression, but I can't evaluate it. I tried with call(), eval(), do.call(), get(), etc. and it didn't work. I also assigning the answer within the environment passed, making a new environment to return, or simply using variables.
fisher_observed <- function(h, at_val, params, sum=TRUE){
out_env <- new.env()
# add params to passed environment
for(i in 1:length(at_val)){
h[[names(at_val)[i]]] <- unname(at_val[i])
}
for(i in ls(h)){
value <- do.call(i, envir=h, at_val)
assign(i, value, out_env)
}
return(h)
}
fisher_observed(h_g, at_val=list(x=1,y=2))
According the code for do.call() this is how it should be used, but it isn't working when passed as a parameter in this way.
R already has the hessian matrix function. You do not have to write one. You could use deriv or deriv3 as shown below:
g <- expression(x^3 - 2 * x * y - y^6)
eval(deriv3(g, c('x','y')),list(x=1,y=2))
[1] -67
attr(,"gradient")
x y
[1,] -1 -194
attr(,"hessian")
, , x
x y
[1,] 6 -2
, , y
x y
[1,] -2 -480
If you want to use a function, you could do:
hessian <- function(expr,values){
nms <- names(values)
f <- eval(deriv3(g, nms),as.list(values))
matrix(attr(f, 'hessian'), length(values), dimnames = list(nms,nms))
}
hessian(g, c(x=1,y=2))
x y
x 6 -2
y -2 -480
Although the function is not necessary as you would do double computation in case you wanted the gradient and hessian
I think this (almost) does what you're looking for:
fisher_observed <- function(h, at_val) {
values <- numeric(length = length(names(h)))
for (i in seq_len(length(names(h)))) {
values[i] = purrr::pmap(.l = at_val, function(x, y) eval(h[[names(h)[i]]]))
}
names(values) = names(h)
return(values)
}
This currently returns a named list of evaluated points:
$`21`
[1] -2
$`22`
[1] -480
$`11`
[1] 6
$`12`
[1] -2
you'd still need to re-arrange this into a matrix (should be fairly easy given the column names are preserved. I think the key thing is that the names must be characters when looking up values in h_g.
You cannot have a matrix of "calls" but you can have a character matrix then evaluate it:
hessian_matrix <- function(gx, respect_to){
out_mat <- matrix("", nrow=length(respect_to), ncol=length(respect_to))
for(i in 1:length(respect_to)){
for(j in 1:length(respect_to)){
dthetad2x <- D(D(gx, respect_to[i]), respect_to[j])
out_mat[i,j] <- deparse(dthetad2x)
}
}
return(out_mat)
}
g <- expression(x^3-2*x*y-y^6)
h_g <- hessian_matrix(g, respect_to = c('x', 'y'))
h_g
#> [,1] [,2]
#> [1,] "3 * (2 * x)" "-2"
#> [2,] "-2" "-(6 * (5 * y^4))"
apply(h_g, 1:2, \(x) eval(str2lang(x), list(x=1, y=2)))
#> [,1] [,2]
#> [1,] 6 -2
#> [2,] -2 -480
Using str() appears to change the evaluation why?
MWE:
f1 <- function(x, y = x) {
str(y)
x <- x + 1
y }
f1(1) # result is 1
f2 <- function(x, y = x) {
x <- x + 1
y }
f2(1) # result is 2
Why does this happen? I tried to use pryr library to debug but can not see the references being updated.
Lazy evaluation. It is about when y = x is evaluated. It is evaluated right before the first statement that uses y.
## f1
y <- x
str(y) ## first use of y
x <- x + 1
y
## f2
x <- x + 1
y <- x
y ## first use of y
Is there some equivalent to express let expressions in r? As an example take this simple haskell code:
let x = 1 in x + 1
Many thanks in advance.
One equivalent would be a lambda function, which you can define and call in a single statement:
(function(x) x+1)(x = 1)
The first () part defines a function, while the second () part calls that function, supplying the value of 1 for the argument named x.
Here are a few:
x <- 100
# 1
with(list(x = 1), x + 1)
## [1] 2
# 2
local(x + 1, list(x = 1))
## [1] 2
# 2a
local({
x <- 1
x + 1
})
## [1] 2
# 3
eval(substitute(x + 1, list(x = 1)))
## [1] 2
# 4
library(wrapr)
let(c(x = "1"),
x + 1,
subsMethod = "stringsubs",
strict = FALSE)
## [1] 2
x
## [1] 100
Also there is an open issue in the lambda.r package to add let.
If the intent of this is to make x only available in that expression, environments could offer this capability:
#make an environment
myenv <- new.env()
#assign 1 to variable x in our environment
myenv$x <- 1
#evaluate the expression within our environment
with(myenv, x + 1)
#[1] 2
#x only works within our created environment and not on the global environment
#(i.e. the default environment when working on the console)
x + 1
#Error: object 'x' not found
As per #Roland 's comment this can be shortened to local({x <- 1; x + 1}). See ?local.
One equivalent is a lambda function, whereby, you use the
implicit local({ }) within the function body
(this is a slightly improved answer of #ArtemSokolov's answer).
(function() {
x <- 1
x + 1
})()
This is equivalent to
local({
x <- 1
x + 1
})
Say I have a function for subsetting (this is just a minimal example):
f <- function(x, ind = seq(length(x))) {
x[ind]
}
(Note: one could use only seq(x) instead of seq(length(x)), but I don't find it very clear.)
So, if
x <- 1:5
ind <- c(2, 4)
ind2 <- which(x > 5) # integer(0)
I have the following results:
f(x)
[1] 1 2 3 4 5
f(x, ind)
[1] 2 4
f(x, -ind)
[1] 1 3 5
f(x, ind2)
integer(0)
f(x, -ind2)
integer(0)
For the last result, we would have wanted to get all x, but this is a common cause of error (as mentionned in the book Advanced R).
So, if I want to make a function for removing indices, I use:
f2 <- function(x, ind.rm) {
f(x, ind = `if`(length(ind.rm) > 0, -ind.rm, seq(length(x))))
}
Then I get what I wanted:
f2(x, ind)
[1] 1 3 5
f2(x, ind2)
[1] 1 2 3 4 5
My question is:
Can I do something cleaner and that doesn't need passing seq(length(x)) explicitly in f2 but using directly the default value of f's parameter ind when ind.rm is integer(0)?
If you anticipate having "empty" negative indices a lot, you can get a performance improvement for these cases if you can avoid the indexing used by x[seq(x)] as opposed to just x. In other words, if you are able to combine f and f2 into something like:
new_f <- function(x, ind.rm){
if(length(ind.rm)) x[-ind.rm] else x
}
There will be a huge speedup in the case of empty negative indices.
n <- 1000000L
x <- 1:n
ind <- seq(0L,n,2L)
ind2 <- which(x>n+1) # integer(0)
library(microbenchmark)
microbenchmark(
f2(x, ind),
new_f(x, ind),
f2(x, ind2),
new_f(x, ind2)
)
all.equal(f2(x, ind), new_f(x, ind)) # TRUE - same result at about same speed
all.equal(f2(x, ind2), new_f(x, ind2)) # TRUE - same result at much faster speed
Unit: nanoseconds
expr min lq mean median uq max neval
f2(x, ind) 6223596 7377396.5 11039152.47 9317005 10271521 50434514 100
new_f(x, ind) 6190239 7398993.0 11129271.17 9239386 10202882 59717093 100
f2(x, ind2) 6823589 7992571.5 11267034.52 9217149 10568524 63417978 100
new_f(x, ind2) 428 1283.5 5414.74 6843 7271 14969 100
What you have isn't bad, but if you want to avoid passing the default value of a default argument you could restructure like this:
f2 <- function(x, ind.rm) {
`if`(length(ind.rm) > 0, f(x,-ind.rm), f(x))
}
which is slightly shorter than what you have.
On Edit
Based on the comments, it seems you want to be able to pass a function nothing (rather than simply not pass at all), so that it uses the default value. You can do so by writing a function which is set up to receive nothing, also known as NULL. You can rewrite your f as:
f <- function(x, ind = NULL) {
if(is.null(ind)){ind <- seq(length(x))}
x[ind]
}
NULL functions as a flag which tells the receiving function to use a default value for the parameter, although that default value must be set in the body of the function.
Now f2 can be rewritten as
f2 <- function(x, ind.rm) {
f(x, ind = `if`(length(ind.rm) > 0, -ind.rm, NULL))
}
This is slightly more readable than what you have, but at the cost of making the original function slightly longer.
To implement "parameter1 = if(cond1) then value1 else default_value_of_param1", I used formals to get default parameters as a call:
f <- function(x, ind.row = seq_len(nrow(x)), ind.col = seq_len(ncol(x))) {
x[ind.row, ind.col]
}
f2 <- function(x, ind.row.rm = integer(0), ind.col.rm = integer(0)) {
f.args <- formals(f)
f(x,
ind.row = `if`(length(ind.row.rm) > 0, -ind.row.rm, eval(f.args$ind.row)),
ind.col = `if`(length(ind.col.rm) > 0, -ind.col.rm, eval(f.args$ind.col)))
}
Then:
> x <- matrix(1:6, 2)
> f2(x, 1:2)
[,1] [,2] [,3]
> f2(x, , 1:2)
[1] 5 6
> f2(x, 1, 2)
[1] 2 6
> f2(x, , 1)
[,1] [,2]
[1,] 3 5
[2,] 4 6
> f2(x, 1, )
[1] 2 4 6
> f2(x)
[,1] [,2] [,3]
[1,] 1 3 5
[2,] 2 4 6
A have a list that has the following structure.
mylist=list(y~ A,
y ~ A+B,
y ~ A+B+C)
I want to replace (recode) the “y “ with a “z”. my goal is
mylist=list(z~ A,
z ~ A+B,
z ~ A+B+C)
Q: How to replace (recode) values in a list?
I have tried this:
for i in range(len(mylist)):
mylist[i] = mylist[i].replace('y','z')
is not working
The update function is useful for formulas.
Just include a . to indicate any formula side to retain. So, for your problem the following is a quick one-liner.
lapply(mylist, update, new = z~.)
I would alternatively suggest to use R built in formulas manipulation functionality. This allows us to operate on different terms of a fromula separately without using regex
lapply(mylist, function(x) reformulate(as.character(terms(x))[3], "z"))
# [[1]]
# z ~ A
# <environment: 0x59c6040>
#
# [[2]]
# z ~ A + B
# <environment: 0x59c0308>
#
# [[3]]
# z ~ A + B + C
# <environment: 0x59bb7b8>
Since you have a list of formulas as a start, you can convert the formulas to characters, use gsub to do the replacement and convert it back to formula. Use env parameter to specify the environment of the formulas to make sure they are the same as original list:
lapply(mylist, function(f) formula(gsub("y", "z", format(f)), env = .GlobalEnv))
# [[1]]
# z ~ A
# [[2]]
# z ~ A + B
# [[3]]
# z ~ A + B + C
To take care of the concern of #David Arenburg, so that the replacement of y will always happen on the left side of the formula, we can use a more restricted regular expression:
lapply(mylist, function(f) formula(gsub("y(\\s)?(?=~)", "z", format(f), perl = T), env = .GlobalEnv))
# [[1]]
# z ~ A
# [[2]]
# z ~ A + B
# [[3]]
# z ~ A + B + C
Just like expressions, formulas have replaceable parts. So you could use [[<- to replace parts of the formula. The y value is the second in the expression list, as ~ is a function and hence the first.
lapply(mylist, "[[<-", 2, as.name("z"))
# [[1]]
# z ~ A
#
# [[2]]
# z ~ A + B
#
# [[3]]
# z ~ A + B + C