The R Project SVN – R – Diff – /trunk/src/library/methods/tests/basicRefClass.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",

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

                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),

				   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),

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(

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

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

    usingMethods("counter")
    sapply(seq_along(edits), "counter")
})
 
 
ff <- mv( data = xMat)
stopifnot(identical(markViewer, "ON")) # check initialize
ff$edit(2,2,0)
ff$data
stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))
ff$undo()

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

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

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

     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) {

        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())

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

Rev 59654	Rev 61035
Line 1...	Line 1...
1	`## simple call, only field names`	1	`## simple call, only field names`
2	`fg <- setRefClass("foo", c("bar", "flag"))`	2	`fg <- setRefClass("foo", c("bar", "flag"))`
3	`f1 <- new("foo")`	3	`f0 <- new("foo") # deprecated, but should still work`
4	`f1$bar`	-
5	`f1 <- fg$new(flag = "testing")`	4	`f1 <- fg(flag = "testing")`
6	`f1$bar <- 1`	5	`f1$bar <- 1`
7	`stopifnot(identical(f1$bar, 1))`	6	`stopifnot(identical(f1$bar, 1))`
-		7	`## add method`
8	`fg$methods(showAll = function() c(bar, flag))`	8	`fg$methods(showAll = function() c(bar, flag))`
9	`stopifnot(all.equal(f1$showAll(), c(1, "testing")))`	9	`stopifnot(all.equal(f1$showAll(), c(1, "testing")))`
10	`str(f1)`	10	`str(f1)`
11		11
12	`fg <- setRefClass("foo", list(bar = "numeric", flag = "character",`	12	`fg <- setRefClass("foo", list(bar = "numeric", flag = "character",`
Line 30...	Line 30...
30	`## but no second assign`	30	`## but no second assign`
31	`stopifnot(is(tryCatch(ff$flag <- "new", error = function(e)e), "error"))`	31	`stopifnot(is(tryCatch(ff$flag <- "new", error = function(e)e), "error"))`
32		32
33	`## test against generator`	33	`## test against generator`
34		34
35	`f2 <- fg$new(bar = pi, flag = "flag test")`	35	`f2 <- fg(bar = pi, flag = "flag test")`
36	`## identical does not return TRUE if contents of env are identical`	36	`## identical does not return TRUE if contents of env are identical`
37	`stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))`	37	`stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))`
38	`## but flag was now assigned once`	38	`## but flag was now assigned once`
39	`stopifnot(is(tryCatch(f2$flag <- "new", error = function(e)e), "error"))`	39	`stopifnot(is(tryCatch(f2$flag <- "new", error = function(e)e), "error"))`
40		40
Line 82...	Line 82...
82	`addToBar(incr) #uses inherited class method`	82	`addToBar(incr) #uses inherited class method`
83	`b2 <<- b2 + incr`	83	`b2 <<- b2 + incr`
84	`}))`	84	`}))`
85	`## now lock the flag field; should still allow one write`	85	`## now lock the flag field; should still allow one write`
86	`foo2$lock("flag")`	86	`foo2$lock("flag")`
87	`f2 <- foo2$new(bar = -3, flag = as("ANY", "ratedChar"),`	87	`f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"),`
88	`b2 = ff$bar, tag = 1.5)`	88	`b2 = ff$bar, tag = 1.5)`
89	`## but not a second one`	89	`## but not a second one`
90	`stopifnot(is(tryCatch(f2$flag <- "Try again",`	90	`stopifnot(is(tryCatch(f2$flag <- "Try again",`
91	`error = function(e)e), "error"))`	91	`error = function(e)e), "error"))`
92	`str(f2)`	92	`str(f2)`
93	`f22 <- foo2$new(bar = f2$bar)`	93	`f22 <- foo2(bar = f2$bar)`
94	`## same story if assignment follows the initialization`	94	`## same story if assignment follows the initialization`
95	`f22$flag <- f2$flag`	95	`f22$flag <- f2$flag`
96	`stopifnot(is(tryCatch(f22$flag <- "Try again",`	96	`stopifnot(is(tryCatch(f22$flag <- "Try again",`
97	`error = function(e)e), "error"))`	97	`error = function(e)e), "error"))`
98	`## Exporting superclass object`	98	`## Exporting superclass object`
99	`f22 <- fg$new(bar = f2$bar, flag = f2$flag)`	99	`f22 <- fg(bar = f2$bar, flag = f2$flag)`
100	`f2e <- f2$export("foo")`	100	`f2e <- f2$export("foo")`
101	`stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),`	101	`stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),`
102	`identical(class(f2e), class(f22)))`	102	`identical(class(f2e), class(f22)))`
103	`stopifnot(identical(f2$flag, as("ANY", "ratedChar")),`	103	`stopifnot(identical(f2$flag, as("ANY", "ratedChar")),`
104	`identical(f2$bar, -3),`	104	`identical(f2$bar, -3),`
Line 115...	Line 115...
115	`sep = "; "),`	115	`sep = "; "),`
116	`"ratedChar")`	116	`"ratedChar")`
117	`incr`	117	`incr`
118	`}))`	118	`}))`
119		119
120	`f2 <- foo2$new(bar = -3, flag = as("ANY", "ratedChar"), b2 = 1:3)`	120	`f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"), b2 = 1:3)`
121	`f3 <- foo3$new()`	121	`f3 <- foo3()`
122	`f3$import(f2)`	122	`f3$import(f2)`
123	`stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar),`	123	`stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar),`
124	`all.equal(f3$flag, f2$flag))`	124	`all.equal(f3$flag, f2$flag))`
125	`f3$addBoth(1)`	125	`f3$addBoth(1)`
126	`stopifnot(all.equal(f3$bar, -2), all.equal(f3$b2, 2:4+0),`	126	`stopifnot(all.equal(f3$bar, -2), all.equal(f3$b2, 2:4+0),`
Line 130...	Line 130...
130	`stopifnot(is(tryCatch(f3$flag <- "Try again",`	130	`stopifnot(is(tryCatch(f3$flag <- "Try again",`
131	`error = function(e)e), "error"))`	131	`error = function(e)e), "error"))`
132	`str(f3)`	132	`str(f3)`
133		133
134	`## importing the same class (not very useful but documented to work)`	134	`## importing the same class (not very useful but documented to work)`
135	`f3 <- foo3$new()`	135	`f3 <- foo3()`
136	`f4 <- foo3$new(bar = -3, flag = as("More", "ratedChar"), b2 = 1:3, flag2 = f2$flag)`	136	`f4 <- foo3(bar = -3, flag = as("More", "ratedChar"), b2 = 1:3, flag2 = f2$flag)`
137	`f3$import(f4)`	137	`f3$import(f4)`
138	`stopifnot(identical(f3$bar, f4$bar),`	138	`stopifnot(identical(f3$bar, f4$bar),`
139	`identical(f3$flag, f4$flag),`	139	`identical(f3$flag, f4$flag),`
140	`identical(f3$b2, f4$b2),`	140	`identical(f3$b2, f4$b2),`
141	`identical(f3$flag2, f4$flag2))`	141	`identical(f3$flag2, f4$flag2))`
142		142
143	`## similar to $import() but using superclass object in the $new() call`	143	`## similar to $import() but using superclass object in the generator call`
144	`## The explicitly supplied flag= should override and be allowed`	144	`## The explicitly supplied flag= should override and be allowed`
145	`## by the default $initialize()`	145	`## by the default $initialize()`
146	`f3b <- foo3$new(f2, flag = as("Other", "ratedChar"),`	146	`f3b <- foo3(f2, flag = as("Other", "ratedChar"),`
147	`flag2 = as("More", "ratedChar"))`	147	`flag2 = as("More", "ratedChar"))`
148	`## check that inherited and direct field assignments worked`	148	`## check that inherited and direct field assignments worked`
149	`stopifnot(identical(f3b$tag, f2$tag),`	149	`stopifnot(identical(f3b$tag, f2$tag),`
150	`identical(f3b$flag, as("Other", "ratedChar")),`	150	`identical(f3b$flag, as("Other", "ratedChar")),`
151	`identical(f3b$flag2, as("More", "ratedChar")))`	151	`identical(f3b$flag2, as("More", "ratedChar")))`
-		152	`## the $new() method should match the generator function`
-		153	`f3b <- foo3$new(f2, flag = as("Other", "ratedChar"),`
-		154	`flag2 = as("More", "ratedChar"))`
-		155	`stopifnot(identical(f3b$tag, f2$tag),`
-		156	`identical(f3b$flag, as("Other", "ratedChar")),`
-		157	`identical(f3b$flag2, as("More", "ratedChar")))`
152		-
153	`## a class with an initialize method, and an extra slot (legal, not a good idea)`	158	`## a class with an initialize method, and an extra slot (legal, not a good idea)`
154	`setOldClass(c("simple.list", "list"))`	159	`setOldClass(c("simple.list", "list"))`
155	`fg4 <- setRefClass("foo4",`	160	`fg4 <- setRefClass("foo4",`
156	`contains = "foo2",`	161	`contains = "foo2",`
157	`methods = list(`	162	`methods = list(`
Line 169...	Line 174...
169	`## a trivial class with no fields, using fields = list(), failed up to rev 56035`	174	`## a trivial class with no fields, using fields = list(), failed up to rev 56035`
170	`foo5 <- setRefClass("foo5", fields = list(),`	175	`foo5 <- setRefClass("foo5", fields = list(),`
171	`methods = list(bar = function(test)`	176	`methods = list(bar = function(test)`
172	`paste("",test,"")))`	177	`paste("",test,"")))`
173		178
174	`f5 <- foo5$new()`	179	`f5 <- foo5()`
175	`stopifnot(identical( f5$bar("xxx"), paste("","xxx", "")))`	180	`stopifnot(identical( f5$bar("xxx"), paste("","xxx", "")))`
176		181
177		182
178	`## simple active binding test`	183	`## simple active binding test`
179	`abGen <- setRefClass("ab",`	184	`abGen <- setRefClass("ab",`
180	`fields = list(a = "ANY",`	185	`fields = list(a = "ANY",`
181	`b = function(x) if(missing(x)) a else {a <<- x; x}))`	186	`b = function(x) if(missing(x)) a else {a <<- x; x}))`
182		187
183	`ab1 <- abGen$new(a = 1)`	188	`ab1 <- abGen(a = 1)`
184		189
185	`stopifnot(identical(ab1$a, 1), identical(ab1$b, 1))`	190	`stopifnot(identical(ab1$a, 1), identical(ab1$b, 1))`
186		191
187	`ab1$b <- 2`	192	`ab1$b <- 2`
188		193
Line 218...	Line 223...
218	`length(edits) <<- length(edits) - 2`	223	`length(edits) <<- length(edits) - 2`
219	`invisible(prev)`	224	`invisible(prev)`
220	`}`	225	`}`
221	`))`	226	`))`
222	`xMat <- matrix(1:12,4,3)`	227	`xMat <- matrix(1:12,4,3)`
223	`xx <- mEditor$new(data = xMat)`	228	`xx <- mEditor(data = xMat)`
224	`xx$edit(2, 2, 0)`	229	`xx$edit(2, 2, 0)`
225	`xx$data`	230	`xx$data`
226	`xx$undo()`	231	`xx$undo()`
227	`mEditor$help("undo")`	232	`mEditor$help("undo")`
228	`stopifnot(all.equal(xx$data, xMat))`	233	`stopifnot(all.equal(xx$data, xMat))`
Line 291...	Line 296...
291	`usingMethods("counter")`	296	`usingMethods("counter")`
292	`sapply(seq_along(edits), "counter")`	297	`sapply(seq_along(edits), "counter")`
293	`})`	298	`})`
294		299
295		300
296	`ff <- mv$new( data = xMat)`	301	`ff <- mv( data = xMat)`
297	`stopifnot(identical(markViewer, "ON")) # check initialize`	302	`stopifnot(identical(markViewer, "ON")) # check initialize`
298	`ff$edit(2,2,0)`	303	`ff$edit(2,2,0)`
299	`ff$data`	304	`ff$data`
300	`stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))`	305	`stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))`
301	`ff$undo()`	306	`ff$undo()`
Line 306...	Line 311...
306		311
307	`## tests of copying`	312	`## tests of copying`
308	`viewerPlus <- setRefClass("viewerPlus",`	313	`viewerPlus <- setRefClass("viewerPlus",`
309	`fields = list( text = "character",`	314	`fields = list( text = "character",`
310	`viewer = "matrixViewer"))`	315	`viewer = "matrixViewer"))`
311	`ff <- mv$new( data = xMat)`	316	`ff <- mv( data = xMat)`
312	`v1 <- viewerPlus$new(text = letters, viewer = ff)`	317	`v1 <- viewerPlus(text = letters, viewer = ff)`
313	`v2 <- v1$copy()`	318	`v2 <- v1$copy()`
314	`v3 <- v1$copy(TRUE)`	319	`v3 <- v1$copy(TRUE)`
315	`v2$text <- "Hello, world"`	320	`v2$text <- "Hello, world"`
316	`v2$viewer$data <- t(xMat) # change a field in v2$viewer`	321	`v2$viewer$data <- t(xMat) # change a field in v2$viewer`
317	`v3$text <- LETTERS`	322	`v3$text <- LETTERS`
318	`v3$viewer <- mv$new( data = matrix(nrow=1,ncol=1))`	323	`v3$viewer <- mv( data = matrix(nrow=1,ncol=1))`
319	`## with a deep copy all is protected, with a shallow copy`	324	`## with a deep copy all is protected, with a shallow copy`
320	`## the environment of a copied field remains the same,`	325	`## the environment of a copied field remains the same,`
321	`## but replacing the whole field should be local`	326	`## but replacing the whole field should be local`
322	`stopifnot(identical(v1$text, letters),`	327	`stopifnot(identical(v1$text, letters),`
323	`identical(v1$viewer, ff),`	328	`identical(v1$viewer, ff),`
Line 343...	Line 348...
343	`## methods from $methods(...)`	348	`## methods from $methods(...)`
344	`refClassA <- setRefClass("refClassA", methods=list(foo=function() "A"))`	349	`refClassA <- setRefClass("refClassA", methods=list(foo=function() "A"))`
345	`refClassB <- setRefClass("refClassB", contains="refClassA")`	350	`refClassB <- setRefClass("refClassB", contains="refClassA")`
346	`mnames <- objects(getClass("refClassB")@refMethods)`	351	`mnames <- objects(getClass("refClassB")@refMethods)`
347	`refClassB$methods(foo=function() callSuper())`	352	`refClassB$methods(foo=function() callSuper())`
348	`stopifnot(identical(refClassB$new()$foo(), "A"))`	353	`stopifnot(identical(refClassB()$foo(), "A"))`
349	`mnames2 <- objects(getClass("refClassB")@refMethods)`	354	`mnames2 <- objects(getClass("refClassB")@refMethods)`
350	`stopifnot(identical(mnames2[is.na(match(mnames2,mnames))], "foo#refClassA"))`	355	`stopifnot(identical(mnames2[is.na(match(mnames2,mnames))], "foo#refClassA"))`
351	`refClassB$methods(foo=function() paste(callSuper(), "Version 2"))`	356	`refClassB$methods(foo=function() paste(callSuper(), "Version 2"))`
352	`stopifnot(identical(refClassB$new()$foo(), "A Version 2"))`	357	`stopifnot(identical(refClassB()$foo(), "A Version 2"))`
353	`stopifnot(identical(mnames2, objects(getClass("refClassB")@refMethods)))`	358	`stopifnot(identical(mnames2, objects(getClass("refClassB")@refMethods)))`
354		359
355	`if(methods:::.hasCodeTools()) {`	360	`if(methods:::.hasCodeTools()) {`
356	`## code warnings assigning locally to field names`	361	`## code warnings assigning locally to field names`
357	`stopifnot(is(tryCatch(mv$methods(test = function(x)`	362	`stopifnot(is(tryCatch(mv$methods(test = function(x)`
Line 376...	Line 381...
376	`close(ccon)`	381	`close(ccon)`
377	`rm(ctxt)`	382	`rm(ctxt)`
378		383
379		384
380	`## tests related to subclassing environments. These really test code in the core, viz. builtin.c`	385	`## tests related to subclassing environments. These really test code in the core, viz. builtin.c`
381	`a <- refClassA$new()`	386	`a <- refClassA()`
382	`ev <- new.env(parent = a) # parent= arg`	387	`ev <- new.env(parent = a) # parent= arg`
383	`stopifnot(is.environment(ev))`	388	`stopifnot(is.environment(ev))`
384	`foo <- function()"A"; environment(foo) <- a # environment of function`	389	`foo <- function()"A"; environment(foo) <- a # environment of function`
385	`stopifnot(identical(as.environment(a), environment(foo)))`	390	`stopifnot(identical(as.environment(a), environment(foo)))`
386	`xx <- 1:10; environment(xx) <- a # environment attribute`	391	`xx <- 1:10; environment(xx) <- a # environment attribute`
Line 435...	Line 440...
435	`fields = list (text = "character"),`	440	`fields = list (text = "character"),`
436	`methods = list(`	441	`methods = list(`
437	`print = function () {cat(text)},`	442	`print = function () {cat(text)},`
438	`initialize = function(text = "", ...) callSuper(text = paste(text, ":", sep=""),...)`	443	`initialize = function(text = "", ...) callSuper(text = paste(text, ":", sep=""),...)`
439	`))`	444	`))`
440	`tt <- TestClass$new("hello world")`	445	`tt <- TestClass("hello world")`
441	`stopifnot(identical(tt$text, "hello world:"))`	446	`stopifnot(identical(tt$text, "hello world:"))`
442	`## now a subclass with another field & another layer of callSuper()`	447	`## now a subclass with another field & another layer of callSuper()`
443	`TestClass2 <- setRefClass("TestClass2",`	448	`TestClass2 <- setRefClass("TestClass2",`
444	`contains = "TestClass",`	449	`contains = "TestClass",`
445	`fields = list( version = "integer"),`	450	`fields = list( version = "integer"),`
446	`methods = list(`	451	`methods = list(`
447	`initialize = function(..., version = 0L)`	452	`initialize = function(..., version = 0L)`
448	`callSuper(..., version = version+1L))`	453	`callSuper(..., version = version+1L))`
449	`)`	454	`)`
450	`tt <- TestClass2$new("test", version = 1L)`	455	`tt <- TestClass2("test", version = 1L)`
451	`stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))`	456	`stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))`
452	`tt <- TestClass2$new(version=3L) # default text`	457	`tt <- TestClass2(version=3L) # default text`
453	`stopifnot(identical(tt$text, ":"), identical(tt$version, as.integer(4)))`	458	`stopifnot(identical(tt$text, ":"), identical(tt$version, as.integer(4)))`
454		459
455		460
456	`## test some capabilities but read-only for .self`	461	`## test some capabilities but read-only for .self`
457	`.changeAllFields <- function(replacement) {`	462	`.changeAllFields <- function(replacement) {`
Line 460...	Line 465...
460	`eval(substitute(.self$FIELD <- replacement$FIELD,`	465	`eval(substitute(.self$FIELD <- replacement$FIELD,`
461	`list(FIELD = field)))`	466	`list(FIELD = field)))`
462	`}`	467	`}`
463		468
464	`mEditor$methods(change = .changeAllFields)`	469	`mEditor$methods(change = .changeAllFields)`
465	`xx <- mEditor$new(data = xMat)`	470	`xx <- mEditor(data = xMat)`
466	`xx$edit(2, 2, 0)`	471	`xx$edit(2, 2, 0)`
467		472
468	`yy <- mEditor$new(data = xMat+1)`	473	`yy <- mEditor(data = xMat+1)`
469	`yy$change(xx)`	474	`yy$change(xx)`
470	`stopifnot(identical(yy$data, xx$data), identical(yy$edits, xx$edits))`	475	`stopifnot(identical(yy$data, xx$data), identical(yy$edits, xx$edits))`
471		476
472	`## but don't allow assigment`	477	`## but don't allow assigment`
473	`if(methods:::.hasCodeTools())`	478	`if(methods:::.hasCodeTools())`
Line 481...	Line 486...
481	`is(tryCatch(evr$accessors("def"), error = function(e)e), "error"))`	486	`is(tryCatch(evr$accessors("def"), error = function(e)e), "error"))`
482		487
483	`##getRefClass() method and function should work with either`	488	`##getRefClass() method and function should work with either`
484	`## a class name or a class representation (bug report 14600)`	489	`## a class name or a class representation (bug report 14600)`
485	`tg <- setRefClass("tg", fields = "a")`	490	`tg <- setRefClass("tg", fields = "a")`
486	`t1 <- tg$new(a=1)`	491	`t1 <- tg(a=1)`
487	`tgg <- t1$getRefClass()`	492	`tgg <- t1$getRefClass()`
488	`tggg <- getRefClass("tg")`	493	`tggg <- getRefClass("tg")`
489	`stopifnot(identical(tgg$def, tggg$def),`	494	`stopifnot(identical(tgg$def, tggg$def),`
490	`identical(tg$def, tgg$def))`	495	`identical(tg$def, tgg$def))`
491	`## TODO: the className returned by setRefClass should have`	-
492	`## a package attribute, which would allow:`	-
493	`## identical(tg$className, tgg$className))`	-
494		496
495	`## this used to fail in initFieldArgs() from partial matching "self"`	497	`## this used to fail in initFieldArgs() from partial matching "self"`
496	`selfClass <- setRefClass("selfClass",`	498	`selfClass <- setRefClass("selfClass",`
497	`fields=list(`	499	`fields=list(`
498	`self="character", super="character", sub="character"`	500	`self="character", super="character", sub="character"`
499	`)`	501	`)`
500	`)`	502	`)`
501		503
502	`stopifnot(identical(selfClass$new(self="B", super="A", sub="C")$self, "B"))`	504	`stopifnot(identical(selfClass(self="B", super="A", sub="C")$self, "B"))`

The R Project SVN R

(root)/trunk/src/library/methods/tests/basicRefClass.R @ 63243 – Rev 59654 → 61035