I need to recover the expression implicitly used to invoke a call to show from within a show method, but this only works with an explicit show call:
> setClass("test", representation(a="character"))
> setMethod("show", "test", function(object) cat(deparse(substitute(object))))
[1] "show"
> show(new("test")) # explicit call: as expected
new("test")
> new("test") # implicit: not so much...
<S4 object of class structure("test", package = ".GlobalEnv")>
There seems to be a similar issue with print and S3 objects, but I'm more interested in the S4 version here. Any way to work around this? I looked at the call stack with sys.calls but there was no call recorded with the original expression which suggests to me this may be too low level to be resolved easily.
> showDefault
function (object, oldMethods = TRUE)
{
clDef <- getClass(cl <- class(object), .Force = TRUE)
cl <- classLabel(cl)
if (!is.null(clDef) && isS4(object) && is.na(match(clDef#className,
.BasicClasses))) {
cat("An object of class ", cl, "\n", sep = "")
slots <- slotNames(clDef)
dataSlot <- .dataSlot(slots)
if (length(dataSlot) > 0) {
dataPart <- slot(object, dataSlot)
show(dataPart)
slots <- slots[is.na(match(slots, dataSlot))]
}
else if (length(slots) == 0L)
show(unclass(object))
for (what in slots) {
if (identical(what, ".Data"))
next
cat("Slot \"", what, "\":\n", sep = "")
print(slot(object, what))
cat("\n")
}
}
else print(object, useS4 = FALSE)
invisible()
}
<bytecode: 0x11c228000>
<environment: namespace:methods>
Related
I am pretty new to R, I have coded with Python and here OOP is quite different to python. I am trying to understand it, so in S3 you can create methods/functions that are not directly attached to a single class, just the same as the objects as they can be in multiple classes (which is quite flexible I guess). However what I do not understand is when I am creating a class such as:
> my_mean <- function (x, ...) {
UseMethod("my_mean", x)}
> my_mean
function (x, ...) {
UseMethod("my_mean", x)}
> my_mean.default <- function(obj){cat("this is a generic function")}
> my_mean.default
function(obj){cat("this is a generic function")}
But then when I have to run for example summary:
summary.default
function (object, ..., digits, quantile.type = 7)
{
if (is.factor(object))
return(summary.factor(object, ...))
else if (is.matrix(object)) {
if (missing(digits))
return(summary.matrix(object, quantile.type = quantile.type,
...))
else return(summary.matrix(object, digits = digits, quantile.type = quantile.type,
...))
}
value <- if (is.logical(object))
c(Mode = "logical", {
tb <- table(object, exclude = NULL, useNA = "ifany")
if (!is.null(n <- dimnames(tb)[[1L]]) && any(iN <- is.na(n))) dimnames(tb)[[1L]][iN] <- "NA's"
tb
})
else if (is.numeric(object)) {
nas <- is.na(object)
object <- object[!nas]
qq <- stats::quantile(object, names = FALSE, type = quantile.type)
qq <- c(qq[1L:3L], mean(object), qq[4L:5L])
if (!missing(digits))
qq <- signif(qq, digits)
names(qq) <- c("Min.", "1st Qu.", "Median",
"Mean", "3rd Qu.", "Max.")
if (any(nas))
c(qq, `NA's` = sum(nas))
else qq
}
else if (is.recursive(object) && !is.language(object) &&
(n <- length(object))) {
sumry <- array("", c(n, 3L), list(names(object),
c("Length", "Class", "Mode")))
ll <- numeric(n)
for (i in 1L:n) {
ii <- object[[i]]
ll[i] <- length(ii)
cls <- oldClass(ii)
sumry[i, 2L] <- if (length(cls))
cls[1L]
else "-none-"
sumry[i, 3L] <- mode(ii)
}
sumry[, 1L] <- format(as.integer(ll))
sumry
}
else c(Length = length(object), Class = class(object), Mode = mode(object))
class(value) <- c("summaryDefault", "table")
value
}
<bytecode: 0x000001926eaaf8f8>
<environment: namespace:base>
> summary
function (object, ...)
UseMethod("summary")
<bytecode: 0x000001926e9ec2c0>
<environment: namespace:base>
I cannot see the difference in why when you call summary in the console it does not give you the function, it gives you a reference to that object. There's any explanation? Furthermore, is it generic in some way similar to init?
S3 classes work nothing like any OOP you may be familiar with from other languages. They are a losely connected set of mechanisms that only work when you stick to certain rules.
x <- 1:11
mean(x)
#> [1] 6
This implcitely calls the function mean.default because x is a simple atomic vector.
Now we create a method for our own class evil
mean.evil <- function( x ) {
return(666) # always retuns 666 that is why it is evil
}
And we convert the vector x to a class evil:
class(x) <- "evil" # you can actually do it just like that
Now, calling mean determines that xis of class evil and calls the according function.
mean(x) # calls mean.evil
#> [1] 666
mean.default(x) # coerces R to use the default method which is still possible
#> [1] 6
The reason is that mean uses UseMethod() which checks the class and tries to find a function that has name with the pattern mean.[myclass]. And that is all that happens.
mean
#> function (x, ...)
#> UseMethod("mean")
#> <bytecode: 0x0000000015812e18>
#> <environment: namespace:base>
In other languages everything is held together by the syntax. S3 mechanisms on the other hand can be used to "approximate" OOP but they can be easily misused. They are simply and effective and appropriate for many use cases in R. If you are interested in more advanced OOP in R I recommend R6 classes.
Created on 2020-06-30 by the reprex package (v0.3.0)
edit: added full code
I made an S4 method for 'plot' that appears to be working, except it outputs some stray NULL to the console and I can't figure out where it's coming from. Here's the top level code:
print(plot(x = flux, y = 1, fastplot = TRUE, quietly = TRUE))
And the class:
flux <- setClass(
# Set the class name
"flux",
slots = c(
raw.data = "list",
source.files = "character",
data = "matrix",
time = "POSIXct",
datatype = "character",
metadata = "data.frame"
)
)
And the method:
setMethod("plot",
signature(x = "flux"),
function (x, y, ...) {
CheckFluxObject(x)
params <- LoadDefaults(flux = x)
# Interpret 'plot' arguments
par.restore <- par(no.readonly = TRUE)
on.exit(expr = par(par.restore), add = TRUE)
arguments <- list(...)
if (!("fastplot" %in% names(arguments))) {
fastplot <- FALSE
} else {
fastplot <- arguments$fastplot
arguments$fastplot <- NULL
}
if (!("quietly" %in% names(arguments))) {
quietly <- FALSE
} else {
quietly <- arguments$quietly
arguments$quietly <- NULL
}
par(ask=!(fastplot))
if (!("ylab" %in% arguments)) {
ylab <- params["units"]
} else {
ylab <- arguments$ylab
arguments$ylab <- NULL
}
# Pull relevant 'flux' class object data
data <- slot(x, "data")
if (missing("y")) {
y <- 1:ncol(data)
} else {
stopifnot(
is.integer(y),
all(y %in% 1:ncol(data))
)
}
# Bulk function execution
if (quietly == FALSE) {
message("Plotting data traces:")
}
plot.obj <- plot.new()
print("NULL is in the 'for' loop...")
for (i in y){
main <- colnames(data)[i]
plot.obj <- plot(slot(x, "time"), data[, i], main = main,
xlab = "Time", ylab = ylab, unlist(arguments))
print(plot.obj)
}
print("but is it also here??")
# Clean-up and exit
if (quietly == FALSE) {
message("Done plotting.")
}
if (length(y) == 1) {
invisible(plot.obj)
}
print("or here??")
invisible(NULL)
}
)
The output for that is:
[1] "NULL is in the 'for' loop..."
NULL
[1] "but is it also here??"
[1] "or here??"
NULL
If I throw in another print("what about here??") after the invisible(NULL),
then it does this:
[1] "NULL is in the 'for' loop..."
NULL
[1] "but is it also here??"
[1] "or here??"
[1] "what about here??"
[1] "what about here??"
Is there some behavior of the function return or print commands that I'm not anticipating? The CheckFluxObject function just checks to make sure all the slots are filled.
I'll leave this here till a better answer pops up, if ever:
Apparently the print method for plot objects returns a NULL, and if you're trying to generate a plot within a function it seems like the best way to do that is using invisible(plot.object) or invisible(plot(x, y, ...)), NOT print.
I'm still not sure where the 2nd NULL is coming from...
edit: Found the second one! Just like the print(plot.obj) in the method itself, the print in the top-level code was throwing a NULL. Dropping all of the print commands killed all of the ghosts.
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.
In the book, the exercise is on page 10/23 of the Environments chapter, after section Iteration vs. Recursion. It is
Modify where() to find all environments that contain a binding for
name.
Here, where() is from the pryr package. First of all, to be sure I understand what is asked: Say I have the name mean. This could refer to:
> mean
function (x, ...)
UseMethod("mean")
<bytecode: 0x2234b58>
<environment: namespace:base>
But also, say I assign a value to a variable of the same name:
> mean <- 3
> mean
[1] 3
So, now (please correct me if I'm wrong), the former mean is bound by the baseenv() whereas the latter is bound by globalenv(). Correct?
> ls(as.environment(globalenv()))
[1] "mean"
> which(ls(as.environment(baseenv()))=="mean")
[1] 671
So I wrote:
where2 <- function(k, name, env) {
stopifnot(is.character(name), length(name) == 1)
# Why does this only work when calling 'where' from
# the 'pryr' package?
# env <- to_env(env)
# Hopefully the same as 'to_env'.
# env <- as.environment(env)
# Successful case.
if(exists(name, env, inherits=FALSE)) {
k <- list(k, env)
where2(k, name, parent.env(env))
}
# Base case or search one level up.
if(identical(env, emptyenv())) {
stop("Can't find ", name, call.=FALSE)
} else {
where2(k, name, parent.env(env))
}
}
inspired by the where function from the pryr package.
I was hoping I could now do (at the R prompt):
> source("./where2.r")
> mean <- 3
> k <- list()
> where2(k, "mean", parent.frame())
Error: Can't find mean
and get a list containint the base- and global environments.
What should I do differently and how?
This function solves the problem:
where_2 = function (name, env = parent.frame(), env_list = list())
{
stopifnot(is.character(name), length(name) == 1)
env <- as.environment(env)
if (identical(env, emptyenv())) {
if (length(env_list) == 0) {
stop("Can't find ", name, call.=FALSE)
} else {
return(env_list)
}
} else if (exists(name, env, inherits = FALSE)) {
env_list = append(env_list, env)
where_2(name, parent.env(env), env_list = env_list)
}
else {
where_2(name, parent.env(env), env_list = env_list)
}
}
let's assume you have one S4 class "A", and a subclass "B" which has additional features. Each have their own validity checks in place - B should only check the additional features. Now in the initialization of B, I would like to start out from an object of class A, and then amend it with the additional features. However, this creates problems, and I guess I am somewhere violating R's assumptions in this example.
Here's the dummy code:
setClass(Class="A",
representation=
representation(x="numeric"),
validity=
function(object){stopifnot(x > 0)})
setMethod("initialize",
signature(.Object="A"),
function(.Object,
...,
z){
x <- get("z") + 1
callNextMethod(.Object,
...,
x=x)
})
setClass(Class="B",
contains="A",
representation=
representation(y="numeric"),
validity=
function(object){stopifnot(y > 0)})
setMethod("initialize",
signature(.Object="B"),
function(.Object,
...,
bla){
.Object <- callNextMethod(.Object,
...)
.Object#y <- .Object#x + bla
return(.Object)
})
test <- new("B",
z=4,
bla=5)
If I try to create the "test" object, I get:
Error in stopifnot(x > 0): object 'x' not found
Do you know how I could do better?
Thanks a lot in advance!
Best regards
Daniel
A convenient test of the assumptions in S4 is that new() called with no arguments on a non-VIRTUAL class needs to return a valid object. Your class does not pass this test
> validObject(new("A"))
Error in get("z") : argument "z" is missing, with no default
One option would provide a default value to z in the initialize method, or (my preference) to use a prototype in the class definition coupled with a constructor. Also the validity function is supposed to return TRUE (if valid) or a character vector describing how it is not valid. So I wrote your class 'A' as
.A <- setClass(Class="A",
representation(x="numeric"),
prototype(x=1),
validity= function(object) {
msg <- NULL
if (length(object#x) != 1 || object#x <= 0)
msg <- c(msg, "'x' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
(the return value of setClass() just wraps new() in a more semantically rich function call).
> validObject(.A())
[1] TRUE
Instead of using the initialize method (which is tricky to implement correctly -- it's a copy constructor as well) I'd write
A <- function(z, ...)
.A(x=z+1, ...)
which behaves as expected
> A()
Error in initialize(value, ...) (from valid.R!7685pfr#2) :
argument "z" is missing, with no default
> A(1)
An object of class "A"
Slot "x":
[1] 2
I think the extension of these principles to "B" should be straight-forward, and a good "exercise for the reader"!
Just to complete Martin's answer, here is the full solution to my problem:
.A <- setClass(Class="A",
representation(x="numeric"),
prototype(x=1),
validity=
function(object){
msg <- NULL
if (length(object#x) != 1 || object#x <= 0)
msg <- c(msg, "'x' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
validObject(.A())
A <- function(z, ...)
{
x <- z + 1
.A(x=x, ...)
}
.B <- setClass(Class="B",
representation(y="numeric"),
prototype(y=2),
contains="A",
validity=
function(object){
msg <- NULL
if (length(object#y) != 1 || object#y <= 0)
msg <- c(msg, "'y' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
validObject(.B())
B <- function(bla, z, ...)
{
obj <- A(z, ...)
y <- obj#x + bla
.B(obj, y=y, ...)
}
test <- B(z=4,
bla=5)
Thanks again Martin for the extremely fast and perfect help!
best regards
Daniel