The R Project SVN R

Rev

Rev 52871 | Rev 52960 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
52846 jmc 1 
options(error = recover)
52903 jmc 2 
fg <- setRefClass("foo", list(bar = "numeric", flag = "character"),
52816 jmc 3 
            fieldPrototypes = list(flag = "standard flag"),
52903 jmc 4 
            refMethods = list(
52816 jmc 5 
            addToBar = function(incr) {
6 
                b = getBar() + incr
7 
                setBar(b)
8 
                b
9 
            }
10 
            ))
11 
ff = new("foo", bar = 1.5)
12 
stopifnot(identical(ff$bar, 1.5))
13 
ff$bar <- pi
14 
stopifnot(identical(ff$bar, pi))
52903 jmc 15 
## test against generator
52816 jmc 16 
 
52903 jmc 17 
f2 <- fg$new(bar = pi)
18 
## identical does not return TRUE if *contents* of env are identical
19 
stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))
20 
 
21 
 
52816 jmc 22 
stopifnot(identical(ff$flag, "standard flag"))
23 
 
24 
ff$setBar(1:3)
25 
stopifnot(identical(ff$bar, 1:3))
26 
 
27 
ff$getBar()
28 
stopifnot(all.equal(ff$addToBar(1), 2:4))
29 
 
52903 jmc 30 
## Add a method
31 
fg$methods(barTimes = function(x) {
32 
    "This method multiples field bar by argument x
33 
and this string is self-documentation"
34 
    setBar(getBar() * x)})
35 
 
36 
ffbar <- ff$getBar()
37 
ff$barTimes(10)
38 
stopifnot(all.equal(ffbar * 10, ff$getBar()))
39 
ff$barTimes(.1)
40 
 
52846 jmc 41 
## inheritance.  redefines flag so should fail:
52903 jmc 42 
stopifnot(is(tryCatch(setRefClass("foo2", list(b2 = "numeric", flag = "complex"),
52816 jmc 43 
            contains = "foo",
52903 jmc 44 
            refMethods = list(addBoth = function(incr) {
52816 jmc 45 
                addToBar(incr) #uses inherited class method
46 
                setB2(getB2() + incr)
52903 jmc 47 
                })),
48 
          error = function(e)e), "error"))
52846 jmc 49 
## but with flag as a subclass of "character", should work
52871 jmc 50 
setClass("ratedChar", contains = "character", representation(score = "numeric"))
52903 jmc 51 
foo2 <- setRefClass("foo2", list(b2 = "numeric", flag = "ratedChar"),
52846 jmc 52 
            contains = "foo",
52903 jmc 53 
            refMethods = list(addBoth = function(incr) {
52846 jmc 54 
                addToBar(incr) #uses inherited class method
55 
                setB2(getB2() + incr)
52816 jmc 56 
                }))
52903 jmc 57 
f2 <- foo2$new(bar = -3, flag = as("ANY", "ratedChar"), b2 = ff$bar)
58 
f22 <- fg$new(bar = f2$bar, flag = f2$flag)
59 
f2e <- f2$export("foo")
60 
stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),
61 
          identical(class(f2e), class(f22)))
52871 jmc 62 
stopifnot(identical(f2$flag,  as("ANY", "ratedChar")), identical(f2$bar, -3),
52816 jmc 63 
          all.equal(f2$b2, 2:4+0))
64 
f2$addBoth(-1)
65 
stopifnot(all.equal(f2$bar, -4), all.equal(f2$b2, 1:3+0))
66 
 
67 
setRefClass("foo3", contains = "foo2",
52903 jmc 68 
            refMethods = list(addBoth = function(incr) {
52846 jmc 69 
                callSuper(incr)
52871 jmc 70 
                setFlag(as(paste(getFlag(), paste(incr, collapse = ", "), sep = "; "), "ratedChar"))
52816 jmc 71 
                incr
72 
            }))
73 
 
52846 jmc 74 
f3 <- new("foo3")
75 
f3$import(f2)
76 
stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar), all.equal(f3$flag, f2$flag))
52871 jmc 77 
f3$addBoth(1)
78 
stopifnot(all.equal(f3$bar, -3), all.equal(f3$b2, 2:4+0),
79 
          all.equal(f3$flag, as("ANY; 1", "ratedChar")))
80