packrat/lib-R/x86_64-w64-mingw32/3.6.1/methods/tests/testGroupGeneric.R

In jmcascalheira/LGMIberiaCluster: Research compendium for the paper "Human adaptations and palaeoenvironmental record during the Last Glacial Maximum in the Iberian Peninsula"

## 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)