R Under development (unstable) (2023-08-15 r84951) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu 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/ > #### ------------------------ > ### - checking console output <--> *.Rout.save > ### - *no* platform dependency, no recommended pkg <--> strict checking > > 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.2 Class "standardGeneric" [package "methods"] Slots: Name: .Data generic package group Class: function character character list Name: valueClass signature default skeleton Class: character character optionalMethod call Extends: Class "genericFunction", directly Class "function", by class "genericFunction", distance 2 Class "OptionalFunction", by class "function", distance 3 Class "PossibleMethod", by class "function", distance 3 Class "optionalMethod", by class "genericFunction", distance 4 Known Subclasses: "standardGenericWithTrace" > stopifnot(.isMethodsDispatchOn()) ## was FALSE in R <= 3.2.2 > > > ## Needs cached primitive generic for '$' > new("envRefClass")# failed in R <= 3.2.0 Reference 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) > foo An 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 > foo show 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")}) > foo show 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.0 Formal 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] TRUE Slot "x": [1] 1.5 Slot "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,] NA Slot "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= TRUE in 'myMat' method for 'Gfun() : extrarg= TRUE in 'myMat' method for 'Gfun() : extrarg= FALSE in '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= TRUE in 'mmat2' method for 'Gfun() : extrarg= TRUE [1] 3 > Gfun(m3, extrarg = FALSE) # used to not pass 'extrarg' in 'mmat3' method for 'Gfun() : extrarg= FALSE in '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 + NA Signatures: x target "foo" defined "foo" > xx <- new("foo", FALSE) > !xx An 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(" ", format(match.call()),"\n")) > setMethod("foo", signature(x = "m2"), + function(x, ...) { + cat(" ", format(match.call()),"\n") + x <- as(x, "m1"); callGeneric() + }) > setMethod("foo", signature(x = "m3"), + function(x, ...) { + cat(" ", format(match.call()),"\n") + x <- as(x, "m2"); callGeneric() + }) > foo(new("m1"), bla = TRUE) foo(x = new("m1"), bla = TRUE) > foo(new("m2"), bla = TRUE) foo(x = new("m2"), bla = TRUE) foo(x = x, bla = TRUE) > foo(new("m3"), bla = TRUE) foo(x = new("m3"), bla = TRUE) foo(x = x, bla = TRUE) 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" > > ## 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( ) > ## 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 3 attr(,"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-[ : FALSE NULL > y[1, drop=FALSE] drop in C2-[ : FALSE drop in C1-[ : FALSE NULL > ## 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, ...) { # comment NULL } > getSrcref(getMethod("initialize", "MyClass")) function(.Object, value) { # comment .Object@val <- value return(.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(, ) : ") + 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(, ) : x@a done > stopifnot(identical(om1, rbind2(obj1, mat1))) rbind2(, ) : 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, too Formal 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) > 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) > 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]])) > > > ## 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 <- methods::new("A") value <- methods::new("A") > ## was ... <- new(structure("A", package = ".GlobalEnv")) > ## for a few days in R-devel (Nov.2017) > > > setClass("foo", slots = c(y = "numeric")) > setClass("bar", contains = "foo") > body(getClass("bar")@contains[[1]]@coerce)[[2]] class(from) <- "foo" >