The R Project SVN R

## simple call, only field names

fg <- setRefClass("foo", c("bar", "flag"))

f1 <- new("foo")

f1$bar

f1 <- fg$new(flag = "testing")

f1$bar <- 1

stopifnot(identical(f1$bar, 1))

fg$methods(showAll = function() c(bar, flag))

stopifnot(all.equal(f1$showAll(), c(1, "testing")))

str(f1)

fg <- setRefClass("foo", list(bar = "numeric", flag = "character",

                              tag = "ANY"),

                  methods = list(addToBar = function(incr) {

                      b <- bar + incr

                      bar <<- b

                      b

                  } )

                  )

ff <- new("foo", bar = 1.5)

stopifnot(identical(ff$bar, 1.5))

ff$bar <- pi

stopifnot(identical(ff$bar, pi))

## test against generator

f2 <- fg$new(bar = pi)

## identical does not return TRUE if *contents* of env are identical

stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))

f2$flag <- "standard flag"

stopifnot(identical(f2$flag, "standard flag"))

str(f2)

## fg$lock("flag")

## tryCatch(f2$flag <- "other", error = function(e)e)

## add some accessor methods

fg$accessors("bar")

ff$setBar(1:3)

stopifnot(identical(ff$getBar(), 1:3))

ff$getBar()

stopifnot(all.equal(ff$addToBar(1), 2:4))

## Add a method

fg$methods(barTimes = function(x) {

    "This method multiples field bar by argument x

and this string is self-documentation"

    setBar(getBar() * x)})

ffbar <- ff$getBar()

ff$barTimes(10)

stopifnot(all.equal(ffbar * 10, ff$getBar()))

ff$barTimes(.1)

## inheritance.  redefines flag so should fail:

stopifnot(is(tryCatch(setRefClass("foo2", list(b2 = "numeric",

					       flag = "complex"),

            contains = "foo",

            refMethods = list(addBoth = function(incr) {

                addToBar(incr) #uses inherited class method

                setB2(getB2() + incr)

                })),

          error = function(e)e), "error"))

## but with flag as a subclass of "character", should work

## Also subclasses "tag" which had class "ANY before

setClass("ratedChar", contains = "character",

         representation(score = "numeric"))

foo2 <- setRefClass("foo2", list(b2 = "numeric", flag = "ratedChar",

				 tag = "numeric"),

	    contains = "foo",

	    methods = list(addBoth = function(incr) {

                addToBar(incr) #uses inherited class method

                b2 <<- b2 + incr

                }))

## now lock the flag field; should still allow one write

foo2$lock("flag")

f2 <- foo2$new(bar = -3, flag = as("ANY", "ratedChar"),

               b2 = ff$bar, tag = 1.5)

## but not a second one

stopifnot(is(tryCatch(f2$flag <- "Try again",

         error = function(e)e), "error"))

str(f2)

f22 <- foo2$new(bar = f2$bar)

## same story if assignment follows the initialization

f22$flag <- f2$flag

stopifnot(is(tryCatch(f22$flag <- "Try again",

         error = function(e)e), "error"))

## Exporting superclass object

f22 <- fg$new(bar = f2$bar, flag = f2$flag)

f2e <- f2$export("foo")

stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),

          identical(class(f2e), class(f22)))

stopifnot(identical(f2$flag,  as("ANY", "ratedChar")),

          identical(f2$bar, -3),

          all.equal(f2$b2, 2:4+0))

f2$addBoth(-1)

stopifnot(all.equal(f2$bar, -4), all.equal(f2$b2, 1:3+0))

## test callSuper()

setRefClass("foo3", fields = list(flag2 = "ratedChar"),

            contains = "foo2",

	    methods = list(addBoth = function(incr) {

		callSuper(incr)

		flag2 <<- as(paste(flag, paste(incr, collapse = ", "),

				   sep = "; "),

                             "ratedChar")

                incr

            }))

f2 <- foo2$new(bar = -3, flag = as("ANY", "ratedChar"), b2 =  1:3)

f3 <- new("foo3")

f3$import(f2)

stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar),

          all.equal(f3$flag, f2$flag))

f3$addBoth(1)

stopifnot(all.equal(f3$bar, -2), all.equal(f3$b2, 2:4+0),

          all.equal(f3$flag2, as("ANY; 1", "ratedChar")))

## but the import should have used up the one write for $flag

stopifnot(is(tryCatch(f3$flag <- "Try again",

         error = function(e)e), "error"))

str(f3)

## a class with an initialize method, and an extra slot

setOldClass(c("simple.list", "list"))

fg4 <- setRefClass("foo4",

            contains = "foo2",

            methods = list(

              initialize = function(...) {

                  .self$initFields(...)

                  .self@made <<- R.version

                  .self

              }),

            representation = list(made = "simple.list")

            )

f4 <- new("foo4", flag = "another test", bar = 1:3)

stopifnot(identical(f4@made, R.version))

## a trivial class with no fields, using fields = list(), failed up to rev 56035

foo5 <- setRefClass("foo5", fields = list(),

                    methods = list(bar = function(test)

                    paste("*",test,"*")))

f5 <- foo5$new()

stopifnot(identical( f5$bar("xxx"), paste("*","xxx", "*")))

## simple active binding test

abGen <- setRefClass("ab",

                  fields = list(a = "ANY",

                  b = function(x) if(missing(x)) a else {a <<- x; x}))

ab1 <- abGen$new(a = 1)

stopifnot(identical(ab1$a, 1), identical(ab1$b, 1))

ab1$b <- 2

stopifnot(identical(ab1$a, 2), identical(ab1$b, 2))

## a simple editor for matrix objects.  Method  $edit() changes some

## range of values; method $undo() undoes the last edit.

mEditor <- setRefClass("matrixEditor",

        fields = list(data = "matrix",

		     edits = "list"),

       methods = list(

     edit = function(i, j, value) {

       ## the following string documents the edit method

       'Replaces the range [i, j] of the

	object by value.

        '

         backup <-

             list(i, j, data[i,j])

         data[i,j] <<- value

         edits <<- c(list(backup),

                     edits)

         invisible(value)

     },

     undo = function() {

       'Undoes the last edit() operation

        and update the edits field accordingly.

        '

         prev <- edits

         if(length(prev)) prev <- prev[[1]]

         else stop("No more edits to undo")

         edit(prev[[1]], prev[[2]], prev[[3]])

         ## trim the edits list

         length(edits) <<- length(edits) - 2

         invisible(prev)

     }

     ))

xMat <- matrix(1:12,4,3)

xx <- mEditor$new(data = xMat)

xx$edit(2, 2, 0)

xx$data

xx$undo()

mEditor$help("undo")

stopifnot(all.equal(xx$data, xMat))

## add a method to save the object

mEditor$methods(

     save = function(file) {

       'Save the current object on the file

        in R external object format.

       '

         base::save(.self, file = file)

     }

)

tf <- tempfile()

xx$save(tf) #$

load(tf)

unlink(tf)

stopifnot(identical(xx$data, .self$data))

markViewer <- ""

setMarkViewer <- function(what)

    markViewer <<- what

## Inheriting a reference class:  a matrix viewer

mv <- setRefClass("matrixViewer",

    fields = c("viewerDevice", "viewerFile"),

    contains = "matrixEditor",

    methods = list( view = function() {

        dd <- dev.cur(); dev.set(viewerDevice)

        devAskNewPage(FALSE)

        matplot(data, main = paste("After",length(edits),"edits"))

        dev.set(dd)},

        edit = # invoke previous method, then replot

          function(i, j, value) {

            callSuper(i, j, value)

            view()

          }))

## initialize and finalize methods

mv$methods( initialize = function(file = "./matrixView.pdf", ...) {

    viewerFile <<- file

    pdf(viewerFile)

    viewerDevice <<- dev.cur()

    message("Plotting to ", viewerFile)

    dev.set(dev.prev())

    setMarkViewer("ON")

    initFields(...)

  },

  finalize = function() {

    dev.off(viewerDevice)

    setMarkViewer("OFF")

  })

ff <- mv$new( data = xMat)

stopifnot(identical(markViewer, "ON")) # check initialize

ff$edit(2,2,0)

ff$data

ff$undo()

stopifnot(all.equal(ff$data, xMat))

rm(ff)

gc()

stopifnot(identical(markViewer, "OFF")) #check finalize

## tests of copying

viewerPlus <- setRefClass("viewerPlus",

                   fields = list( text = "character",

                      viewer = "matrixViewer"))

ff <- mv$new( data = xMat)

v1 <- viewerPlus$new(text = letters, viewer = ff)

v2 <- v1$copy()

v3 <- v1$copy(TRUE)

v2$text <- "Hello, world"

v2$viewer$data <- t(xMat) # change a field in v2$viewer

v3$text <- LETTERS

v3$viewer <- mv$new( data = matrix(nrow=1,ncol=1))

## with a deep copy all is protected, with a shallow copy

## the environment of a copied field remains the same,

## but replacing the whole field should be local

stopifnot(identical(v1$text, letters),

          identical(v1$viewer, ff),

          identical(v2$text, "Hello, world"))

v3 <- v1$copy(TRUE)

v3$viewer$data <- t(xMat) # should modify v1$viewer as well

stopifnot(identical(v1$viewer$data, t(xMat)))

## the field() method

stopifnot(identical(v1$text, v1$field("text")))

v1$field("text", "Now is the time")

stopifnot(identical(v1$field("text"), "Now is the time"))

## setting a non-existent field, or a method, should throw an error

stopifnot(is(tryCatch(v1$field("foobar", 0), error = function(e)e), "error"),

         is(tryCatch(v1$field("copy", 0), error = function(e)e), "error") )

## the methods to extract class definition and generator

stopifnot(identical(v3$getRefClass()$def, getRefClass("viewerPlus")$def),

          identical(v3$getClass(), getClass("viewerPlus")))

## deal correctly with inherited methods and overriding existing

## methods from $methods(...)

refClassA <- setRefClass("refClassA", methods=list(foo=function() "A"))

refClassB <- setRefClass("refClassB", contains="refClassA")

mnames <- objects(getClass("refClassB")@refMethods)

refClassB$methods(foo=function() callSuper())

stopifnot(identical(refClassB$new()$foo(), "A"))

mnames2 <- objects(getClass("refClassB")@refMethods)

stopifnot(identical(mnames2[is.na(match(mnames2,mnames))], "foo#refClassA"))

refClassB$methods(foo=function() paste(callSuper(), "Version 2"))

stopifnot(identical(refClassB$new()$foo(), "A Version 2"))

stopifnot(identical(mnames2, objects(getClass("refClassB")@refMethods)))

if(methods:::.hasCodeTools()) {

    ## code warnings assigning locally to field names

    stopifnot(is(tryCatch(mv$methods(test = function(x)

                                 { data <- x[!is.na(x)]; mean(data)}),

                          warning = function(e)e), "warning"))

    ## warnings for nonlocal assignment that is not a field

    stopifnot(is(tryCatch(mv$methods(test2 = function(x) {something <<- data[!is.na(x)]}), warning = function(e)e), "warning"))

    ## error for trying to assign to a method name

    stopifnot(is(tryCatch(mv$methods(test3 = function(x) {edit <<- data[!is.na(x)]}), error = function(e)e), "error"))

} else

    warning("Can't run some tests:  recommended package codetools is not available")

## tests (fragmentary by necessity) of promptClass for reference class

ccon <- textConnection("ctxt", "w")

suppressMessages(promptClass("refClassB", filename = ccon))

## look for a method, inheritance, inherited method

stopifnot(length(c(grep("foo.*refClassA", ctxt),

                   grep("code{foo()}", ctxt, fixed = TRUE),

                   grep("linkS4class{refClassA", ctxt, fixed = TRUE))) >= 3)

close(ccon)

rm(ctxt)

## tests related to subclassing environments.  These really test code in the core, viz. builtin.c

a <- refClassA$new()

ev <- new.env(parent = a) # parent= arg

stopifnot(is.environment(ev))

foo <- function()"A"; environment(foo) <- a # environment of function

stopifnot(identical(as.environment(a), environment(foo)))

xx <- 1:10; environment(xx) <- a # environment attribute

stopifnot(identical(as.environment(a), environment(xx)))

## tests of [[<- and $<- for subclasses of environment.  At one point

## methods for these assignments were defined and caused

## inf. recursion when the arguments to the [[<- case were changed in base.

setClass("myEnv", contains = "environment")

m <- new("myEnv", a="test")

m2 <- new("myEnv"); m3 <- new("myEnv")

## test that new.env() is called for each new object

stopifnot(!identical(as.environment(m), as.environment(m2)),

          !identical(as.environment(m3), as.environment(m2)))

m[["x"]] <- 1; m$y <- 2

stopifnot(identical(c(m[["x"]], m$y), c(1,2)), is(m, "myEnv"))

rm(x, envir = m) # check rm() works, does not clobber class

stopifnot(identical(sort(objects(m)), sort(c("a", "y"))),

          is(m, "myEnv"))

## tests of binding & environment tools with subclases of environment

lockBinding("y", m)

stopifnot(bindingIsLocked("y", m))

unlockBinding("y", m)

stopifnot(!bindingIsLocked("y", m))

makeActiveBinding("z", function(value) {

    if(missing(value))

        "dummy"

    else

        "dummy assignment"

}, m)

stopifnot(identical(get("z", m),"dummy"))

## assignment will return the value but do nothing

stopifnot(identical(assign("z","other", m), "other"),

          identical(get("z", m),"dummy"))

## this has to be last--Seems no way to unlock an environment!

lockEnvironment(m)

stopifnot(environmentIsLocked(m))

rm(m)

m <- new("myEnv")

stopifnot(length(ls(m)) == 0)

## used to contain the previous content

## test of callSuper() to a hidden default method for initialize() (== initFields)

TestClass <- setRefClass ("TestClass",

     fields = list (text = "character"),

     methods = list(

       print = function ()  {cat(text)},

       initialize = function(text = "", ...) callSuper(text = paste(text, ":", sep=""),...)

  ))

tt <- TestClass$new("hello world")

stopifnot(identical(tt$text, "hello world:"))

## now a subclass with another field & another layer of callSuper()

TestClass2 <- setRefClass("TestClass2",

        contains = "TestClass",

        fields = list( version = "integer"),

        methods = list(

          initialize = function(..., version = 0L)

              callSuper(..., version = version+1L))

  )

tt <- TestClass2$new("test", version = 1L)

stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))

tt <- TestClass2$new(version=3L) # default text

stopifnot(identical(tt$text, ":"), identical(tt$version, as.integer(4)))

## test some capabilities but read-only for .self

.changeAllFields <- function(replacement) {

    fields <- names(.refClassDef@fieldClasses)

    for(field in fields)

        eval(substitute(.self$FIELD <- replacement$FIELD,

                        list(FIELD = field)))

}

mEditor$methods(change = .changeAllFields)

xx <- mEditor$new(data = xMat)

xx$edit(2, 2, 0)

yy <- mEditor$new(data = xMat+1)

yy$change(xx)

stopifnot(identical(yy$data, xx$data), identical(yy$edits, xx$edits))

## but don't allow assigment

if(methods:::.hasCodeTools())

        stopifnot(is(tryCatch(yy$.self$data <- xMat, error = function(e)e), "error"))

## the locked binding of refObjectGenerator class should prevent modifying

## methods, locking fields or setting accessor methods

evr <- getRefClass("refObjectGenerator") # in methods

stopifnot(is(tryCatch(evr$methods(foo = function()"..."), error = function(e)e), "error"),

         is(tryCatch(evr$lock("def"), error = function(e)e), "error"),

         is(tryCatch(evr$accessors("def"), error = function(e)e), "error"))

##getRefClass() method and function should work with either

## a class name or a class representation (bug report 14600)

tg <- setRefClass("tg", fields = "a")

t1 <- tg$new(a=1)

tgg <- t1$getRefClass()

tggg <- getRefClass("tg")

stopifnot(identical(tgg$def, tggg$def),

          identical(tg$def, tgg$def))

## TODO:  the className returned by setRefClass should have

## a package attribute, which would allow:

##          identical(tg$className, tgg$className))