| ## 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")) |