I am trying to update a call for a new function I developed with a new class. The developing is pretty similar to linmod found in Leish's article "Creating R packages".
Inside the function, the call is stored with match.call().
When I try to update the call, as follows:
library(MASS)
fit <- linmod(Hwt~Bwt*Sex, data=cats)
update(fit, subset = -1)
I got the following error message:
Error in eval(expr, envir, enclos) :
could not find function "linmod.formula"
The problem seems to be that match.call() saves the full S3 method name (linmod.formula), instead of just the generic function name (linmod), which would work perfectly.
Anyone could help me how to solve this problem?
The easiest way I know for fixing this is exporting the method. For this, you need to add #export linmod.formula. Of course, it is generally not recommended to export methods.
Another option is creating a method for update. The following is a copy of update.default with one additional line:
#' #export
update.linmod <- function (object, formula., ..., evaluate = TRUE)
{
if (is.null(call <- getCall(object)))
stop("need an object with call component")
extras <- match.call(expand.dots = FALSE)$...
#call generic instead of method:
call[[1]] <- quote(linmod)
if (!missing(formula.))
call$formula <- update.formula(formula(object), formula.)
if (length(extras)) {
existing <- !is.na(match(names(extras), names(call)))
for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
if (any(!existing)) {
call <- c(as.list(call), extras[!existing])
call <- as.call(call)
}
}
if (evaluate)
eval(call, parent.frame())
else call
}
I dislike both options and would avoid having methods for the linmod function. Your default method seems useless to me. Note how, e.g., lm is not an S3 generic.
PS: update doesn't have a subset parameter.
Since this hasn't been mentioned here yet, and it is the approach explicitly recommended in ?update: write a method for getCall. From ?update:
“Extracting the call” in update() and similar functions uses getCall() which itself is a (S3) generic function with a default method that simply gets x$call. Because of this, update() will often work (via its default method) on new model classes, either automatically, or by providing a simple getCall() method for that class.
So, in your package, if you have:
#' #export
f <- function(x) {
UseMethod("f")
}
#' #export
f.bar <- function(x) {
structure(list(x = x, call = match.call()), class = "fbar")
}
#' #export
#' #importFrom stats getCall
getCall.fbar <- function(x) {
x$call[[1L]] <- quote(f) # replacing `f.bar`
x$call
}
Then, in your script, you could do:
x1 <- structure(1, class = "bar")
x2 <- structure(2, class = "bar")
fx1 <- f(x = x1)
fx2 <- update(fx1, x = x2)
fx1
# $x
# [1] 1
# attr(,"class")
# [1] "bar"
#
# $call
# f.bar(x = x1)
#
# attr(,"class")
# [1] "fbar"
fx2
# $x
# [1] 2
# attr(,"class")
# [1] "bar"
#
# $call
# f.bar(x = x2)
#
# attr(,"class")
# [1] "fbar"
Related
I am trying to inspect the internal objects produced by a R function such as the example below:
myfunction <- function(arg1, arg2){
sum.both <- arg1+arg2
diff.both <- arg1-arg2
return(diff.both)
}
I am aware that I can bring it to the working environment by modifying the function itself:
myfunction.mod <- function(arg1, arg2){
sum.both <- arg1+arg2
sum.both <<- sum.both
diff.both <- arg1-arg2
return(diff.both)
}
myfunction.mod(1,2)
By doing that I can see the sum.both object by typing ls() in the console. However, I am looking for a way to get such internal objects from any existing function. Therefore, I tried debug() and environment() without success. Any ideas or directions on how to obtain internal objects from a function would be appreciated.
I guess one easy way to modify an existing function is to use the trace() debugging tool. We can use that to insert code that will run at exit of a function to "leak" all the values from the function scope into the global scope. Here's such a function
make_leaky <- function(f) {
fn <- substitute(f)
invisible(trace(fn, print=FALSE, exit=quote(list2env(mget(ls()), globalenv()))))
}
Then we can test it with the following function
foo <- function(x, y) {
a <- x+7
b <- x*y
b/a
}
We will use ls() to see all the variables at each step
ls()
# [1] "foo" "make_leaky"
foo(5,2)
# [1] 0.8333333
ls() # NO NEW VARIABLES CREATED HERE
# [1] "foo" "make_leaky"
make_leaky(foo)
foo(5,2)
# [1] 0.8333333
ls() # ALL VARIABLES FROM FOO ARE NOW IN GLOBAL ENV
# [1] "a" "b" "foo" "make_leaky"
# [5] "x" "y"
Given a call to a function bar::foo(), I would like to be able to programmatically switch the package bar so that the same syntax calls hello::foo().
An example:
Let's say I have three packages, parentPkg, childPkg1 and childPkg2.
In parentPkg I have a call to function childPkg1::foo()
foo() is also a function in childPkg2
I would like to be able, in parentPkg to use the :: operator to call foo() but to programatically switch the package name.
Something like:
dummy_pkg_name = ifelse(scenario=="child1", "childPkg1", "childPkg2")
dummy_pkg_name::foo()
Is it possible? How do I achieve it?
Some context
parentPkg is a function that interacts with a web application, takes some request and data and returns results from different statistical models depending on the scenarios.
Each scenario is quite complex and not everything can be generalised in parentPkg. For this reason, childPkg1 and childPkg2 (actually there are also 3 and 4) are sort of sub-packages that deals with the data cleaning and various alternatives for each scenario but return the same class of value.
The idea is that parentPkg would switch the package to the pertinent child depending on the scenario and call all of the necessary functions without having to write the same sequence for each child but just with a slightly different :: call.
Since :: can be seen as a function, it looks like
`::`(dummy_pkg_name, foo)()
is what you want. Alternatively,
getFromNamespace("foo", ns = dummy_pkg_name)()
For instance,
`::`(stats, t.test)
# function (x, ...)
# UseMethod("t.test")
# <bytecode: 0x102fd4b00>
# <environment: namespace:stats>
getFromNamespace("t.test", ns = "stats")
# function (x, ...)
# UseMethod("t.test")
# <bytecode: 0x102fd4b00>
# <environment: namespace:stats>
To adhere to KISS, simply re-assign to new named functions in global environment. Be sure to leave out () since you are not requesting to run the function.
parent_foo <- parentPkg::foo
child1_foo <- childPkg1::foo
child2_foo <- childPkg2::foo
child3_foo <- childPkg3::foo
Then, conditionally apply them as needed:
if (scenario=="child1") {
obj <- child1_foo(...)
}
else if (scenario=="child2") {
obj <- child2_foo(...)
}
...
You could also create a call() that could then be evaluated.
call("::", quote(bar), quote(foo()))
# bar::foo()
Put into use:
c <- call("::", quote(stats), quote(t.test))
eval(c)
# function (x, ...)
# UseMethod("t.test")
# <bytecode: 0x4340988>
# <environment: namespace:stats>
Wrapped up in a function using setdiff as our default function:
f <- function(pkg, fn = setdiff) {
pkg <- substitute(pkg)
fn <- substitute(fn)
eval(call("::", pkg, fn))
}
f(base)
# function (x, y)
# {
# x <- as.vector(x)
# y <- as.vector(y)
# unique(if (length(x) || length(y))
# x[match(x, y, 0L) == 0L]
# else x)
# }
# <bytecode: 0x30f1ea8>
# <environment: namespace:base>
f(dplyr)
# function (x, y, ...)
# UseMethod("setdiff")
# <environment: namespace:dplyr>
I have a generic function foo that I want to call three different ways depending on the arguments given to it.
foo <- function(...) UseMethod("foo")
#default
foo.default <- function(x, y, ...) {
#does some magic
print("this is the default method")
}
#formula
foo.formula <- function(formula, data = list(), ...) {
print("this is the formula method")
}
#data.frame
foo.data.frame <- function(data, x, y, ...) {
print("this is the data.frame method")
}
In the following I'm going to show how I am expecting the method dispatch to work but the outputs are presented under each call...
mydata <- data.frame(x=c(1,2,3,4),y=c(5,6,7,8))
#ways to call default function
foo(x = mydata$x, y = mydata$y)
#[1] "this is the default method"
#ways to call formula
foo(formula = mydata$x~mydata$y)
#[1] "this is the formula method"
foo(formula = x~y, data = mydata)
#[1] "this is the formula method"
foo(data = mydata, formula = x~y) #ERROR
#[1] "this is the data.frame method"
#ways to call data.frame method
foo(data = mydata, x = x, y = y)
#[1] "this is the data.frame method"
foo(x = x, y = y, data = mydata) #ERROR
#Error in foo(x = x, y = y, data = mydata) : object 'x' not found
from what I can tell, the method used depends on the class of the first argument. Essentially, I would like for the method dispatch to depend on the arguments passed to the generic function foo and not the first argument.
I would like the dispatch to have the following priority:
If the formula argument is present the formula method is used (data argument should be optional here)
Then, if no formula argument is found, if data argument is present use data.frame method (which requires x and y arguments)
else foo expects the x and y arguments or it will fail.
Note
I would like to avoid defining the generic function foo as follows
foo <- function(formula, data,...) UseMethod("foo")
while this would fix all my issues (I believe all except the last case), this will cause a devtools::check() warning because the some of S3 functions will not have the same arguments as the generic function and will no longer be consistent (specifically foo.default and foo.data.frame). And I wouldn't like to include the missing arguments because those methods do not have use for those arguments.
As Thomas has pointed out, this is not the standard behavior for S3 classes. If you really want to stick to S3, however, you could write your functions so as to "mimick" UseMethod, even though it won't be pretty and is probably not what you want to do. Nevertheless, here an idea that is based on capturing all arguments first, and then checking for the presence of your "preferred" argument type:
Get some objects first:
a <- 1; class(a) <- "Americano"
b <- 2; class(b) <- "Espresso"
Let the function in question capture all arguments with dots, and then check for the presence of an argument type in order of your preference:
drink <- function(...){
dots <- list(...)
if(any(sapply(dots, function(cup) class(cup)=="Americano"))){
drink.Americano(...)
} else { # you can add more checks here to get a hierarchy
# try to find appropriate method first if one exists,
# using the first element of the arguments as usual
tryCatch(get(paste0("drink.", class(dots[[1]])))(),
# if no appropriate method is found, try the default method:
error = function(e) drink.default(...))
}
}
drink.Americano <- function(...) print("Hmm, gimme more!")
drink.Espresso <- function(...) print("Tripple, please!")
drink.default <- function(...) print("Any caffeine in there?")
drink(a) # "Americano", dispatch hard-coded.
# [1] "Hmm, gimme more!"
drink(b) # "Espresso", not hard-coded, but correct dispatch anyway
# [1] "Tripple, please!"
drink("sthelse") # Dispatches to default method
# [1] "Any caffeine in there?"
drink(a,b,"c")
# [1] "Hmm, gimme more!"
drink(b,"c", a)
# [1] "Hmm, gimme more!"
I know about methods(), which returns all methods for a given class. Suppose I have x and I want to know what method will be called when I call foo(x). Is there a oneliner or package that will do this?
The shortest I can think of is:
sapply(class(x), function(y) try(getS3method('foo', y), silent = TRUE))
and then to check the class of the results... but is there not a builtin for this?
Update
The full one liner would be:
fm <- function (x, method) {
cls <- c(class(x), 'default')
results <- lapply(cls, function(y) try(getS3method(method, y), silent = TRUE))
Find(function (x) class(x) != 'try-error', results)
}
This will work with most things but be aware that it might fail with some complex objects. For example, according to ?S3Methods, calling foo on matrix(1:4, 2, 2) would try foo.matrix, then foo.numeric, then foo.default; whereas this code will just look for foo.matrix and foo.default.
findMethod defined below is not a one-liner but its body has only 4 lines of code (and if we required that the generic be passed as a character string it could be reduced to 3 lines of code). It will return a character string representing the name of the method that would be dispatched by the input generic given that generic and its arguments. (Replace the last line of the body of findMethod with get(X(...)) if you want to return the method itself instead.) Internally it creates a generic X and an X method corresponding to each method of the input generic such that each X method returns the name of the method of the input generic that would be run. The X generic and its methods are all created within the findMethod function so they disappear when findMethod exits. To get the result we just run X with the input argument(s) as the final line of the findMethod function body.
findMethod <- function(generic, ...) {
ch <- deparse(substitute(generic))
f <- X <- function(x, ...) UseMethod("X")
for(m in methods(ch)) assign(sub(ch, "X", m, fixed = TRUE), "body<-"(f, value = m))
X(...)
}
Now test it. (Note that the one-liner in the question fails with an error in several of these tests but findMethod gives the expected result.)
findMethod(as.ts, iris)
## [1] "as.ts.default"
findMethod(print, iris)
## [1] "print.data.frame"
findMethod(print, Sys.time())
## [1] "print.POSIXct"
findMethod(print, 22)
## [1] "print.default"
# in this example it looks at 2nd component of class vector as no print.ordered exists
class(ordered(3))
## [1] "ordered" "factor"
findMethod(print, ordered(3))
## [1] "print.factor"
findMethod(`[`, BOD, 1:2, "Time")
## [1] "[.data.frame"
I use this:
s3_method <- function(generic, class, env = parent.frame()) {
fn <- get(generic, envir = env)
ns <- asNamespace(topenv(fn))
tbl <- ns$.__S3MethodsTable__.
for (c in class) {
name <- paste0(generic, ".", c)
if (exists(name, envir = tbl, inherits = FALSE)) {
return(get(name, envir = tbl))
}
if (exists(name, envir = globalenv(), inherits = FALSE)) {
return(get(name, envir = globalenv()))
}
}
NULL
}
For simplicity this doesn't return methods defined by assignment in the calling environment. The global environment is checked for convenience during development. These are the same rules used in r-lib packages.
The function testfun1, defined below, does what I want it to do. (For the reasoning of all this, see the background info below the code example.) The question I wanted to ask you is why what I tried in testfun2 doesn't work. To me, both appear to be doing the exact same thing. As shown by the print in testfun2, the evaluation of the helper function inside testfun2 takes place in the correct environment, but the variables from the main function environment get magically passed to the helper function in testfun1, but not in testfun2. Does anyone of you know why?
helpfun <- function(){
x <- x^2 + y^2
}
testfun1 <- function(x,y){
xy <- x*y
environment(helpfun) <- sys.frame(sys.nframe())
x <- eval(as.call(c(as.symbol("helpfun"))))
return(list(x=x,xy=xy))
}
testfun1(x = 2,y = 1:3)
## works as intended
eval.here <- function(fun){
environment(fun) <- parent.frame()
print(environment(fun))
eval(as.call(c(as.symbol(fun))))
}
testfun2 <- function(x,y){
print(sys.frame(sys.nframe()))
xy <- x*y
x <- eval.here("helpfun")
return(list(x=x,xy=xy))
}
testfun2(x = 2,y = 1:3)
## helpfun can't find variable 'x' despite having the same environment as in testfun1...
Background info: I have a large R code in which I want to call helperfunctions inside my main function. They alter variables of the main function environment. The purpose of all this is mainly to unclutter my code. (Main function code is currently over 2000 lines, with many calls to various helperfunctions which themselves are 40-150 lines long...)
Note that the number of arguments to my helper functions is very high, so that the traditional explicit passing of function arguments ( "helpfun(arg1 = arg1, arg2 = arg2, ... , arg50 = arg50)") would be cumbersome and doesnt yield the uncluttering of the code that I am aiming for. Therefore, I need to pass the variables from the parent frame to the helper functions anonymously.
Use this instead:
eval.here <- function(fun){
fun <- get(fun)
environment(fun) <- parent.frame()
print(environment(fun))
fun()
}
Result:
> testfun2(x = 2,y = 1:3)
<environment: 0x0000000013da47a8>
<environment: 0x0000000013da47a8>
$x
[1] 5 8 13
$xy
[1] 2 4 6