I have an issue verifying the validity of my class 'class2'; it is made of a list of 'class1' objects. I want to verify that it is indeed the case:
class2 <- setClass(
Class = "class2",
slots = c(slotListName = "list"),
validity = function(object){
lapply(object#slotListName, function(x){
if(!identical(is(x), "class1"))
stop(" not a class1 object");
});
});
The problem is that lapply returns values which are not accepted:
Error in validObject(.Object) :
invalid class “class2” object: 1: NULL
invalid class “class2” object: 2: NULL
I checked that the problem was coming from the lapply by testing only the first element of the list, which is working fine:
if(!identical(is(object#slotListName[[1]]), "class1"))
stop("not a class1 object");
I tried vectorizing but this does not change the problem.
Is there a way to verify that slotListName is indeed a list of 'class1' objects?
Thanks a lot!
The problem with your function is that it gives an error for an invalid object. It's supposed to return a diagnostic message, with the S4 object construction machinery taking care of the error.
Here's how you can do it using the recommended approach, which is to define methods for initialize and setValidity. See ?setClass for more details.
class2 <- setClass("class2", slots=c(slotListName="list"))
setMethod("initialize", "class2", function(.Object, lst)
{
.Object#slotListName <- lst
validObject(.Object)
.Object
})
# returns TRUE if the object is valid, otherwise a diagnostic message
setValidity("class2", function(object)
{
if(length(object#slotListName) < 1)
"must contain at least one class1 object"
else if(!all(sapply(object#slotListName, function(x) inherits(x, "class1"))))
"all objects in list must be class1"
else TRUE
})
## testing
x <- 42
class(x) <- "class1"
y <- 43
class(y) <- "bad"
l1 <- list(x, x, x)
l2 <- list(x, x, y)
## works
obj1 <- class2(l1)
## error: bad object in list
obj2 <- class2(l2)
## error: empty list
obj3 <- class2(list())
Related
I want to implement an inset method for my class myClass for the internal generic [<- (~ help(Extract)).
This method should run a bunch of tests, before passing on the actual insetting off to [<- via NextMethod().
I understand that:
any method has to include at least the arguments of the generic (mine does, I think)
the NextMethod() call does not usually need any arguments (though supplying them manually doesn't seem to help either).
Here's my reprex:
x <- c(1,2)
class(x) <- c("myClass", "numeric")
`[<-.myClass` <- function(x, i, j, value, foo = TRUE, ...) {
if (foo) {
stop("'foo' must be false!")
}
NextMethod()
}
x[1] <- 3 # this errors out with *expected* error message, so dispatch works
x[1, foo = FALSE] <- 3 # this fails with "incorrect number of subscripts
What seems to be happening is that NextMethod() also passes on foo to the internal generic [<-, which mistakes foo for another index, and, consequently errors out (because, in this case, x has no second dimension to index on).
I also tried supplying the arguments explicitly no NextMethod(), but this also fails (see reprex below the break).
How can I avoid choking up NextMethod() with additional arguments to my method?
(Bonus: Does anyone know good resources for building methods for internal generics? #Hadleys adv-r is a bit short on the matter).
Reprex with explicit arguments:
x <- c(1,2)
class(x) <- c("myClass", "numeric")
`[<-.myClass` <- function(x, i = NULL, j = NULL, value, foo = TRUE, ...) {
if (foo) {
stop("'foo' must be false!")
}
NextMethod(generic = "`[<-`", object = x, i = i, j = j, value = value, ...)
}
x[1] <- 3 # this errors out with expected error message, so dispatch works
x[1, foo = FALSE] <- 3 # this fails with "incorrect number of subscripts
I don't see an easy way around this except to strip the class (which makes a copy of x)
`[<-.myClass` <- function(x, i, value, ..., foo = TRUE) {
if (foo) {
cat("hi!")
x
} else {
class_x <- class(x)
x <- unclass(x)
x[i] <- value
class(x) <- class_x
x
}
}
x <- structure(1:2, class = "myClass")
x[1] <- 3
#> hi!
x[1, foo = FALSE] <- 3
x
#> [1] 3 2
#> attr(,"class")
#> [1] "myClass"
This is not a general approach - it's only needed for [, [<-, etc because they don't use the regular rules for argument matching:
Note that these operations do not match their index arguments in the standard way: argument names are ignored and positional matching only is used. So m[j = 2, i = 1] is equivalent to m[2, 1] and not to m[1, 2].
(from the "Argument matching" section in ?`[`)
That means your x[1, foo = FALSE] is equivalent to x[1, FALSE] and then you get an error message because x is not a matrix.
Approaches that don't work:
Supplying additional arguments to NextMethod(): this can only increase the number of arguments, not decrease it
Unbinding foo with rm(foo): this leads to an error about undefined foo.
Replacing foo with a missing symbol: this leads to an error that foo is not supplied with no default argument.
Here's how I understand it, but I don't know so much about that subject so I hope I don't say too many wrong things.
From ?NextMethod
NextMethod invokes the next method (determined by the class vector,
either of the object supplied to the generic, or of the first argument
to the function containing NextMethod if a method was invoked
directly).
Your class vector is :
x <- c(1,2)
class(x) <- "myClass" # note: you might want class(x) <- c("myClass", class(x))
class(x) # [1] "myClass"
So you have no "next method" here, and [<-.default, doesn't exist.
What would happen if we define it ?
`[<-.default` <- function(x, i, j, value, ...) {print("default"); value}
x[1, foo = FALSE] <- 3
# [1] "default"
x
# [1] 3
If there was a default method with a ... argument it would work fine as the foo argument would go there, but it's not the case so I believe NextMethod just cannot be called as is.
You could do the following to hack around the fact that whatever is called doesn't like to be fed a foo argument:
`[<-.myClass` <- function(x, i, j, value, foo = FALSE, ...) {
if (foo) {
stop("'foo' must be false!")
}
`[<-.myClass` <- function(x, i, j, value, ...) NextMethod()
args <- as.list(match.call())[-1]
args <- args[names(args) %in% c("","x","i","j","value")]
do.call("[<-",args)
}
x[1, foo = FALSE] <- 3
x
# [1] 3 2
# attr(,"class")
# [1] "myClass"
Another example, with a more complex class :
library(data.table)
x <- as.data.table(iris[1:2,1:2])
class(x) <- c("myClass",class(x))
x[1, 2, foo = FALSE] <- 9999
# Sepal.Length Sepal.Width
# 1: 5.1 9999
# 2: 4.9 3
class(x)
# [1] "myClass" "data.table" "data.frame"
This would fail if the next method had other arguments than x, i, j and value, in that case better to be explicit about our additional arguments and run args <- args[! names(args) %in% c("foo","bar")]. Then it might work (as long as arguments are given explicitly as match.call doesn't catch default arguments). I couldn't test this though as I don't know such method for [<-.
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
Reproducible example:
setClass("test", representation(a="ANY"))
A <- structure("blahblahblah", class="try-error")
new("test", a=A)
# Error in validObject(.Object) : invalid class “test” object: blahblahblah
I think the problem stems from line 29 of validObject:
sloti <- try(switch(namei, .S3Class = S3Class(object),
slot(object, namei)), silent = TRUE)
which clearly will trick whatever follows when slot(object, namei) returns a try-error class object as is the case here.
Anyhow, just wanted to ask here if this seems like a bug to anyone else before I go off and propose a tryCatch alternate.
And if you're curious as to why on earth I would be doing something like this, I am building S4 classes to store results of arbitrary expression evaluations, which in one of my test cases happened to contain the result of a try() statement.
No, the issue is on the next line:
if (inherits(sloti, "try-error")) {
errors <- c(errors, sloti)
next
}
A hacky workaround would be:
safeNew <- function(...) {
suppressMessages(trace(validObject, quote(inherits <- function(...)
if (eval.parent(substitute(namei != '.S3Class' && class(slot(object, namei)) == 'try-error'))) FALSE
else base::inherits(...)), at = 11))
capture.output(res <- new(...))
suppressMessages(untrace(validObject))
res
}
setClass("test", representation(a="ANY"))
A <- structure("blahblahblah", class="try-error")
safeNew("test", a = A) # Now returns no error.
EDIT: I changed some code above so it now type checks correctly rather than disable type checking. For example,
setClass("test", representation(a="ANY", b = "character"))
A <- structure("blahblahblah", class="try-error")
safeNew("test", a = A, b = 5)
# Error in validObject(.Object) :
# invalid class “test” object: invalid object for slot "b" in class "test": got class "numeric", should be or extend class "character"
Lets say I want to make a class "myClass" with two slots A and B.
now I want a validObject function that ensures A and B are the same length
same_length <- function(object){
if(length(object#A)!=length(object#B)) {
"vectors are not the same length"
} else TRUE
}
setClass("myClass", representation(A="numeric", B="numeric"),
validity=same_length)
I saw a function somewhere that will ensure the class is valid when initialized:
setMethod("initialize", "myClass", function(.Object, ...){
value <- callNextMethod()
validObject(value)
value
})
which will send an error if I try
newObj <- new("myClass", A=c(1,2,3), B=c(1,2))
But if I do
newObj <- new("myClass")
newObj#A <- c(1,2,3)
newObj#B <- c(1,2)
no error is thrown. How do I get it to throw an error as soon as a new slot assignment does not validate?
Write a 'replacement method' that does the check. To do this, we need to create a generic function (because no function with the appropriate name and signature already exists)
setGeneric("slotA<-", function(x, ..., value) standardGeneric("slotA<-"))
We then need to implement the replacement method for the specific types of objects we want to handle -- the first argument is of class 'myClass', the second argument (value) is of class 'numeric':
setReplaceMethod("slotA", c("myClass", "numeric"), function(x, ..., value) {
x#A = value
validObject(x)
x
})
We might also write a 'getter' generic and method
setGeneric("slotA", function(x, ...) standardGeneric("slotA"))
setMethod("slotA", "myClass", function(x, ...) x#A)
and then
> a=new("myClass", A=1:10, B=10:1)
> slotA(a)
[1] 1 2 3 4 5 6 7 8 9 10
> slotA(a) = 1:5
Error in validObject(x) :
invalid class "myClass" object: vectors are not the same length
Note that the default initialize method calls checkValidity, so if you use callNextMethod as the last line in your constructor there's no need to explicitly check validity.
I'm having a bunch of custom-made Reference Classes and would like to write coercion methods for some of them. It'd be nice if a function call would look like this:
objectCoerce(src=obj, to="list", ...)
where ... is the crucial part as sometimes I want to pass additional stuff for certain coercions (see do.deep = TRUE/FALSE below.
However, in order to do that, do I need to implement sort of a "transformer" that takes the to argument, tries to instantiate an empty object of the class specified by to and then calls the "regular" method dispatch? Or is there a better way?
Below you'll find my current solution. It works, but I'm "loosing" the option to coerce to class character" as this class is used to process things to the regular dispatcher and a to = "character would result in infinite recursion. Plus, it's a lot of overhead.
EDIT 2011-12-02
Of course setAs would be the first address to check. But the function specified by arg def in setAs can only take one argument, and often that's too rigid for me. For example, I don't see how I could include the do.deep = TRUE/FALSE switch when using setAs.
Class Defs
setRefClass(Class="MyVirtual")
setRefClass(
Class="A",
contains="MyVirtual",
fields=list(
x="character"
)
)
setRefClass(
Class="B",
contains="MyVirtual",
fields=list(
x.a="A",
x.b="numeric",
x.c="data.frame"
)
)
setGeneric(
name="objectCoerce",
signature=c("src", "to"),
def=function(src, to, ...){
standardGeneric("objectCoerce")
}
)
Generic Method
setGeneric(
name="objectCoerce",
signature=c("src", "to"),
def=function(src, to, ...){
standardGeneric("objectCoerce")
}
)
Intermediate Transformer
setMethod(
f="objectCoerce",
signature=signature(src="ANY", to="character"),
definition=function(src, to, do.deep=FALSE, ...){
# Transform 'to' to a dummy object of class 'to'
to.0 <- to
# For standard R classes
try.res <- try(eval(substitute(
to <- CLASS(),
list(CLASS=as.name(to.0))
)), silent=TRUE)
# For S4 classes
if(inherits(try.res, "try-error")){
try.res <- try(eval(substitute(
to <- new(CLASS),
list(CLASS=to.0)
)), silent=TRUE)
# For my classes. In order to get an 'hollow' object, some of them
# need to be instantiated by 'do.hollow=TRUE'
if(inherits(try.res, "try-error")){
try.res <- try(eval(substitute(
to <- new(CLASS, do.hollow=TRUE),
list(CLASS=to.0)
)), silent=TRUE)
if(inherits(try.res, "try-error")){
stop(try.res)
}
}
}
# Pass transformed 'to' along so the standard method
# dispatcher can kick in.
out <- objectCoerce(src=src, to=to, do.deep=do.deep, ...)
return(out)
}
)
Coercion Method 'MyVirtual' to 'list'
setMethod(
f="objectCoerce",
signature=signature(src="MyVirtual", to="list"),
definition=function(src, to, do.deep=FALSE, ...){
fields <- names(getRefClass(class(src))$fields())
out <- lapply(fields, function(x.field){
src$field(x.field)
})
names(out) <- fields
if(do.deep){
out <- lapply(out, function(x){
out <- x
if(inherits(x, "MyVirtual")){
out <- objectCoerce(src=x, to=to, do.deep=do.deep, .ARGS=.ARGS)
}
return(out)
})
}
return(out)
}
)
Test Run
x <- new("B", x.a=new("A", x="hello world!"), x.b=1:5,
x.c=data.frame(a=c(TRUE, TRUE, FALSE)))
> objectCoerce(src=x, to="list")
$x.a
Reference class object of class "A"
Field "x":
[1] "hello world!"
$x.b
[1] 1 2 3 4 5
$x.c
a
1 TRUE
2 TRUE
3 FALSE
> objectCoerce(src=x, to="list", do.deep=TRUE)
$x.a
$x.a$x
[1] "hello world!"
$x.b
[1] 1 2 3 4 5
$x.c
a
1 TRUE
2 TRUE
3 FALSE
Maybe use setAs to create a coerce method (though one would rather have one's own base class to write the method on, rather than doing this for envRefClass)
setAs("envRefClass", "list", function(from) {
fields <- names(getRefClass(class(from))$fields())
Map(from$field, fields)
})
and then
> as(new("B"), "list")
$x.a
Reference class object of class "A"
Field "x":
character(0)
$x.b
numeric(0)
$x.c
data frame with 0 columns and 0 rows
? The deep version might be like
setAs("envRefClass", "list", function(from) {
fields <- names(getRefClass(class(from))$fields())
curr <- Map(from$field, fields)
recurr <- sapply(curr, is, "envRefClass")
curr[recurr] <- lapply(curr[recurr], as, "list")
curr
})
I don't have good ideas for combining these, other than to create a psuedo-class 'deep_list' and a coerce method to that. I feel like I'm not understanding your post.