531 lines
18 KiB
R
531 lines
18 KiB
R
|
## simple call, only field names
|
||
|
|
fg <- setRefClass("foo", c("bar", "flag"))
|
||
|
|
f0 <- new("foo") # deprecated, but should still work
|
||
|
|
f1 <- fg(flag = "testing")
|
||
|
|
f1$bar <- 1
|
||
|
|
stopifnot(identical(f1$bar, 1))
|
||
|
|
## add method
|
||
|
|
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
|
||
|
|
} )
|
||
|
|
)
|
||
|
|
fg$lock("flag")
|
||
|
|
stopifnot(identical(fg$lock(), "flag"))
|
||
|
|
|
||
|
|
ff <- new("foo", bar = 1.5)
|
||
|
|
stopifnot(identical(ff$bar, 1.5))
|
||
|
|
ff$bar <- pi
|
||
|
|
stopifnot(identical(ff$bar, pi))
|
||
|
|
## flag has not yet been set
|
||
|
|
ff$flag <- "flag test"
|
||
|
|
stopifnot(identical(ff$flag, "flag test"))
|
||
|
|
## but no second assign
|
||
|
|
stopifnot(is(tryCatch(ff$flag <- "new", error = function(e)e), "error"))
|
||
|
|
|
||
|
|
## test against generator
|
||
|
|
|
||
|
|
f2 <- fg(bar = pi, flag = "flag test")
|
||
|
|
## identical does not return TRUE if *contents* of env are identical
|
||
|
|
stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))
|
||
|
|
## but flag was now assigned once
|
||
|
|
stopifnot(is(tryCatch(f2$flag <- "new", error = function(e)e), "error"))
|
||
|
|
|
||
|
|
str(f2)
|
||
|
|
|
||
|
|
|
||
|
|
## 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 "characters", 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(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(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(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()
|
||
|
|
foo3 <- 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(bar = -3, flag = as("ANY", "ratedChar"), b2 = 1:3)
|
||
|
|
f3 <- 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)
|
||
|
|
|
||
|
|
## importing the same class (not very useful but documented to work)
|
||
|
|
f3 <- foo3()
|
||
|
|
f4 <- foo3(bar = -3, flag = as("More", "ratedChar"), b2 = 1:3, flag2 = f2$flag)
|
||
|
|
f3$import(f4)
|
||
|
|
stopifnot(identical(f3$bar, f4$bar),
|
||
|
|
identical(f3$flag, f4$flag),
|
||
|
|
identical(f3$b2, f4$b2),
|
||
|
|
identical(f3$flag2, f4$flag2))
|
||
|
|
|
||
|
|
## similar to $import() but using superclass object in the generator call
|
||
|
|
## The explicitly supplied flag= should override and be allowed
|
||
|
|
## by the default $initialize()
|
||
|
|
f3b <- foo3(f2, flag = as("Other", "ratedChar"),
|
||
|
|
flag2 = as("More", "ratedChar"))
|
||
|
|
## check that inherited and direct field assignments worked
|
||
|
|
stopifnot(identical(f3b$tag, f2$tag),
|
||
|
|
identical(f3b$flag, as("Other", "ratedChar")),
|
||
|
|
identical(f3b$flag2, as("More", "ratedChar")))
|
||
|
|
## the $new() method should match the generator function
|
||
|
|
f3b <- foo3$new(f2, flag = as("Other", "ratedChar"),
|
||
|
|
flag2 = as("More", "ratedChar"))
|
||
|
|
stopifnot(identical(f3b$tag, f2$tag),
|
||
|
|
identical(f3b$flag, as("Other", "ratedChar")),
|
||
|
|
identical(f3b$flag2, as("More", "ratedChar")))
|
||
|
|
## a class with an initialize method, and an extra slot (legal, not a good idea)
|
||
|
|
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 = as("another test", "ratedChar"), 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()
|
||
|
|
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(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(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)
|
||
|
|
},
|
||
|
|
counter = function(i) {
|
||
|
|
'The number of items in the i-th edit.
|
||
|
|
(Used to test usingMethods())
|
||
|
|
'
|
||
|
|
if(i > 0 && i <= length(edits))
|
||
|
|
length(edits[[i]][[3]])
|
||
|
|
else
|
||
|
|
0L
|
||
|
|
}
|
||
|
|
)
|
||
|
|
|
||
|
|
tf <- tempfile()
|
||
|
|
xx$save(tf) #$
|
||
|
|
load(tf)
|
||
|
|
unlink(tf)
|
||
|
|
stopifnot(identical(xx$data, .self$data))
|
||
|
|
|
||
|
|
## tests of $trace() methods
|
||
|
|
## debugging an object
|
||
|
|
xx$trace(edit, quote(xxTrace <<- TRUE))
|
||
|
|
|
||
|
|
## debugging all objects from class mEditor in method $undo()
|
||
|
|
mEditor$trace(undo, quote(mETrace <<- TRUE))
|
||
|
|
|
||
|
|
xxTrace <- mETrace <- FALSE
|
||
|
|
xx$edit(2,3,100)
|
||
|
|
xx$undo()
|
||
|
|
|
||
|
|
## will not have changed the xx$undo() method (already used)
|
||
|
|
stopifnot(identical(xxTrace, TRUE), identical(mETrace, FALSE))
|
||
|
|
|
||
|
|
## but a new object works the other way around
|
||
|
|
xxTrace <- mETrace <- FALSE
|
||
|
|
xx <- mEditor(data = xMat)
|
||
|
|
xx$edit(2,3,100)
|
||
|
|
xx$undo()
|
||
|
|
stopifnot(identical(xxTrace, FALSE), identical(mETrace, TRUE))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
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")
|
||
|
|
})
|
||
|
|
|
||
|
|
## a counts method to test usingMethods()
|
||
|
|
mv$methods( counts = function() {
|
||
|
|
usingMethods("counter")
|
||
|
|
sapply(seq_along(edits), "counter")
|
||
|
|
})
|
||
|
|
|
||
|
|
|
||
|
|
ff <- mv( data = xMat)
|
||
|
|
stopifnot(identical(markViewer, "ON")) # check initialize
|
||
|
|
ff$edit(2,2,0)
|
||
|
|
ff$data
|
||
|
|
if(methods:::.hasCodeTools()) # otherwise 'counter' is not visible
|
||
|
|
stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))
|
||
|
|
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( data = xMat)
|
||
|
|
v1 <- viewerPlus(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( 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()$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()$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()
|
||
|
|
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("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("test", version = 1L)
|
||
|
|
stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))
|
||
|
|
tt <- TestClass2(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(data = xMat)
|
||
|
|
xx$edit(2, 2, 0)
|
||
|
|
|
||
|
|
yy <- mEditor(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 refGeneratorSlot class should prevent modifying
|
||
|
|
## methods, locking fields or setting accessor methods
|
||
|
|
## Nothing special about refGeneratorSlot in this test -- the point is just
|
||
|
|
## to use a standard reference class known to be defined in a package
|
||
|
|
evr <- getRefClass("refGeneratorSlot") # 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(a=1)
|
||
|
|
tgg <- t1$getRefClass()
|
||
|
|
tggg <- getRefClass("tg")
|
||
|
|
stopifnot(identical(tgg$def, tggg$def),
|
||
|
|
identical(tg$def, tgg$def))
|
||
|
|
|
||
|
|
## this used to fail in initFieldArgs() from partial matching "self"
|
||
|
|
selfClass <- setRefClass("selfClass",
|
||
|
|
fields=list(
|
||
|
|
self="character", super="character", sub="character"
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
stopifnot(identical(selfClass(self="B", super="A", sub="C")$self, "B"))
|