The R Project SVN
R
(root)/tags/R-2-8-0/tests/reg-S4.Rout.save – Rev 46755
Rev 46553 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
R version 2.8.0 Under development (unstable) (2008-09-15 r46542)Copyright (C) 2008 The R Foundation for Statistical ComputingISBN 3-900051-07-0R 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)> options(useFancyQuotes=FALSE)> library(methods)> ##too fragile: showMethods(where = "package:methods")>> ##-- S4 classes with S3 slots [moved from ./reg-tests-1.R]> setClass("test1", representation(date="POSIXct"))[1] "test1"> 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))[1] "f">> ## 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.> setClass("bar", representation(a="numeric"))[1] "bar"> 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")})[1] "show"> 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)>> print.bar <- function(x, ...) cat("print method\n")> fooshow method> print(foo)print method> show(foo)show method>> setMethod("print", "bar", function(x, ...){cat("S4 print method\n")})Creating a new generic function for "print" in ".GlobalEnv"[1] "print"> 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>> setClassUnion("integer or NULL", members = c("integer","NULL"))[1] "integer or NULL"> setClass("c1", representation(x = "integer", code = "integer or NULL"))[1] "c1"> 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> ##>>> library(stats4)> 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}>> ## the following showMethods() output tends to generate errors in the tests> ## whenever the contents of the packages change. Searching in the> ## diff's can easily mask real problems. If there is a point> ## to the printout, e.g., to verify that certain methods exist,> ## hasMethod() would be a useful replacement>> ## showMethods(where = "package:stats4")> ## showMethods("show")> ## showMethods("show")> ## showMethods("plot") # (ANY,ANY) and (profile.mle, missing)> ## showMethods(classes="mle")> ## showMethods(classes="matrix")>>> ##--- "[" 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"))[1] "Mat"> setMethod("[", signature(x = "Mat",+ i = "missing", j = "missing", drop = "ANY"),+ function (x, i, j, drop) x)[1] "["> ## 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"))[1] "X"> setClass("Y", contains="X")[1] "Y"> ## 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"))[1] "foo"> setMethod("foo", signature(object= "Y", arg="missing"),+ function(object, arg) cat("a Y object with bar =", object@bar, "\n"))[1] "foo"> ## 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") )[1] "foo"> ## 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"))[1] "A"> setClass("B", representation(y = "character"))[1] "B"> setClass("C", contains = c("A", "B"), representation(z = "logical"))[1] "C"> 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))[1] "C"> (cc <- new("C"))An object of class "C"Slot "z":[1] TRUESlot "x":[1] 1.5Slot "y":[1] "test"> ## failed reconcilePropertiesAndPrototype(..) after svn r37018>>> ## "Logic" group -- was missing in R <= 2.4.0> stopifnot(all(getGroupMembers("Logic") %in% c("&", "|")),+ any(getGroupMembers("Ops") == "Logic"))> setClass("brob", contains="numeric")[1] "brob"> 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)[1] "Logic"> setMethod("Logic", signature("ANY", "brob"), logic2)[1] "Logic"> ## Now ensure that using group members gives error:> assertError <- function(expr)+ stopifnot(inherits(try(expr, silent = TRUE), "try-error"))> assertWarning <- function(expr)+ stopifnot(inherits(tryCatch(expr, warning = function(w)w), "warning"))> assertWarning_atleast <- function(expr) {+ r <- tryCatch(expr, warning = function(w)w, error = function(e)e)+ stopifnot(inherits(r, "warning") || inherits(r, "error"))+ }>> assertError(b & b)Warning message:Ambiguous method selection for "&", target "brob#brob" (the first of the signatures shown will be used)brob#ANYANY#brob> assertError(b | 1)> assertError(TRUE & b)>>> ## methods' hidden cbind() / rbind:> cBind <- methods:::cbind> setClass("myMat", representation(x = "numeric"))[1] "myMat"> setMethod("cbind2", signature(x = "myMat", y = "missing"), function(x,y) x)[1] "cbind2"> m <- new("myMat", x = c(1, pi))> stopifnot(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")[1] "Foo"> (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))> 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")[1] "myMat"> setClass("mmat2", contains="matrix")[1] "mmat2"> setClass("mmat3", contains="mmat2")[1] "mmat3"> setMethod(Gfun, signature(x = "myMat"),+ function(x, extrarg = TRUE) {+ cat("in 'myMat' method for 'Gfun() : extrarg=", extrarg, "\n")+ Gfun(unclass(x))+ })[1] "Gfun"attr(,"package")[1] ".GlobalEnv"> setMethod(Gfun, signature(x = "mmat2"),+ function(x, extrarg = TRUE) {+ cat("in 'mmat2' method for 'Gfun() : extrarg=", extrarg, "\n")+ x <- unclass(x)+ callGeneric()+ })[1] "Gfun"attr(,"package")[1] ".GlobalEnv"> setMethod(Gfun, signature(x = "mmat3"),+ function(x, extrarg = TRUE) {+ cat("in 'mmat3' method for 'Gfun() : extrarg=", extrarg, "\n")+ x <- as(x, "mmat2")+ callGeneric()+ })[1] "Gfun"attr(,"package")[1] ".GlobalEnv"> 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()+ })[1] "Gf"attr(,"package")[1] ".GlobalEnv"> setMethod(Gf, signature(x = "mmat3"),+ function(x, ...) {+ cat("in 'mmat3' method for 'Gf()\n")+ x <- as(x, "mmat2")+ callGeneric()+ })[1] "Gf"attr(,"package")[1] ".GlobalEnv"> setMethod(Gf, signature(x = "matrix"),+ function(x, a1, ...) {+ cat(sprintf("matrix %d x %d ...\n", nrow(x), ncol(x)))+ list(x=x, a1=a1, ...)+ })[1] "Gf"attr(,"package")[1] ".GlobalEnv">> 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")[1] "c1"> setClass("c2", "numeric")[1] "c2"> 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")[1] "as.character"> as.character(x_c1)[1] "fn test">> setMethod("as.integer", "c1", function(x, ...) 42)[1] "as.integer"> as.integer(x_c1)[1] 42>> setMethod("as.logical", "c1", function(x, ...) NA)[1] "as.logical"> as.logical(x_c1)[1] NA>> setMethod("as.complex", "c1", function(x, ...) pi+0i)[1] "as.complex"> as.complex(x_c1)[1] 3.141593+0i>> setMethod("as.raw", "c1", function(x) as.raw(10))[1] "as.raw"> 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)[1] "as.numeric"> identical(as.numeric(x_c1),as.double(x_c1))[1] TRUE> identical(as.numeric(x_c1),as.real(x_c1))[1] TRUE>>> setMethod(as.double, "c2", function(x, ...) x@.Data+pi)[1] "as.numeric"> x_c2 <- new("c2", pi)> identical(as.numeric(x_c2),as.double(x_c2))[1] TRUE> identical(as.numeric(x_c2),as.real(x_c2))[1] TRUE>> ## '!' changed signature from 'e1' to 'x' in 2.6.0> setClass("foo", "logical")[1] "foo"> setMethod("!", "foo", function(e1) e1+NA)[1] "!"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 failed for about one day -- as.vector(x, mode) :> setMethod("as.vector", signature(x = "foo", mode = "missing"),+ function(x) unclass(x))Creating a new generic function for "as.vector" in ".GlobalEnv"[1] "as.vector"> ## whereas this fails in R versions earlier than 2.6.0:> setMethod("as.vector", "foo", function(x) unclass(x))# gives messageIn method for function "as.vector": expanding the signature toinclude omitted arguments in definition: mode = "missing"[1] "as.vector">> ## 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"))[1] "Mat"> setClass("dMat", representation(x = "numeric", "VIRTUAL"), contains = "Mat")[1] "dMat"> setClass("CMat", representation(dnames = "list","VIRTUAL"), contains = "Mat")[1] "CMat"> setClass("dCMat", contains = c("dMat", "CMat"))[1] "dCMat"> stopifnot(!isVirtualClass("dCMat"),+ length(slotNames(new("dCMat"))) == 3)>>> ## Passing "..." arguments in nested callGeneric()s> setClass("m1", contains="matrix")[1] "m1"> setClass("m2", contains="m1")[1] "m2"> setClass("m3", contains="m2")[1] "m3"> ##> setGeneric("foo", function(x, ...) standardGeneric("foo"))[1] "foo"> setMethod("foo", signature(x = "m1"),+ function(x, ...) cat(" <m1> ", format(match.call()),"\n"))[1] "foo"> setMethod("foo", signature(x = "m2"),+ function(x, ...) {+ cat(" <m2> ", format(match.call()),"\n")+ x <- as(x, "m1"); callGeneric()+ })[1] "foo"> setMethod("foo", signature(x = "m3"),+ function(x, ...) {+ cat(" <m3> ", format(match.call()),"\n")+ x <- as(x, "m2"); callGeneric()+ })[1] "foo"> 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"))[1] "OptionalPOSIXct"> 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", "Math", "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),+ ## isGeneric("dim", where=as.environment("package:Matrix"))+ 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"> ## TODO: use "Matrix" checks once that is >= 1.0>> ## containing "array" ("matrix", "ts", ..)> t. <- ts(1:10, frequency = 4, start = c(1959, 2))> setClass("Arr", contains= "array"); x <- new("Arr", cbind(17))[1] "Arr"> setClass("Ts", contains= "ts"); tt <- new("Ts", t.); t2 <- as(t., "Ts")[1] "Ts"> setClass("ts2", representation(x = "Ts", y = "ts"))[1] "ts2"> 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"> assertWarning_atleast(+ setMethod("test1", "numeric", function(x, name, printit) match.call())+ )## 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"))[1] "moo"> 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>