The R Project SVN
R
(root)/branches/R-4-2-branch/tests/reg-S4.Rout.save – Rev 83495
Rev 82852 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
R version 4.2.2 Patched (2022-12-23 r83494) -- "Innocent and Trusting"Copyright (C) 2022 The R Foundation for Statistical ComputingPlatform: aarch64-apple-darwin22.2.0 (64-bit)R is free software and comes with ABSOLUTELY NO WARRANTY.You are welcome to redistribute it under certain conditions.Type 'license()' or 'licence()' for distribution details.R is a collaborative project with many contributors.Type 'contributors()' for more information and'citation()' on how to cite R or R packages in publications.Type 'demo()' for some demos, 'help()' for on-line help, or'help.start()' for an HTML browser interface to help.Type 'q()' to quit R.> ####--- S4 Methods (and Classes) --- see also ../src/library/methods/tests/>> #### Instead of adding more tests depending on recommended packages,> #### re-facror into a separate script and treat like eval-etc-2.R>> options(useFancyQuotes=FALSE)> require(methods)> assertError <- tools::assertError # "import"> ##too fragile: showMethods(where = "package:methods")>> ## When this test comes too late, it failed too early in R <= 3.2.2> require(stats4)Loading required package: stats4> detach("package:methods")> require("methods")Loading required package: methods> cc <- methods::getClassDef("standardGeneric")> cc ## (auto) print failed here, in R <= 3.2.2Class "standardGeneric" [package "methods"]Slots:Name: .Data generic package groupClass: function character character listName: valueClass signature default skeletonClass: character character optionalMethod callExtends:Class "genericFunction", directlyClass "function", by class "genericFunction", distance 2Class "OptionalFunction", by class "function", distance 3Class "PossibleMethod", by class "function", distance 3Class "optionalMethod", by class "genericFunction", distance 4Known Subclasses: "standardGenericWithTrace"> stopifnot(.isMethodsDispatchOn()) ## was FALSE in R <= 3.2.2>>> ## Needs cached primitive generic for '$'> new("envRefClass")# failed in R <= 3.2.0Reference class object of class "envRefClass">> ##-- S4 classes with S3 slots [moved from ./reg-tests-1.R]> setClass("test1", representation(date="POSIXct"))> x <- new("test1", date=as.POSIXct("2003-10-09"))> stopifnot(format(x @ date) == "2003-10-09")> ## line 2 failed in 1.8.0 because of an extraneous space in "%in%">> stopifnot(all.equal(3:3, 3.), all.equal(1., 1:1))>> ## trace (requiring methods):> f <- function(x, y) { c(x,y)}> xy <- 0> trace(f, quote(x <- c(1, x)), exit = quote(xy <<- x), print = FALSE)[1] "f"> fxy <- f(2,3)> stopifnot(identical(fxy, c(1,2,3)))> stopifnot(identical(xy, c(1,2)))> untrace(f)>> ## a generic and its methods>> setGeneric("f")[1] "f"> setMethod("f", c("character", "character"), function(x, y) paste(x,y))>> ## trace the generic> trace("f", quote(x <- c("A", x)), exit = quote(xy <<- c(x, "Z")), print = FALSE)[1] "f">> ## should work for any method>> stopifnot(identical(f(4,5), c("A",4,5)),+ identical(xy, c("A", 4, "Z")))>> stopifnot(identical(f("B", "C"), paste(c("A","B"), "C")),+ identical(xy, c("A", "B", "Z")))>> ## trace a method> trace("f", sig = c("character", "character"), quote(x <- c(x, "D")),+ exit = quote(xy <<- xyy <<- c(x, "W")), print = FALSE)[1] "f">> stopifnot(identical(f("B", "C"), paste(c("A","B","D"), "C")))> stopifnot(identical(xyy, c("A", "B", "D", "W")))> # got broken by Luke's lexical scoping fix:> #stopifnot(identical(xy, xyy))>> ## but the default method is unchanged> stopifnot(identical(f(4,5), c("A",4,5)),+ identical(xy, c("A", 4, "Z")))>> removeGeneric("f")[1] TRUE> ## end of moved from trace.Rd>>> ## print/show dispatch [moved from ./reg-tests-2.R ]> ## The results have waffled back and forth.> ## Currently (R 2.4.0) the intent is that automatic printing of S4> ## objects should correspond to a call to show(), as per the green> ## book, p. 332. Therefore, the show() method is called, once defined,> ## for auto-printing foo, regardless of the S3 or S4 print() method.> ## (But most of this example is irrelevant if one avoids S3 methods for> ## S4 classes, as one should.)> setClass("bar", representation(a="numeric"))> foo <- new("bar", a=pi)> fooAn object of class "bar"Slot "a":[1] 3.141593> show(foo)An object of class "bar"Slot "a":[1] 3.141593> print(foo)An object of class "bar"Slot "a":[1] 3.141593>> setMethod("show", "bar", function(object){cat("show method\n")})> show(foo)show method> fooshow method> print(foo)show method> # suppressed because output depends on current choice of S4 type or> # not. Can reinstate when S4 type is obligatory> # print(foo, digits = 4)>> ## DON'T DO THIS: S3 methods for S4 classes are a design error JMC iii.9.09> ## print.bar <- function(x, ...) cat("print method\n")> ## foo> ## print(foo)> ## show(foo)>> setMethod("print", "bar", function(x, ...){cat("S4 print method\n")})> fooshow method> print(foo)S4 print method> show(foo)show method> ## calling print() with more than one argument suppresses the show()> ## method, largely to prevent an infinite loop if there is in fact no> ## show() method for this class. A better solution would be desirable.> print(foo, digits = 4)S4 print method>> cn <- "integer or NULL"> setClassUnion(cn, members = c("integer", "NULL"))> setClass("c1", representation(x = "integer", code = cn))> stopifnot(exprs = {+ cn %in% extends(getClass("NULL"))+ cn %in% extends(getClass(".NULL"))+ cn %in% extends(getClass("integer"))+ })> nc <- new("c1", x = 1:2)> str(nc)# gave ^ANULL^A in 2.0.0Formal class 'c1' [package ".GlobalEnv"] with 2 slots..@ x : int [1:2] 1 2..@ code: NULL> ##>> showMethods("coerce", classes=c("matrix", "numeric"))Function: coerce (package methods)from="ANY", to="matrix"from="ANY", to="numeric"> ## {gave wrong result for a while in R 2.4.0}>> ## Most for "mle" in stats4:> for(f in c("coef", "confint", "logLik", "plot", "profile",+ "show", "summary", "update", "vcov"))+ if(!hasMethods(f)) stop("no S4 methods found for ", f)>>> ##--- "[" fiasco before R 2.2.0 :> d2 <- data.frame(b= I(matrix(1:6,3,2)))> ## all is well:> d2[2,][,1] [,2][1,] 2 5> stopifnot(identical(d2[-1,], d2[2:3,]))> ## Now make "[" into S4 generic by defining a trivial method> setClass("Mat", representation(Dim = "integer", "VIRTUAL"))> setMethod("[", signature(x = "Mat",+ i = "missing", j = "missing", drop = "ANY"),+ function (x, i, j, drop) x)> ## Can even remove the method: it doesn't help> removeMethod("[", signature(x = "Mat",+ i = "missing", j = "missing", drop = "ANY"))[1] TRUE> d2[1:2,] ## used to fail badly; now okay[,1] [,2][1,] 1 4[2,] 2 5> stopifnot(identical(d2[-1,], d2[2:3,]))> ## failed in R <= 2.1.x>>> ## Fritz' S4 "odditiy"> setClass("X", representation(bar="numeric"))> setClass("Y", contains="X")> ## Now we define a generic foo() and two different methods for "X" and> ## "Y" objects for arg missing:> setGeneric("foo", function(object, arg) standardGeneric("foo"))[1] "foo"> setMethod("foo", signature(object= "X", arg="missing"),+ function(object, arg) cat("an X object with bar =", object@bar, "\n"))> setMethod("foo", signature(object= "Y", arg="missing"),+ function(object, arg) cat("a Y object with bar =", object@bar, "\n"))> ## Finally we create a method where arg is "logical" only for class> ## "X", hence class "Y" should inherit that:> setMethod("foo", signature(object= "X", arg= "logical"),+ function(object, arg) cat("Hello World!\n") )> ## now create objects and call methods:> y <- new("Y", bar=2)> ## showMethods("foo")> foo(y)a Y object with bar = 2> foo(y, arg=TRUE)## Hello World!Hello World!> ## OK, inheritance worked, and we have> ## showMethods("foo")> foo(y)a Y object with bar = 2> ## still 'Y' -- was 'X object' in R < 2.3>>> ## Multiple inheritance> setClass("A", representation(x = "numeric"))> setClass("B", representation(y = "character"))> setClass("C", contains = c("A", "B"), representation(z = "logical"))> new("C")An object of class "C"Slot "z":logical(0)Slot "x":numeric(0)Slot "y":character(0)> setClass("C", contains = c("A", "B"), representation(z = "logical"),+ prototype = prototype(x = 1.5, y = "test", z = TRUE))> (cc <- new("C"))An object of class "C"Slot "z":[1] TRUESlot "x":[1] 1.5Slot "y":[1] "test"> ## failed reconcilePropertiesAndPrototype(..) after svn r37018> stopifnot(identical(selectSuperClasses("C", dropVirtual = TRUE), c("A", "B")),+ 0 == length(.selectSuperClasses(getClass("B")@contains)))>> ## "Logic" group -- was missing in R <= 2.4.0> stopifnot(all(getGroupMembers("Logic") %in% c("&", "|")),+ any(getGroupMembers("Ops") == "Logic"))> setClass("brob", contains="numeric")> b <- new("brob", 3.14)> logic.brob.error <- function(nm)+ stop("logic operator '", nm, "' not applicable to brobs")> logic2 <- function(e1,e2) logic.brob.error(.Generic)> setMethod("Logic", signature("brob", "ANY"), logic2)> setMethod("Logic", signature("ANY", "brob"), logic2)> ## Now ensure that using group members gives error:> assertError(b & b)Note: method with signature 'brob#ANY' chosen for function '&',target signature 'brob#brob'."ANY#brob" would also be valid> assertError(b | 1)> assertError(TRUE & b)>>> ## methods' hidden cbind() / rbind:> setClass("myMat", representation(x = "numeric"))> setMethod("cbind2", signature(x = "myMat", y = "missing"), function(x,y) x)> m <- new("myMat", x = c(1, pi))> stopifnot(identical(m, methods:::cbind(m)), identical(m, cbind(m)))>>> ## explicit print or show on a basic class with an S4 bit> ## caused infinite recursion> setClass("Foo", representation(name="character"), contains="matrix")> (f <- new("Foo", name="Sam", matrix()))An object of class "Foo"[,1][1,] NASlot "name":[1] "Sam"> f2 <- new("Foo", .Data = diag(2), name="Diag")# explicit .Data> (m <- as(f, "matrix"))[,1][1,] NA> ## this has no longer (2.7.0) an S4 bit: set it explicitly just for testing:> stopifnot(isS4(m. <- asS4(m)),+ identical(m, f@.Data),+ .hasSlot(f, "name"))# failed in R <= 2.13.1> show(m.)[,1][1,] NA> print(m.)[,1][1,] NA> ## fixed in 2.5.0 patched>> ## callGeneric inside a method with new arguments {hence using .local()}:> setGeneric("Gfun", function(x, ...) standardGeneric("Gfun"),+ useAsDefault = function(x, ...) sum(x, ...))[1] "Gfun"> setClass("myMat", contains="matrix")> setClass("mmat2", contains="matrix")> setClass("mmat3", contains="mmat2")> setMethod(Gfun, signature(x = "myMat"),+ function(x, extrarg = TRUE) {+ cat("in 'myMat' method for 'Gfun() : extrarg=", extrarg, "\n")+ Gfun(unclass(x))+ })> setMethod(Gfun, signature(x = "mmat2"),+ function(x, extrarg = TRUE) {+ cat("in 'mmat2' method for 'Gfun() : extrarg=", extrarg, "\n")+ x <- unclass(x)+ callGeneric()+ })> setMethod(Gfun, signature(x = "mmat3"),+ function(x, extrarg = TRUE) {+ cat("in 'mmat3' method for 'Gfun() : extrarg=", extrarg, "\n")+ x <- as(x, "mmat2")+ callGeneric()+ })> wrapG <- function(x, a1, a2) {+ myextra <- missing(a1) && missing(a2)+ Gfun(x, extrarg = myextra)+ }>> (mm <- new("myMat", diag(3)))An object of class "myMat"[,1] [,2] [,3][1,] 1 0 0[2,] 0 1 0[3,] 0 0 1> Gfun(mm)in 'myMat' method for 'Gfun() : extrarg= TRUE[1] 3> stopifnot(identical(wrapG(mm), Gfun(mm, TRUE)),+ identical(wrapG(mm,,2), Gfun(mm, FALSE)))in 'myMat' method for 'Gfun() : extrarg= TRUEin 'myMat' method for 'Gfun() : extrarg= TRUEin 'myMat' method for 'Gfun() : extrarg= FALSEin 'myMat' method for 'Gfun() : extrarg= FALSE>> Gfun(mm, extrarg = FALSE)in 'myMat' method for 'Gfun() : extrarg= FALSE[1] 3> m2 <- new("mmat2", diag(3))> Gfun(m2)in 'mmat2' method for 'Gfun() : extrarg= TRUE[1] 3> Gfun(m2, extrarg = FALSE)in 'mmat2' method for 'Gfun() : extrarg= FALSE[1] 3> ## The last two gave Error ...... variable ".local" was not found> (m3 <- new("mmat3", diag(3)))An object of class "mmat3"[,1] [,2] [,3][1,] 1 0 0[2,] 0 1 0[3,] 0 0 1> Gfun(m3)in 'mmat3' method for 'Gfun() : extrarg= TRUEin 'mmat2' method for 'Gfun() : extrarg= TRUE[1] 3> Gfun(m3, extrarg = FALSE) # used to not pass 'extrarg'in 'mmat3' method for 'Gfun() : extrarg= FALSEin 'mmat2' method for 'Gfun() : extrarg= FALSE[1] 3>> ## -- a variant of the above which failed in version <= 2.5.1 :> setGeneric("Gf", function(x, ...) standardGeneric("Gf"))[1] "Gf"> setMethod(Gf, signature(x = "mmat2"),+ function(x, ...) {+ cat("in 'mmat2' method for 'Gf()\n")+ x <- unclass(x)+ callGeneric()+ })> setMethod(Gf, signature(x = "mmat3"),+ function(x, ...) {+ cat("in 'mmat3' method for 'Gf()\n")+ x <- as(x, "mmat2")+ callGeneric()+ })> setMethod(Gf, signature(x = "matrix"),+ function(x, a1, ...) {+ cat(sprintf("matrix %d x %d ...\n", nrow(x), ncol(x)))+ list(x=x, a1=a1, ...)+ })>> wrap2 <- function(x, a1, ...) {+ A1 <- if(missing(a1)) "A1" else as.character(a1)+ Gf(x, ..., a1 = A1)+ }> ## Gave errors in R 2.5.1 :> wrap2(m2, foo = 3.14)in 'mmat2' method for 'Gf()matrix 3 x 3 ...$x[,1] [,2] [,3][1,] 1 0 0[2,] 0 1 0[3,] 0 0 1$a1[1] "A1"$foo[1] 3.14> wrap2(m2, 10, answer.all = 42)in 'mmat2' method for 'Gf()matrix 3 x 3 ...$x[,1] [,2] [,3][1,] 1 0 0[2,] 0 1 0[3,] 0 0 1$a1[1] "10"$answer.all[1] 42>>> ## regression tests of dispatch: most of these became primitive in 2.6.0> setClass("c1", "numeric")> setClass("c2", "numeric")> x_c1 <- new("c1")> # the next failed < 2.5.0 as the signature in .BasicFunsList was wrong> setMethod("as.character", "c1", function(x, ...) "fn test")> as.character(x_c1)[1] "fn test">> setMethod("as.integer", "c1", function(x, ...) 42)> as.integer(x_c1)[1] 42>> setMethod("as.logical", "c1", function(x, ...) NA)> as.logical(x_c1)[1] NA>> setMethod("as.complex", "c1", function(x, ...) pi+0i)> as.complex(x_c1)[1] 3.141593+0i>> setMethod("as.raw", "c1", function(x) as.raw(10))> as.raw(x_c1)[1] 0a>> # as.double, as.real use as.numeric for their methods to maintain equivalence> setMethod("as.numeric", "c1", function(x, ...) 42+pi)> identical(as.numeric(x_c1),as.double(x_c1))[1] TRUE>>> setMethod(as.double, "c2", function(x, ...) x@.Data+pi)> x_c2 <- new("c2", pi)> identical(as.numeric(x_c2),as.double(x_c2))[1] TRUE>> ## '!' changed signature from 'e1' to 'x' in 2.6.0> setClass("foo", "logical")> setMethod("!", "foo", function(e1) e1+NA)Warning message:For function '!', signature 'foo': argument in method definition changed from (e1) to (x)> selectMethod("!", "foo")Method Definition:function (x)x + NASignatures:xtarget "foo"defined "foo"> xx <- new("foo", FALSE)> !xxAn object of class "foo"[1] NA>> ## This fails in R versions earlier than 2.6.0:> setMethod("as.vector", "foo", function(x) unclass(x))> stopifnot(removeClass("foo"))>> ## stats4::AIC in R < 2.7.0 used to clobber stats::AIC> pfit <- function(data) {+ m <- mean(data)+ loglik <- sum(dpois(data, m))+ ans <- list(par = m, loglik = loglik)+ class(ans) <- "pfit"+ ans+ }> AIC.pfit <- function(object, ..., k = 2) -2*object$loglik + k> AIC(pfit(1:10))[1] 0.05867604> library(stats4) # and keep on search() for tests below> AIC(pfit(1:10)) # failed in R < 2.7.0[1] 0.05867604>> ## For a few days (~ 2008-01-30), this failed to work without any notice:> setClass("Mat", representation(Dim = "integer","VIRTUAL"))> setClass("dMat", representation(x = "numeric", "VIRTUAL"), contains = "Mat")> setClass("CMat", representation(dnames = "list","VIRTUAL"), contains = "Mat")> setClass("dCMat", contains = c("dMat", "CMat"))> stopifnot(!isVirtualClass("dCMat"),+ length(slotNames(new("dCMat"))) == 3)>>> ## Passing "..." arguments in nested callGeneric()s> setClass("m1", contains="matrix")> setClass("m2", contains="m1")> setClass("m3", contains="m2")> ##> setGeneric("foo", function(x, ...) standardGeneric("foo"))[1] "foo"> setMethod("foo", signature(x = "m1"),+ function(x, ...) cat(" <m1> ", format(match.call()),"\n"))> setMethod("foo", signature(x = "m2"),+ function(x, ...) {+ cat(" <m2> ", format(match.call()),"\n")+ x <- as(x, "m1"); callGeneric()+ })> setMethod("foo", signature(x = "m3"),+ function(x, ...) {+ cat(" <m3> ", format(match.call()),"\n")+ x <- as(x, "m2"); callGeneric()+ })> foo(new("m1"), bla = TRUE)<m1> foo(x = new("m1"), bla = TRUE)> foo(new("m2"), bla = TRUE)<m2> foo(x = new("m2"), bla = TRUE)<m1> foo(x = x, bla = TRUE)> foo(new("m3"), bla = TRUE)<m3> foo(x = new("m3"), bla = TRUE)<m2> foo(x = x, bla = TRUE)<m1> foo(x = x, bla = TRUE)> ## The last one used to loose 'bla = TRUE' {the "..."} when it got to m1>> ## is() for S3 objects with multiple class strings> setClassUnion("OptionalPOSIXct", c("POSIXct", "NULL"))> stopifnot(is(Sys.time(), "OptionalPOSIXct"))> ## failed in R 2.7.0>> ## getGeneric() / getGenerics() "problems" related to 'tools' usage:> e4 <- as.environment("package:stats4")> gg4 <- getGenerics(e4)> stopifnot(c("BIC", "coef", "confint", "logLik", "plot", "profile",+ "show", "summary", "update", "vcov") %in% gg4, # %in% : "future proof"+ unlist(lapply(gg4, function(g) !is.null(getGeneric(g, where = e4)))),+ unlist(lapply(gg4, function(g) !is.null(getGeneric(g)))))> em <- as.environment("package:methods")> ggm <- getGenerics(em)> gms <- c("addNextMethod", "body<-", "cbind2", "initialize",+ "loadMethod", "Ops", "rbind2", "show")> stopifnot(unlist(lapply(ggm, function(g) !is.null(getGeneric(g, where = em)))),+ unlist(lapply(ggm, function(g) !is.null(getGeneric(g)))),+ gms %in% ggm,+ gms %in% tools:::get_S4_generics_with_methods(em), # with "message"+ ## all above worked in 2.7.0, however:+ isGeneric("show", where=e4),+ hasMethods("show", where=e4), hasMethods("show", where=em),+ identical(as.character(gg4), #gg4 has packages attr.; tools::: doesn't+ tools:::get_S4_generics_with_methods(e4))+ )> ## the last failed in R 2.7.0 : was not showing "show">> if(require("Matrix", lib.loc = .Library, quietly = TRUE)) {+ D5. <- Diagonal(x = 5:1)+ D5N <- D5.; D5N[5,5] <- NA+ stopifnot(isGeneric("dim", where=as.environment("package:Matrix")),+ identical(D5., pmin(D5.)),+ identical(D5., pmax(D5.)),+ identical(D5., pmax(D5., -1)),+ identical(D5., pmin(D5., 7)),+ inherits((D5.3 <- pmin(D5.+2, 3)), "Matrix"),+ identical(as.matrix(pmin(D5.+2 , 3)),+ pmin(as.matrix(D5.+2), 3)),+ identical(pmin(1, D5.), pmin(1, as.matrix(D5.))),+ identical(D5N, pmax(D5N, -1)),+ identical(D5N, pmin(D5N, 5)),+ identical(as.matrix(pmin(D5N +1, 3)),+ pmin(as.matrix(D5N)+1, 3)),+ ##+ TRUE)+ } else+ message("skipping tests requiring the Matrix package")<sparse>[ <logic> ]: .M.sub.i.logical() maybe inefficient>>> ## containing "array" ("matrix", "ts", ..)> t. <- ts(1:10, frequency = 4, start = c(1959, 2))> setClass("Arr", contains= "array"); x <- new("Arr", cbind(17))> setClass("Ts", contains= "ts"); tt <- new("Ts", t.); t2 <- as(t., "Ts")> setClass("ts2", representation(x = "Ts", y = "ts"))> tt2 <- new("ts2", x=t2, y=t.)> stopifnot(dim(x) == c(1,1), is(tt, "ts"), is(t2, "ts"),+ ## FIXME: identical(tt, t2)+ length(tt) == length(t.),+ identical(tt2@x, t2), identical(tt2@y, t.))> ## new(..) failed in R 2.7.0>> ## Method with wrong argument order :> setGeneric("test1", function(x, printit = TRUE, name = "tmp")+ standardGeneric("test1"))[1] "test1"> tools::assertCondition(+ setMethod("test1", "numeric", function(x, name, printit) match.call()),+ "warning", "error")## did not warn or error in R 2.7.0 and earlier>> library(stats4)> c1 <- getClass("mle", where = "stats4")> c2 <- getClass("mle", where = "package:stats4")> s1 <- getMethod("summary", "mle", where = "stats4")> s2 <- getMethod("summary", "mle", where = "package:stats4")> stopifnot(is(c1, "classRepresentation"),+ is(s1, "MethodDefinition"),+ identical(c1,c2), identical(s1,s2))> ## failed at times in the past>> ## Extending "matrix", the .Data slot etc:> setClass("moo", representation("matrix"))> m <- matrix(1:4, 2, dimnames= list(NULL, c("A","B")))> nf <- new("moo", .Data = m)> n2 <- new("moo", 3:1, 3,2)> n3 <- new("moo", 1:6, ncol=2)> stopifnot(identical(m, as(nf, "matrix")),+ identical(matrix(3:1,3,2), as(n2, "matrix")),+ identical(matrix(1:6,ncol=2), as(n3, "matrix")))> ## partly failed at times in pre-2.8.0>> ## From "Michael Lawrence" <....@fhcrc.org> To r-devel@r-project, 25 Nov 2008:> ## NB: setting a generic on order() is *not* the approved method> ## -- set xtfrm() methods instead> setGeneric("order", signature="...",+ function (..., na.last=TRUE, decreasing=FALSE)+ standardGeneric("order"))Creating a new generic function for 'order' in the global environment[1] "order"> stopifnot(identical(rbind(1), matrix(1,1,1)))> setGeneric("rbind", function(..., deparse.level=1)+ standardGeneric("rbind"), signature = "...")Creating a new generic function for 'rbind' in the global environment[1] "rbind"> stopifnot(identical(rbind(1), matrix(1,1,1)))> ## gave Error in .Method( .... in R 2.8.0>> ## median( <simple S4> )> ## FIXME: if we use "C" instead of "L", this fails because of caching> setClass("L", contains = "list")> ## {simplistic, just for the sake of testing here} :> setMethod("Compare", signature(e1="L", e2="ANY"),+ function(e1,e2) sapply(e1, .Generic, e2=e2))> ## note the next does *not* return an object of the class.> setMethod("Summary", "L",+ function(x, ..., na.rm=FALSE) {x <- unlist(x); callNextMethod()})> setMethod("[", signature(x="L", i="ANY", j="missing",drop="missing"),+ function(x,i,j,drop) new(class(x), x@.Data[i]))> ## defining S4 methods for sort() has no effect on calls to> ## sort() from functions in a namespace; e.g., median.default.> ## but setting an xtfrm() method works.> setMethod("xtfrm", "L", function(x) xtfrm(unlist(x@.Data)))> ## median is documented to use mean(), so we need an S3 mean method:> ## An S4 method will not do because of the long-standing S4 scoping bug.> mean.L <- function(x, ...) new("L", mean(unlist(x@.Data), ...))> x <- new("L", 1:3); x2 <- x[-2]> stopifnot(unlist(x2) == (1:3)[-2],+ is(mx <- median(x), "L"), mx == 2,+ ## median of two+ median(x2) == x[2])> ## NB: quantile() is not said to work on such an object, and only does so> ## for order statistics (so should not be tested, but was in earlier versions).>> ## Buglet in as() generation for class without own slots> setClass("SIG", contains="signature")> stopifnot(packageSlot(class(S <- new("SIG"))) == ".GlobalEnv",+ packageSlot(class(ss <- new("signature"))) == "methods",+ packageSlot(class(as(S, "signature"))) == "methods")> ## the 3rd did not have "methods">> ## Invalid "factor"s -- now "caught" by validity check :> ok.f <- gl(3,5, labels = letters[1:3])> bad.f <- structure(rep(1:3, each=5), levels=c("a","a","b"), class="factor")> validObject(ok.f) ; assertError(validObject(bad.f))[1] TRUE> setClass("myF", contains = "factor")> validObject(new("myF", ok.f))[1] TRUE> assertError(validObject(new("myF", bad.f)))> removeClass("myF")[1] TRUE> ## no validity check in R <= 2.9.0>> ## as(x, .) when x is from an "unregistered" S3 class :> as(structure(1:3, class = "foobar"), "vector")[1] 1 2 3> ## failed to work in R <= 2.9.0>> ## S4 dispatch in the internal generic xtfrm (added in 2.11.0)> setClass("numWithId", representation(id = "character"), contains = "numeric")> x <- new("numWithId", 1:3, id = "An Example")> xtfrm(x) # works as the base representation is numeric[1] 1 2 3attr(,"id")[1] "An Example"> setMethod('xtfrm', 'numWithId', function(x) x@.Data)> xtfrm(x)[1] 1 2 3> stopifnot(identical(xtfrm(x), 1:3))# "integer" is "numeric"> ## new in 2.11.0>> ## [-dispatch using callNextMethod()> setClass("C1", representation(a = "numeric"))> setClass("C2", contains = "C1")> setMethod("[", "C1", function(x,i,j,...,drop=TRUE)+ cat("drop in C1-[ :", drop, "\n"))> setMethod("[", "C2", function(x,i,j,...,drop=TRUE) {+ cat("drop in C2-[ :", drop, "\n")+ callNextMethod()+ })> x <- new("C1"); y <- new("C2")> x[1, drop=FALSE]drop in C1-[ : FALSENULL> y[1, drop=FALSE]drop in C2-[ : FALSEdrop in C1-[ : FALSENULL> ## the last gave TRUE on C1-level in R 2.10.x;> ## the value of drop was wrongly taken from the default.>> ## All slot names -- but "class" -- should work now> problNames <- c("names", "dimnames", "row.names",+ "class", "comment", "dim", "tsp")> myTry <- function(expr, ...) tryCatch(expr, error = function(e) e)> tstSlotname <- function(nm) {+ r <- myTry(setClass("foo", representation =+ structure(list("character"), names = nm)))+ if(is(r, "error")) return(r$message)+ ## else+ ch <- LETTERS[1:5]+ ## instead of new("foo", <...> = ch):+ x <- myTry(do.call(new, structure(list("foo", ch), names=c("", nm))))+ if(is(x, "error")) return(x$message)+ y <- myTry(new("foo")); if(is(y, "error")) return(y$message)+ r <- myTry(capture.output(show(x))); if(is(r, "error")) return(r$message)+ r <- myTry(capture.output(show(y))); if(is(r, "error")) return(r$message)+ ## else+ slot(y, nm) <- slot(x, nm)+ stopifnot(validObject(x), identical(x,y), identical(slot(x, nm), ch))+ return(TRUE)+ }> R <- sapply(problNames, tstSlotname, simplify = FALSE)> str(R) # just so ...List of 7$ names : logi TRUE$ dimnames : logi TRUE$ row.names: logi TRUE$ class : chr "\"class\" is a reserved slot name and cannot be redefined"$ comment : logi TRUE$ dim : logi TRUE$ tsp : logi TRUE> stopifnot(is.character(R[["class"]]),+ sapply(R[names(R) != "class"], isTRUE))> ## only "class" (and ".Data", ...) is reserved as slot name>> ## implicit generics ..> setMethod("sample", "C2",+ function(x, size, replace=FALSE, prob=NULL) {"sample.C2"})Creating a generic function for 'sample' from package 'base' in the global environment> stopifnot(is(sample,"standardGeneric"),+ ## the signature must come from the implicit generic:+ identical(sample@signature, c("x", "size")),+ identical(packageSlot(sample), "base"),+ ## default method must still work:+ identical({set.seed(3); sample(3)}, 1:3))> ## failed in R 2.11.0>> ## Still, signature is taken from "def"inition, if one is provided:> ## (For test, qqplot must be a "simple" function:)> stopifnot(is.function(qqplot) && identical(class(qqplot), "function"))> setGeneric("qqplot", function(x, y, ...) standardGeneric("qqplot"))Creating a new generic function for 'qqplot' in the global environment[1] "qqplot"> stopifnot(is(qqplot, "standardGeneric"),+ identical(qqplot@signature, c("x","y")))> ## failed for a day ~ 2005-05-26, for R-devel only>>> ## 'L$A@x <- ..'> setClass("foo", representation(x = "numeric"))> f <- new("foo", x = pi*1:2)> L <- list()> L$A <- f> L$A@x[] <- 7> if( identical(f, L$A) )+ stop("Oops! f is identical to L$A, even though not touched!")> ## did not duplicate in 2.0.0 <= Rversion <= 2.11.1>>> ## prototypes for virtual classes: NULL if legal, otherwise 1st member> ## "IntOrChar" had invalid NULL prototype < 2.15.0> setClassUnion("IntOrChar", c("integer", "character"))> stopifnot(exprs = {+ ## OptionalPosixct above includes NULL+ is.null (getClass("OptionalPOSIXct")@prototype)+ is.integer(getClass("IntOrChar") @prototype) ## produced an error < 2.15.0+ "IntOrChar" %in% extends(getClass("character"))+ "IntOrChar" %in% extends(getClass("integer"))+ identical(isGeneric("&&"), FALSE)+ })>>> ## mapply() on S4 objects with a "non-primitive" length() method> setClass("A", representation(aa="integer"))> aa <- 11:16> a <- new("A", aa=aa)> setMethod(length, "A", function(x) length(x@aa))> setMethod(`[[`, "A", function(x, i, j, ...) x@aa[[i]])> setMethod(`[`, "A", function(x, i, j, ...) new("A", aa = x@aa[i]))> setMethod("is.na","A", function(x) is.na(x@aa))> stopifnot(length(a) == 6, identical(a[[5]], aa[[5]]),+ identical(a, rev(rev(a))), # using '['+ identical(mapply(`*`, aa, rep(1:3, 2)),+ mapply(`*`, a, rep(1:3, 2))))> ## Up to R 2.15.2, internally 'a' is treated as if it was of length 1> ## because internal dispatch did not work for length().>> setMethod("is.unsorted", "A", function(x, na.rm, strictly)+ is.unsorted(x@aa, na.rm=na.rm, strictly=strictly))Creating a generic function for 'is.unsorted' from package 'base' in the global environment>> stopifnot(!is.unsorted(a), # 11:16 *is* sorted+ is.unsorted(rev(a)))>> # getSrcref failed when rematchDefinition was used> text <- '+ setClass("MyClass", representation(val = "numeric"))+ setMethod("plot", signature(x = "MyClass"),+ function(x, y, ...) {+ # comment+ NULL+ })+ setMethod("initialize", signature = "MyClass",+ function(.Object, value) {+ # comment+ .Object@val <- value+ return(.Object)+ })+ '> source(textConnection(text), keep.source = TRUE)> getSrcref(getMethod("plot", "MyClass"))function(x, y, ...) {# commentNULL}> getSrcref(getMethod("initialize", "MyClass"))function(.Object, value) {# comment.Object@val <- valuereturn(.Object)}>>> ## PR#15691> setGeneric("fun", function(x, ...) standardGeneric("fun"))[1] "fun"> setMethod("fun", "character", identity)> setMethod("fun", "numeric", function(x) {+ x <- as.character(x)+ callGeneric()+ })>> stopifnot(identical(fun(1), do.call(fun, list(1))))> ## failed in R < 3.1.0>>> ## PR#15680> setGeneric("f", function(x, y) standardGeneric("f"))[1] "f"> setMethod("f", c("numeric", "missing"), function(x, y) x)> try(?f(1))Error in .helpForCall(topicExpr, parent.frame()) :no documentation for function 'f' and signature 'x = "numeric", y = "missing"'>> ## "..." is not handled> setGeneric("f", function(...) standardGeneric("f"))[1] "f"> setMethod("f", "numeric", function(...) c(...))> try(?f(1,2))Error in .helpForCall(topicExpr, parent.frame()) :no documentation for function 'f' and signature '... = "numeric"'>> ## defaults in the generic formal arguments are not considered> setGeneric("f", function(x, y=0) standardGeneric("f"))[1] "f"> setMethod("f", c("numeric", "numeric"), function(x, y) x+y)> try(?f(1))Error in .helpForCall(topicExpr, parent.frame()) :no documentation for function 'f' and signature 'x = "numeric", y = "numeric"'>> ## Objects with S3 classes fail earlier> setGeneric("f", function(x) standardGeneric("f"))[1] "f"> setMethod("f", "numeric", function(x) x)> setOldClass(c("foo", "numeric"))> n <- structure(1, class=c("foo", "numeric"))> try(?f(n))Error in .helpForCall(topicExpr, parent.frame()) :no documentation for function 'f' and signature 'x = "numeric"'> ## different failures in R < 3.1.0.>>> ## identical() did not look at S4 bit:> a <- 1:5> b <- setClass("B", "integer")(a)> stopifnot(is.character(all.equal(a, b)))> attributes(a) <- attributes(b)> if(!isS4(a)) { # still (unfortunately)+ message("'a' is not S4 yet")+ if(identical(a,b)) stop("identical() not looking at S4 bit")+ ## set S4 bit manually:+ a <- asS4(a)+ }'a' is not S4 yet> stopifnot(identical(a, b), isS4(a))> ## failed in R <= 3.1.1>>> ### cbind(), rbind() now work both via rbind2(), cbind2() and rbind.> ##__ 1) __> setClass("A", representation(a = "matrix"))> setMethod("initialize", signature(.Object = "A"),+ function(.Object, y) {+ .Object@a <- y+ .Object+ })> setMethod("rbind2", signature(x = "A", y = "matrix"),+ function(x, y, ...) {+ cat("rbind2(<A>, <matrix>) : ")+ x@a <- rbind(x@a, y)+ cat(" x@a done\n")+ x+ })> setMethod("dim", "A", function(x) dim(x@a))> mat1 <- matrix(1:9, nrow = 3)> obj1 <- new("A", 10*mat1)> om1 <- rbind(obj1, mat1)## now does work {it does need a working "dim" method!}rbind2(<A>, <matrix>) : x@a done> stopifnot(identical(om1, rbind2(obj1, mat1)))rbind2(<A>, <matrix>) : x@a done> rm(obj1,om1); removeClass("A")[1] TRUE> ##> ##> ###__ 2) --- Matrix --- via cbind2(), rbind2()> ## this has its output checked strictly, so test depending on Matrix> ## has been moved to reg-tests-3.R> ##> ###__ 3) --- package 'its' like> setClass("its",representation("matrix", dates="POSIXt"))> m <- outer(1:3, setNames(1:5,LETTERS[1:5]))> im <- new("its", m, dates=as.POSIXct(Sys.Date()))> stopifnot(identical(m, im@.Data))> ii <- rbind(im, im-1)> i.i <- cbind(im, im-7)> stopifnot(identical(m, rbind(im)),+ identical(m, cbind(im)),+ identical(ii , rbind(m, m-1)),+ identical(i.i, cbind(m, m-7)))> rm(im, ii, i.i)> removeClass("its")[1] TRUE> ##> ##> ###__ 4) --- pkg 'mondate' like --> setClass("mondate",+ slots = c(timeunits = "character"), contains = "numeric")> three <- 3> m1 <- new("mondate", 1:4, timeunits = "hrs")> m2 <- new("mondate", 7:8, timeunits = "min")> stopifnot(identical(colnames(cbind(m1+1, deparse.level=2)), "m1 + 1"),+ is.null (colnames(cbind(m1+1, deparse.level=0))),+ is.null (colnames(cbind(m1+1, deparse.level=1))),+ identical(colnames(cbind(m1)), "m1"),+ colnames(cbind(m1 , M2 = 2, deparse.level=0)) == c("" , "M2"),+ colnames(cbind(m1 , M2 = 2)) == c("m1", "M2"),+ colnames(cbind(m1 , M2 = 2, deparse.level=2)) == c("m1", "M2"),+ colnames(cbind(m1+1, M2 = 2, deparse.level=2)) == c("m1 + 1", "M2"),+ colnames(cbind(m1+1, M2 = 2, deparse.level=1)) == c("", "M2"))> cbind(m1, three, m2)m1 three m2[1,] 1 3 7[2,] 2 3 8[3,] 3 3 7[4,] 4 3 8> cbind(m1, three, m2, deparse.level = 0) # none[,1] [,2] [,3][1,] 1 3 7[2,] 2 3 8[3,] 3 3 7[4,] 4 3 8> cbind(m1, three, m2+3, deparse.level = 1) # "m1" "three"m1 three[1,] 1 3 10[2,] 2 3 11[3,] 3 3 10[4,] 4 3 11> cbind(m1, three, m2+3, deparse.level = 2) -> m3> m3 # .... and "m2 + 3"m1 three m2 + 3[1,] 1 3 10[2,] 2 3 11[3,] 3 3 10[4,] 4 3 11> stopifnot(identical(t(m3), rbind(m1, three, m2+3, deparse.level = 2)),+ identical(cbind(m1, m2) -> m12,+ cbind(m1=m1@.Data, m2=m2@.Data)),+ identical(rbind(m1, m2), t(m12)),+ identical(cbind(m1, m2, T=T, deparse.level=0),+ cbind(m1@.Data, m2@.Data, T=T) -> mm),+ identical(colnames(mm), c("", "", "T")),+ identical(cbind(m1, m2, deparse.level=0),+ cbind(m1@.Data, m2@.Data)))> ##> ## Cleanup all class definitions etc -- seems necessary for the following "re"-definitions:> invisible(lapply(getClasses(globalenv()), removeClass))> nn <- names(globalenv())> rm(list = c("nn", nn))>> ## Using "data.frame" in a slot -- all have worked for long:> setClass("A", representation(slot1="numeric", slot2="logical"))> setClass("D1", contains="A", representation(design="data.frame"))> setClass("D2", contains="D1")> validObject(a <- new("A", slot1=77, slot2=TRUE))[1] TRUE> validObject(D. <- new("D2", a, design = data.frame(x = 1)))[1] TRUE> ## using "formula" in a slot -- from Hervé Pages :> setClass("B", contains="A", representation(design="formula"))> setClass("C", contains="B")> ##> a <- new("A", slot1=77, slot2=TRUE)> validObject(C1 <- new("C", a, design = x ~ y))# failed for R <= 3.2.0[1] TRUE> C2 <- new("C", slot1=a@slot1, slot2=a@slot2, design=x ~ y)> stopifnot(identical(C1, C2),+ identical(formula(), formula(NULL)),+ length(N <- new("formula")) == 0, inherits(N, "formula"),+ length(N <- new("table") ) == 0, is.table(N),+ validObject(N <- new("summary.table")),+ length(N <- new("ordered")) == 0, is.ordered(N))> ## formula() and new("formula"), new("..") also failed in R <= 3.2.0>> require("stats4")# -> "mle" class> validObject(sig <- new("signature", obj = "mle"))[1] TRUE> stopifnot(c("package", "names") %in% slotNames(sig))> str(sig) # failed, tooFormal class 'signature' [package "methods"] with 3 slots..@ .Data : chr "mle"..@ names : chr "obj"..@ package: chr "">> cl4 <- getClasses("package:stats4")> stopifnot(identical(getClasses(which(search() == "package:stats4")), cl4),+ c("mle", "profile.mle", "summary.mle") %in% cl4)> ## failed after an optimization patch>> detach("package:methods", force=TRUE)Warning message:package 'methods' is required by 'Matrix', which may no longer work correctly> C1@slot1 <- pi> stopifnot(identical(C1@slot1, pi))> stopifnot(require("methods"))Loading required package: methods> ## Slot assignment failed in R <= 3.2.2, C code calling checkAtAssignment()>> ## Error in argument evaluation of S4 generic - PR#16111> f <- function() {+ signal <- FALSE+ withCallingHandlers({ g(sqrt(-1)) }, warning = function(w) {+ signal <<- TRUE+ invokeRestart("muffleWarning")+ })+ signal+ }> g <- function(x) x> op <- options(warn = 2)# warnings give errors> stopifnot(isTRUE( f() ))> setGeneric("g")[1] "g"> stopifnot(isTRUE( f() ))> options(op)> ## the second f() gave a warning and FALSE in R versions 2.12.0 <= . <= 3.2.3>>> stopifnot(+ identical(formals(getGeneric("as.vector")), formals(base::as.vector)),+ identical(formals(getGeneric("unlist")), formals(base::unlist)))> ## failed for a while in R-devel (3.3.0)>> setClass("myInteger", contains=c("integer", "VIRTUAL"))> setClass("mySubInteger", contains="myInteger")> new("mySubInteger", 1L)An object of class "mySubInteger"[1] 1> ## caused infinite recursion in R 3.3.0> new("mySubInteger")An object of class "mySubInteger"integer(0)> ## failed due to lack of prototype in R 3.6.0>> detach("package:methods", force=TRUE)Warning message:package 'methods' is required by 'Matrix', which may no longer work correctly> methods::setClass("test1", methods::representation(date="POSIXct"))> methods::setClass("test2", contains="test1")> test <- function(x) UseMethod('test', x)> test.test1 <- function(x) 'Hi'> test(methods::new("test2", date=as.POSIXct("2003-10-09")))[1] "Hi"> stopifnot(require("methods"))Loading required package: methods> ## S3 dispatch to superclass methods failed on S4 objects when> ## methods package was not attached>>> ## Tests for class fetching and conflict resolution> setClass("htest1", slots=c(a="numeric",b="data.frame"), package="package1")> setClass("htest2", slots=c(a="logical"), package="package2")> class.list = list(+ package1=getClassDef("htest1", where=class_env1),+ package2=getClassDef("htest2", where=class_env2)+ )>> firstclass <- methods:::.resolveClassList(class.list,.GlobalEnv,+ package="package1")> secondclass <- methods:::.resolveClassList(class.list,.GlobalEnv,+ package="package2")> alsofirstclass <- methods:::.resolveClassList(class.list,.GlobalEnv,+ package="package3")Found more than one class "htest1" in cache; using the first, from namespace 'package1'Also defined by 'package2'> stopifnot(!identical(firstclass, secondclass))> stopifnot(identical(firstclass, class.list[[1]]))> stopifnot(identical(secondclass, class.list[[2]]))> stopifnot(identical(alsofirstclass, class.list[[1]]))>> ## implicit coercion of S4 object to vector via as.vector() in sub-assignment> setClass("A", representation(stuff="numeric"))> as.vector.A <- function (x, mode="any") x@stuff> v <- c(3.5, 0.1)> a <- new("A", stuff=v)> x <- y <- numeric(10)> x[3:4] <- a> y[3:4] <- v> stopifnot(identical(x, y))>> ## callNextMethod() was broken when augmenting args of primitive generics> foo <- setClass("foo")> bar <- setClass("bar", contains = "foo")>> setMethod("[", "foo", function(x, i, j, ..., flag = FALSE, drop = FALSE) {+ flag+ })>> setMethod("[", "bar", function(x, i, j, ..., flag = FALSE, drop = FALSE) {+ callNextMethod()+ })>> BAR <- new("bar")> stopifnot(identical(BAR[1L], FALSE))> stopifnot(identical(BAR[1L, , flag=TRUE], TRUE))>> ## avoid infinite recursion on Ops,structure methods> setClass("MyInteger",+ representation("integer")+ )> i <- new("MyInteger", 1L)> m <- matrix(rnorm(300), 30,10)> stopifnot(identical(i*m, m))>> ## when rematching, do not drop arg with NULL default> setGeneric("genericExtraArg",+ function(x, y, extra) standardGeneric("genericExtraArg"),+ signature="x")[1] "genericExtraArg">> setMethod("genericExtraArg", "ANY", function(x, y=NULL) y)>> stopifnot(identical(genericExtraArg("foo", 1L), 1L))>> ## callNextMethod() was broken for ... dispatch> f <- function(...) length(list(...))> setGeneric("f")[1] "f"> setMethod("f", "character", function(...){ callNextMethod() })> stopifnot(identical(f(1, 2, 3), 3L))> stopifnot(identical(f("a", "b", "c"), 3L))>> ## ... dispatch was evaluating missing arguments in the generic frame> f <- function(x, ..., a = b) {+ b <- "a"+ a+ }> setGeneric("f", signature = "...")[1] "f"> stopifnot(identical(f(a=1), 1))> stopifnot(identical(f(), "a"))>> ## ensure forwarding works correctly for dots dispatch> f2 <- function(...) f(...)> stopifnot(identical(f2(a=1), 1))>>> ## R's internal C R_check_class_and_super() was not good enough> if(require("Matrix", lib.loc = .Library, quietly = TRUE)) { withAutoprint({+ setClass("Z", representation(zz = "list"))+ setClass("C", contains = c("Z", "dgCMatrix"))+ setClass("C2", contains = "C")+ setClass("C3", contains = "C2")+ m <- matrix(c(0,0,2:0), 3,5, dimnames = list(NULL,NULL))+ m2 <- matrix(c(0,0,2:0), 3,5)+ (mC <- as(m, "dgCMatrix"))+ (cc <- as(mC, "C"))+ c2 <- as(mC, "C2")+ c3 <- as(mC, "C3")+ stopifnot(+ identical(capture.output(c2),+ sub("C3","C2", capture.output(c3)))+ , identical(as(cc, "matrix"), m2) # changed for Matrix 1.5-x+ , identical(as(c2, "matrix"), m2)+ , identical(as(c3, "matrix"), m2)+ )+ invisible(lapply(c("Z","C","C2","C3"), removeClass))+ })+ } else+ message("skipping tests requiring the Matrix package")> setClass("Z", representation(zz = "list"))> setClass("C", contains = c("Z", "dgCMatrix"))> setClass("C2", contains = "C")> setClass("C3", contains = "C2")> m <- matrix(c(0, 0, 2:0), 3, 5, dimnames = list(NULL, NULL))> m2 <- matrix(c(0, 0, 2:0), 3, 5)> (mC <- as(m, "dgCMatrix"))3 x 5 sparse Matrix of class "dgCMatrix"[1,] . 1 . . 2[2,] . . 2 . 1[3,] 2 . 1 . .> (cc <- as(mC, "C"))3 x 5 sparse Matrix of class "C"[1,] . 1 . . 2[2,] . . 2 . 1[3,] 2 . 1 . .> c2 <- as(mC, "C2")> c3 <- as(mC, "C3")> stopifnot(identical(capture.output(c2), sub("C3", "C2", capture.output(c3))),+ identical(as(cc, "matrix"), m2), identical(as(c2, "matrix"), m2), identical(as(c3,+ "matrix"), m2))> invisible(lapply(c("Z", "C", "C2", "C3"), removeClass))>>> ## Automatic coerce method creation:> setClass("A", slots = c(foo = "numeric"))> setClass("Ap", contains = "A", slots = c(p = "character"))> cd <- getClassDef("Ap")> body(cd@contains[["A"]]@coerce)[[2]] ## >> value <- new("A")value <- new("A")> ## was ... <- new(structure("A", package = ".GlobalEnv"))> ## for a few days in R-devel (Nov.2017)>>> ## Error messages occurring during method selection are forwarded> f <- function(x) x> setGeneric("f")[1] "f"> setMethod("f", signature("NULL"), function(x) NULL)> err <- tryCatch(f(stop("this is mentioned")), error = identity)> stopifnot(identical(err$message, "error in evaluating the argument 'x' in selecting a method for function 'f': this is mentioned"))>>> ## canCoerce(obj, .) when length(class(obj)) > 1 :> setOldClass("foo")> setAs("foo", "A", function(from) new("A", foo=from))> o3 <- structure(1:7, class = c("foo", "bar"))> stopifnot( canCoerce(o3, "A") )> ## failed in R <= 3.6.1>> if(require("Matrix", lib.loc = .Library, quietly = TRUE)) { withAutoprint({+ sci <- names(getClass("integer")@contains)+ # These 2 classes have *nothing* to do with Matrix:+ setClass("MyClass")+ ncl <- "NumOrMyClass"+ setClassUnion(ncl, c("numeric", "MyClass"))+ nsci <- names(getClass("integer")@contains)+ ## failed in R <= 3.6.2+ stopifnot(sci %in% nsci, identical(setdiff(nsci, sci), ncl))++ setClassUnion('dMatrixOrMatrix', members = c('dMatrix', 'matrix'))+ ## failed in R <= 3.6.2+ stopifnot("dMatrixOrMatrix" %in% names(getClass("dgCMatrix")@contains))++ invisible(lapply(c("NumOrMyClass", "MyClass", "dMatrixOrMatrix"),+ removeClass))+ })+ } else+ message("skipping tests requiring the Matrix package")> sci <- names(getClass("integer")@contains)> setClass("MyClass")> ncl <- "NumOrMyClass"> setClassUnion(ncl, c("numeric", "MyClass"))> nsci <- names(getClass("integer")@contains)> stopifnot(sci %in% nsci, identical(setdiff(nsci, sci), ncl))> setClassUnion("dMatrixOrMatrix", members = c("dMatrix", "matrix"))> stopifnot("dMatrixOrMatrix" %in% names(getClass("dgCMatrix")@contains))> invisible(lapply(c("NumOrMyClass", "MyClass", "dMatrixOrMatrix"), removeClass))>> setClass("foo", slots = c(y = "numeric"))> setClass("bar", contains = "foo")> body(getClass("bar")@contains[[1]]@coerce)[[2]]class(from) <- "foo">