In an S3 generic function, I'd like to modify a function argument before calling NextMethod(). As a starting point, I looked through #44 of Henrik Bengtsson's "Wishlist for R". The following snippet is taken from there and corresponds to his suggestion on to how modify an argument before calling NextMethod().
x <- structure(NA, class = "A")
expected <- list(x = x, a = 3)
foo <- function(x, a) UseMethod("foo")
foo.A <- function(x, a) {
a <- a + 1
NextMethod()
}
foo.default <- function(x, a) {
list(x = x, a = a)
}
identical(foo(x, a = 2), expected)
#> [1] TRUE
identical(foo(x, 2), expected)
#> [1] TRUE
Now what has me stumped is the following behavior where the argument to be modified has a default value.
bar <- function(x, a) UseMethod("bar")
bar.A <- function(x, a = 2) {
a <- a + 1
NextMethod()
}
bar.default <- function(x, a = 2) {
list(x = x, a = a)
}
identical(bar(x, a = 2), expected)
#> [1] TRUE
identical(bar(x, 2), expected)
#> [1] TRUE
identical(bar(x), expected)
#> [1] FALSE
Can someone help me understand what is happening here? Any ideas on how to make the default argument case work (apart from an explicit call of bar.default())?
I'm not sure how realistic this set-up is, but the problem with it is that calling bar(x) means that you are calling bar.A(x), then (via NextMethod()) you are calling bar.default(x), rather than bar.default(x, a = 3) as you might expect.
The way round this is to specifically pass a as a parameter in NextMethod. The issue you will have with this is that if the user doesn't name the second parameter, then bar.default will throw because it is being given 3 parameters instead of two (x, 2 and a = 3). You can get round this by including a ... parameter in bar.default so that unnamed parameters are ignored.
x <- structure(NA, class = "A")
expected <- list(x = x, a = 3)
bar <- function(x, ...) UseMethod("bar")
bar.A <- function(x, a = 2) {
a <- a + 1
NextMethod("bar", x, a = a)
}
bar.default <- function(x, ..., a = 2) {
list(x = x, a = a)
}
identical(bar(x, a = 2), expected)
#> [1] TRUE
identical(bar(x, 2), expected)
#> [1] TRUE
identical(bar(x), expected)
#> [1] TRUE
Created on 2020-04-02 by the reprex package (v0.3.0)
Related
This is really a mystery for me. I have defined my method like this (for class "graf"):
addStatistics <- function(x) UseMethod("addStatistics")
addStatistics.graf <- function (x, stat_name = NULL, value = NULL)
{
if (stat_name == "env_coef_delta_mnll") {
x$env_coef_delta_mnll <- value
}
x
}
I am calling the method like this, and getting an error:
addStatistics(m, "env_coef_delta_mnll", 0)
#Error in addStatistics(m, "env_coef_delta_mnll", 0) :
# unused arguments ("env_coef_delta_mnll", 0)
Why the method doesn't accept those supplied arguments and says they are "unused"?
Here is a way of solving the problem. Apparently you are creating a setter function, so I will change the generic a bit.
`addStatistics<-` <- function(x, ...) UseMethod("addStatistics<-")
`addStatistics<-.graf` <- function (x, stat_name = NULL, value = NULL)
{
if (stat_name == "env_coef_delta_mnll") {
x$env_coef_delta_mnll <- value
}
x
}
as.graf <- function(x){
class(x) <- "graf"
x
}
x <- as.graf(list())
addStatistics(x, "env_coef_delta_mnll") <- 1234
x
#$env_coef_delta_mnll
#[1] 1234
#
#attr(,"class")
#[1] "graf"
#GGrothendieck beat me to the punch, but here's a reprex to prove it;
addStatistics <- function(...) UseMethod("addStatistics")
addStatistics.graf <- function (x, stat_name, value)
{
if(!missing(stat_name)){
if (stat_name == "env_coef_delta_mnll") {
x$env_coef_delta_mnll <- value
}}
x
}
m <- list(env_coef_delta_mnll = 3)
class(m) <- "graf"
addStatistics(m, stat_name = "env_coef_delta_mnll", 4)
#> $env_coef_delta_mnll
#> [1] 4
#>
#> attr(,"class")
#> [1] "graf"
Created on 2020-02-20 by the reprex package (v0.3.0)
My goal is to create the following function using code:
s <- c(x = 10)
a <- c(i = 3)
model <- function(s, a) {
with(as.list(c(s, a)), {
y <- x * i
y * 10
})
}
model(s, a)
The result should be 300.
I'm parsing another software, and I can extract the equations from that software as strings. So, I need to construct the function's body from those strings.
I've been trying to use rlang library to no avail.
library(rlang)
func_body <- "with(as.list(c(s, a)), {
y <- x * i
y * 10
})";
foo <- new_function(
exprs(s =, a = ),
expr(!!parse(text = func_body))
)
Any idea?
Not sure your motivation for using new_function here but this gives your expected output:
library(rlang)
s <- (x = 10)
a <- (i = 3)
foo <- new_function(
args = pairlist2(s =, a =),
body = expr(
with(as.list(c(s, a)), {
y <- x * i
y * 10
})
)
)
foo(s, a)
#[1] 300
If the body is a string use parse_expr:
foo2 <- new_function(
args = pairlist2(s =, a =),
body = parse_expr(
"with(as.list(c(s, a)), {
y <- x * i
y * 10
})"
)
)
foo2(s, a)
#[1] 300
With base R you can do :
foo <- function(s, a){}
body(foo) <- parse(text=func_body)
foo(s, a)
#> [1] 300
An alternative way, still in base R would be:
foo <- as.function(c(alist(s=,a=), parse(text=func_body)[[1]]))
foo(s, a)
#> [1] 300
As a side note, in your example the values of s and a are not use at all, you're just using the values of x and i from the global workspace. You might want :
# cleanup
rm(s,a,x,i)
s <- c(x = 10)
a <- c(i = 3)
foo(s, a)
#> [1] 300
Hi so I have the following function:
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
I'd like to vectorize this without using any for loops or apply statements, can't seem to get around doing so. Help would be appreciated. Thanks.
EDIT: Given the responses, here are my answers to the questions posed.
Given requests for clarification, I will elaborate on the function inputs and on the user defined function inside the function given. So X here is a dataset in the form of a vector, specifically, a vector of length 7 in the dataset I used as an input to this function. The X I used this function for is c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041). s is a single scalar point set at 0.2 for the use of this function. kde is a user - defined function that I wrote. Here is the implementation:
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
in this function, X is the same vector of data points used in kde.cv. s is also the same scalar value of 0.2 used in kde.cv. x is a vector of evaluation points for the function, I used seq(-2.5, -0.5, by = 0.1).
Here is an option using sapply
kde.cv = function(X,s)
sum(sapply(1:length(X), function(i) log(kde(X[i], X[-i], s))))
For convenience, please provide a more complete example. For example, the kde() function. Is that a customized function?
Alternative to sapply, you can try Vectorize(). There are some examples you can find on stack overflow.
Vectorize() vs apply()
Here is an example
f1 <- function(x,y) return(x+y)
f2 <- Vectorize(f1)
f1(1:3, 2:4)
[1] 3 5 7
f2(1:3, 2:4)
[1] 3 5 7
and the second example
f1 <- function(x)
{
new.vector<-c()
for (i in 1:length(x))
{
new.vector[i]<-sum(x[i] + x[-i])
}
return(sum(new.vector))
}
f2<-function(x)
{
f3<-function(y, i)
{
u<-sum(y[i]+y[-i])
return(u)
}
f3.v<-Vectorize(function(i) f3(y = x, i=i))
new.value<-f3.v(1:length(x))
return(sum(new.value))
}
f1(1:3)
[1] 24
f2(1:3)
[1] 24
Note: Vectorize is a wrapper for mapply
EDIT 1
According to the response, I edited your kde.cv function.
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
##### Vectorize kde.cv ######
kde.cv.v = function(X,s)
{
log.fhat.vector = c()
kde.v<-Vectorize(function(i) kde(X[i], X[-i], s))
CV.score <- sum(log(kde.v(1:length(X))))
return(CV.score)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
x<-seq(-2.5, -0.5, by = 0.1)
kde.cv(X, s)
[1] -10.18278
kde.cv.v(X, s)
[1] -10.18278
EDIT 2
Well, I think the following function may match your requirement. BTW, since the little x is not used in your kde.cv, I just edited both two functions
kde.cv.2 <- function(X,s)
{
log.fhat.vector<-log(kde.2(X, s))
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde.2<-function(X, s)
{
l <- length(X)
b <- matrix(rep(X, l), l, l, byrow = T)
c <- X - b
diag(c) <- NA
phi.matrix <- dnorm(c, 0, s)
d <- rowMeans(phi.matrix, na.rm = T)
return(d)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
kde.cv(X,s)
[1] -10.18278
kde.cv.2(X, s)
[1] -10.18278
This question refers to "Programming with dplyr"
I want to slice the ... argument of a function and use each element as an argument for a corresponding function.
foo <- function(...){
<some code>
}
should evaluate for example foo(x, y, z) in this form:
list(bar(~x), bar(~y), bar(~z))
so that x, y, z remain quoted till they get evaluated in bar.
I tried this:
foo <- function(...){
arguments <- quos(...)
out <- map(arguments, ~bar(UQ(.)))
out
}
I have two intentions:
Learn better how tidyeval/rlang works and when to use it.
turn future::futureOf() into a function that get me more then one futures at once.
This approach might be overly complicated, because I don't fully understand the underlying concepts of tidyeval yet.
You don't really need any packages for this. match.call can be used.
foo <- function(..., envir = parent.frame()) {
cl <- match.call()
cl$envir <- NULL
cl[[1L]] <- as.name("bar")
lapply(seq_along(cl)[-1], function(i) eval(cl[c(1L, i)], envir))
}
# test
bar <- function(...) match.call()
foo(x = 1, y = 2, z = 3)
giving:
[[1]]
bar(x = 1)
[[2]]
bar(y = 2)
[[3]]
bar(z = 3)
Another test
bar <- function(...) ..1^2
foo(x = 1, y = 2, z = 3)
giving:
[[1]]
[1] 1
[[2]]
[1] 4
[[3]]
[1] 9
This is an extension of Using callNextMethod() within accessor function in R.
Update 2017-03-25: To illustrate how this only fails when loading the methods, but not when it's in a built package, I created a dummy package: https://github.com/zkamvar/inheritest#readme
Basic problem:
I have a class bar that inherits another class foo, and both of them have additional arguments for the [ method. The method for foo works consistently, but the method for bar fails after the first use.
Error and Traceback:
Error in callNextMethod(x, i, j, ..., drop): bad object found as method (class "function")
4: stop(gettextf("bad object found as method (class %s)", dQuote(class(method))),
domain = NA)
3: callNextMethod(x, i, j, ..., drop) at #9
2: .local(x, i, j, ..., drop = drop)
1: BAR["x"]
Further details:
I have a package that implements a class that depends on a class from another package. When the packages are built, everything works fine, but when my package is simply loaded (using devtools::load_all(".")), I get the behavior below.
Minimum Working Example:
foo <- setClass("foo", representation(x = "numeric", y = "numeric"))
bar <- setClass("bar", representation(distance = "numeric"), contains = "foo")
setMethod(f = "[", signature = signature(x = "foo", i = "ANY", j = "ANY", drop = "ANY"),
definition = function(x, i, j, ..., foo = TRUE, drop = FALSE) {
if (foo)
message("FOOOOOOO")
if (i == "x") {
return(x#x)
} else {
if (i == "y") {
return(x#y)
}
}
})
#> [1] "["
setMethod(f = "[", signature = signature(x = "bar", i = "ANY", j = "ANY", drop = "ANY"),
definition = function(x, i, j, ..., bar = TRUE, drop = FALSE) {
if (bar)
message("BAAAAAAR")
if (i == "distance") {
return(x#distance)
} else {
callNextMethod(x, i, j, ..., drop)
}
})
#> [1] "["
FOO <- new("foo", x = 1, y = 4)
BAR <- new("bar", x = 1, y = 4, distance = 3)
FOO["x"]
#> FOOOOOOO
#> [1] 1
BAR["x"]
#> BAAAAAAR
#> FOOOOOOO
#> [1] 1
FOO["x"]
#> FOOOOOOO
#> [1] 1
BAR["distance"]
#> BAAAAAAR
#> [1] 3
BAR["x"] # fails
#> BAAAAAAR
#> Error in callNextMethod(x, i, j, ..., drop): bad object found as method (class "function")
BAR["x", foo = FALSE]
#> BAAAAAAR
#> [1] 1
Note: when I passed this through reprex, The first and last calls to BAR resulted in errors as well, but I am showing what I experience in an interactive session. I am using R version 3.3.3
This is because callNextMethod() is not smart enough to handle methods on primitives with augmented formals. I've fixed it and will commit to trunk soon.
Here's a partial answer: it is to do with "[" specifically. Here is some working code, that replaces the '[' method with a 'bat' method. It works fine for me:
foo <- setClass("foo", representation(x = "numeric", y = "numeric"))
bar <- setClass("bar", representation(distance = "numeric"), contains = "foo")
bat <- function (x, i, j, ..., drop = FALSE) message('in bat')
setGeneric('bat')
setMethod(f = "bat", signature = signature(x = "foo"),
definition = function(x, i, j, ..., foo = TRUE, drop = FALSE) {
if (foo)
message("FOOOOOOO")
if (i == "x") {
return(x#x)
} else {
if (i == "y") {
return(x#y)
}
}
})
#> [1] "["
setMethod(f = "bat", signature = signature(x = "bar"),
definition = function(x, i, j, ..., bar = TRUE, drop = FALSE) {
if (bar)
message("BAAAAAAR")
if (i == "distance") {
return(x#distance)
} else {
callNextMethod(x, i, j, ..., drop)
}
})
FOO <- new("foo", x = 1, y = 4)
BAR <- new("bar", x = 1, y = 4, distance = 3)
bat(FOO, 'x')
bat(BAR, 'distance')
bat(BAR, 'x')
And now:
bat(FOO, 'x')
FOOOOOOO
[1] 1
bat(BAR, 'x')
BAAAAAAR
FOOOOOOO
[1] 1
bat(BAR, 'distance')
BAAAAAAR
[1] 3
bat(BAR, 'x')
BAAAAAAR
FOOOOOOO
[1] 1
So, I think this is something to do with the interaction of S4 dispatch and ['s own dispatching... and solutions? I have none, except to avoid S4 like the plague it seems to be. Maybe R-devel can help. It's possible this is a genuine R bug, given that the code only breaks for [.
The issue has likely to do with the fact that [ is a primitive, and primitives are dealt with differently when using S4. Digging into callNextMethod shows that the callstack isn't analyzed correctly in the case that the method has different arguments compared to the generic for that primitive function. If you drop the argument bar from the method definition, dispatching works correctly.
That said, there is another workaround that doesn't require you to choose another function name. I add an extra function as.foo and recall the generic after converting to a foo object:
setGeneric("as.foo", function(x)standardGeneric("as.foo"))
setMethod("as.foo", signature = "bar",
function(x)
new("foo", x = x#x, y = x#y))
setMethod(f = "[", signature = signature(x = "bar", i = "ANY", j = "ANY", drop = "ANY"),
definition = function(x, i, j, ..., bar = TRUE, drop = FALSE) {
if (bar)
message("BAAAAAAR")
if (i == "distance") {
return(x#distance)
} else {
x <- as.foo(x)
callGeneric()
}
}
)
This way you circumvent the hiccup in dispatching, and all the code that used to fail now works
FOO["x"]
#> FOOOOOOO
#> [1] 1
BAR["x"]
#> BAAAAAAR
#> FOOOOOOO
#> [1] 1
BAR["distance"]
#> BAAAAAAR
#> [1] 3
BAR["x"]
#> BAAAAAAR
#> FOOOOOOO
#> [1] 1
BAR["x", foo = FALSE]
#> BAAAAAAR
#> [1] 1