84 lines
2.5 KiB
R
84 lines
2.5 KiB
R
|
## reset inherited methods of group members
|
||
|
|
## (contributed by Martin Morgan, 2011-2-9)
|
||
|
|
setClass("A", representation("numeric"))
|
||
|
|
a <- new("A")
|
||
|
|
|
||
|
|
setMethod("Logic", c("A", "A"), function(e1, e2) FALSE)
|
||
|
|
res0 <- a & a # inherit &,A,A-method
|
||
|
|
setMethod("Logic", c("A", "A"), function(e1, e2) TRUE)
|
||
|
|
stopifnot(a & a)
|
||
|
|
|
||
|
|
removeMethod("Logic", c("A", "A"))
|
||
|
|
stopifnot(logical() == a & a)
|
||
|
|
|
||
|
|
removeClass("A")
|
||
|
|
|
||
|
|
### Find inherited group methods:
|
||
|
|
if(require(Matrix)) { ## , lib.loc = .Library
|
||
|
|
sm <- selectMethod("-", c("dgCMatrix", "numeric"))# direct match with "Arith"
|
||
|
|
s2 <- selectMethod("-", c("dtCMatrix", "numeric"))# ambiguity match with "Arith"
|
||
|
|
stopifnot(sm@generic == "Arith", s2@generic == "Arith")
|
||
|
|
}
|
||
|
|
## was not ok in R 2.14.x
|
||
|
|
|
||
|
|
## some tests of callGeneric(). It's reccommended for use with group generics
|
||
|
|
setGeneric("f1", signature=c("a"),
|
||
|
|
function(..., a) standardGeneric("f1"))
|
||
|
|
setMethod("f1", c(a="ANY"), function(..., a) list(a=a, ...))
|
||
|
|
setMethod("f1", c(a="missing"), function(..., a) callGeneric(a=1, ...))
|
||
|
|
f2 <- function(b,c,d, a) {
|
||
|
|
if (missing(a))
|
||
|
|
f1(b=b, c=c, d=d)
|
||
|
|
else
|
||
|
|
f1(a=a, b=b, c=c, d=d)
|
||
|
|
}
|
||
|
|
|
||
|
|
## use callGeneric both directly (f1) and indirectly (f2)
|
||
|
|
## Latter failed pre rev. 66408; Bug ID 15937
|
||
|
|
stopifnot(identical(c(1,2,3,4), as.vector(unlist(f1(2,3,4)))))
|
||
|
|
stopifnot(identical(c(1,2,3,4), as.vector(unlist(f2(2,3,4)))))
|
||
|
|
|
||
|
|
## test callGeneric() with no arguments. This is rarely used
|
||
|
|
## because nearly all applications use the groups Ops, etc.
|
||
|
|
## whose members are primitives => must supply args to callGeneric
|
||
|
|
|
||
|
|
Hide <- setClass("Hide", slots = c(data = "vector"), contains = "vector")
|
||
|
|
|
||
|
|
unhide <- function(obj)
|
||
|
|
obj@data
|
||
|
|
|
||
|
|
setGeneric("%p%", function(e1, e2) e1 + e2, group = "Ops2")
|
||
|
|
setGeneric("%gt%", function(e1, e2) e1 > e2, group = "Ops2")
|
||
|
|
|
||
|
|
setGroupGeneric("Ops2", function(e1,e2)NULL, knownMembers = c("%p%","%gt%"))
|
||
|
|
|
||
|
|
setMethod("Ops2", c("Hide", "Hide"),
|
||
|
|
function(e1, e2) {
|
||
|
|
e1 <- unhide(e1)
|
||
|
|
e2 <- unhide(e2)
|
||
|
|
callGeneric()
|
||
|
|
})
|
||
|
|
|
||
|
|
setMethod("Ops2", c("Hide", "vector"),
|
||
|
|
function(e1, e2) {
|
||
|
|
e1 <- unhide(e1)
|
||
|
|
callGeneric()
|
||
|
|
})
|
||
|
|
setMethod("Ops2", c("vector", "Hide"),
|
||
|
|
function(e1, e2) {
|
||
|
|
e2 <- unhide(e2)
|
||
|
|
callGeneric()
|
||
|
|
})
|
||
|
|
|
||
|
|
h1 <- Hide(data = 1:10)
|
||
|
|
h2 <- Hide(data = (1:10)*.5+ 0.5)
|
||
|
|
|
||
|
|
stopifnot(all.equal(h1%p%h2, h1@data + h2@data))
|
||
|
|
stopifnot(all.equal(h1 %gt% h2, h1@data > h2@data))
|
||
|
|
|
||
|
|
removeClass("Hide")
|
||
|
|
for(g in c("f1", "%p%", "%gt%", "Ops2"))
|
||
|
|
removeGeneric(g)
|
||
|
|
|
||
|
|
|