1context("portable-inheritance")
2
3test_that("Inheritance", {
4  AC <- R6Class("AC",
5    portable = TRUE,
6    public = list(
7      x = 0,
8      z = 0,
9      initialize = function(x) self$x <- x,
10      getx = function() self$x,
11      getx2 = function() self$x*2,
12      getprivateA = function() private
13    ),
14    private = list(
15      getz = function() self$z,
16      getz2 = function() self$z*2
17    ),
18    active = list(
19      x2 = function(value) {
20        if (missing(value)) return(self$x * 2)
21        else self$x <- value/2
22      },
23      x3 = function(value) {
24        if (missing(value)) return(self$x * 3)
25        else self$x <- value/3
26      }
27    )
28  )
29  BC <- R6Class("BC",
30    portable = TRUE,
31    inherit = AC,
32    public = list(
33      y = 0,
34      z = 3,
35      initialize = function(x, y) {
36        super$initialize(x)
37        self$y <- y
38      },
39      getx = function() self$x + 10,
40      getprivateB = function() private
41    ),
42    private = list(
43      getz = function() self$z + 10
44    ),
45    active = list(
46      x2 = function(value) {
47        if (missing(value)) return(self$x + 2)
48        else self$x <- value-2
49      }
50    )
51  )
52  B <- BC$new(1, 2)
53
54  # Environment checks
55  eval_env <- environment(B$getx)
56  super_bind_env <- eval_env$super
57  super_eval_env <- environment(super_bind_env$getx)
58
59  expect_identical(parent.env(super_bind_env), emptyenv())
60  expect_identical(parent.env(super_eval_env), environment())
61  expect_identical(super_eval_env$self, B)
62  expect_identical(super_eval_env$private, B$getprivateA())
63  expect_identical(B$getprivateA(), B$getprivateB())
64
65  # Overridden public method
66  expect_identical(eval_env, environment(B$getx))
67  # Inherited public method
68  environment(B$getx2)
69  expect_identical(B, environment(B$getx2)$self)
70  # Overridden private method
71  expect_identical(eval_env, environment(B$getprivateA()$getz))
72  # Inherited private method - should have same eval env as inherited public
73  expect_identical(environment(B$getx2), environment(B$getprivateA()$getz2))
74
75  # Behavioral tests
76  # Overriding literals
77  expect_identical(B$x, 1)
78  expect_identical(B$y, 2)
79  expect_identical(B$z, 3) # Subclass value overrides superclass value
80  # Methods
81  expect_identical(B$getx(), 11)                # Overridden public method
82  expect_identical(B$getx2(), 2)                # Inherited public method
83  expect_identical(B$getprivateA()$getz(), 13)  # Overriden private method
84  expect_identical(B$getprivateA()$getz2(), 6)  # Inherited private method
85
86  # Active bindings
87  expect_identical(B$x2, 3) # Overridden
88  expect_identical(B$x3, 3) # Inherited
89
90  # Classes
91  expect_identical(class(B), c("BC", "AC", "R6"))
92})
93
94
95test_that("Inheritance: superclass methods", {
96  AC <- R6Class("AC",
97    portable = TRUE,
98    public = list(
99      x = 0,
100      initialize = function() {
101        self$inc_x()
102        private$inc_y()
103        self$incz
104      },
105      inc_x = function() self$x <- self$x + 1,
106      inc = function(val) val + 1,
107      pinc = function(val) private$priv_inc(val), # Call private inc method
108      gety = function() private$y,
109      z = 0
110    ),
111    private = list(
112      y = 0,
113      inc_y = function() private$y <- private$y + 1,
114      priv_inc = function(val) val + 1
115    ),
116    active = list(
117      incz = function(value) {
118        self$z <- z + 1
119      }
120    )
121  )
122  BC <- R6Class("BC",
123    portable = TRUE,
124    inherit = AC,
125    public = list(
126      inc_x = function() self$x <- self$x + 2,
127      inc = function(val) super$inc(val) + 20
128    ),
129    private = list(
130      inc_y = function() private$y <- private$y + 2,
131      priv_inc = function(val) super$priv_inc(val) + 20
132    ),
133    active = list(
134      incz = function(value) {
135        self$z <- self$z + 2
136      }
137    )
138  )
139  B <- BC$new()
140
141  # Testing overrides
142  expect_identical(B$x, 2)       # Public
143  expect_identical(B$gety(), 2)  # Private
144  expect_identical(B$z, 2)       # Active
145  # Calling superclass methods
146  expect_identical(B$inc(0), 21)
147  expect_identical(B$pinc(0), 21)
148
149
150  # Multi-level inheritance
151  CC <- R6Class("CC",
152    portable = TRUE,
153    inherit = BC,
154    public = list(
155      inc_x = function() self$x <- self$x + 3,
156      inc = function(val) super$inc(val) + 300
157    ),
158    private = list(
159      inc_y = function() private$y <- private$y + 3,
160      priv_inc = function(val) super$priv_inc(val) + 300
161    ),
162    active = list(
163      incz = function(value) {
164        self$z <- self$z + 3
165      }
166    )
167  )
168  C <- CC$new()
169
170  # Testing overrides
171  expect_identical(C$x, 3)       # Public
172  expect_identical(C$gety(), 3)  # Private
173  expect_identical(C$z, 3)       # Active
174  # Calling superclass methods (two levels)
175  expect_identical(C$inc(0), 321)
176  expect_identical(C$pinc(0), 321)
177
178  # Classes
179  expect_identical(class(C), c("CC", "BC", "AC", "R6"))
180})
181
182
183test_that("Inheritance: enclosing environments for super$ methods", {
184  encA <- new.env()
185  encB <- new.env()
186  encC <- new.env()
187
188  encA$n <- 1
189  encB$n <- 20
190  encC$n <- 300
191
192  AC <- R6Class("AC",
193    portable = TRUE,
194    parent_env = encA,
195    public = list(
196      x = 0,
197      initialize = function() {
198        self$x <- self$get_n()
199      },
200      get_n = function() n,
201      priv_get_n = function(val) private$get_n_priv()
202    ),
203    private = list(
204      get_n_priv = function() n
205    ),
206    active = list(
207      active_get_n = function() n
208    )
209  )
210  A <- AC$new()
211  expect_identical(A$x, 1)
212  expect_identical(A$get_n(), 1)
213  expect_identical(A$priv_get_n(), 1)
214  expect_identical(A$active_get_n, 1)
215
216  BC <- R6Class("BC",
217    portable = TRUE,
218    parent_env = encB,
219    inherit = AC,
220    public = list(
221      x = 0,
222      initialize = function() {
223        super$initialize()
224      },
225      get_n = function() n + super$get_n(),
226      priv_get_n = function(val) private$get_n_priv()
227    ),
228    private = list(
229      get_n_priv = function() n + super$get_n_priv()
230    ),
231    active = list(
232      active_get_n = function() n + super$active_get_n
233    )
234  )
235  B <- BC$new()
236  expect_identical(B$x, 21)
237  expect_identical(B$get_n(), 21)
238  expect_identical(B$priv_get_n(), 21)
239  expect_identical(B$active_get_n, 21)
240
241  CC <- R6Class("CC",
242    portable = TRUE,
243    parent_env = encC,
244    inherit = BC,
245    public = list(
246      x = 0,
247      initialize = function() {
248        super$initialize()
249      },
250      get_n = function() n + super$get_n(),
251      priv_get_n = function(val) private$get_n_priv()
252    ),
253    private = list(
254      get_n_priv = function() n + super$get_n_priv()
255    ),
256    active = list(
257      active_get_n = function() n + super$active_get_n
258    )
259  )
260  C <- CC$new()
261  expect_identical(C$x, 321)
262  expect_identical(C$get_n(), 321)
263  expect_identical(C$priv_get_n(), 321)
264  expect_identical(C$active_get_n, 321)
265})
266
267
268test_that("Inheritance: enclosing environments for inherited methods", {
269  encA <- new.env()
270  encB <- new.env()
271  encC <- new.env()
272
273  encA$n <- 1
274  encB$n <- 20
275  encC$n <- 300
276
277  AC <- R6Class("AC",
278    portable = TRUE,
279    parent_env = encA,
280    public = list(
281      get_n = function() n
282    )
283  )
284  A <- AC$new()
285  expect_identical(A$get_n(), 1)
286
287  BC <- R6Class("BC",
288    portable = TRUE,
289    parent_env = encB,
290    inherit = AC
291  )
292  B <- BC$new()
293  # Since this inherits A's get_n() method, it should also inherit the
294  # environment in which get_n() runs. This is necessary for inherited methods
295  # to find methods from the correct namespace.
296  expect_identical(B$get_n(), 1)
297
298  CC <- R6Class("CC",
299    portable = TRUE,
300    parent_env = encC,
301    inherit = BC,
302    public = list(
303      get_n = function() n + super$get_n()
304    )
305  )
306  C <- CC$new()
307  # When this calls super$get_n(), it should get B's version of get_n(), which
308  # should in turn run in A's environment, returning 1. Add C's value of n, and
309  # the total is 301.
310  expect_identical(C$get_n(), 301)
311})
312
313
314test_that("Inheritance hierarchy for super$ methods", {
315  AC <- R6Class("AC", portable = TRUE,
316    public = list(n = function() 0 + 1)
317  )
318  expect_identical(AC$new()$n(), 1)
319
320  BC <- R6Class("BC", portable = TRUE,
321    public = list(n = function() super$n() + 10),
322    inherit = AC
323  )
324  expect_identical(BC$new()$n(), 11)
325
326  CC <- R6Class("CC", portable = TRUE,
327    inherit = BC
328  )
329  # This should equal 11 because it inherits BC's n(), which adds 1 to AC's n()
330  expect_identical(CC$new()$n(), 11)
331
332  # Skipping one level of inheritance ---------------------------------
333  AC <- R6Class("AC", portable = TRUE,
334    public = list(n = function() 0 + 1)
335  )
336  expect_identical(AC$new()$n(), 1)
337
338  BC <- R6Class("BC", portable = TRUE,
339    inherit = AC
340  )
341  expect_identical(BC$new()$n(), 1)
342
343  CC <- R6Class("CC", portable = TRUE,
344    public = list(n = function() super$n() + 100),
345    inherit = BC
346  )
347  # This should equal 101 because BC inherits AC's n()
348  expect_identical(CC$new()$n(), 101)
349
350  DC <- R6Class("DC", portable = TRUE,
351    inherit = CC
352  )
353  # This should equal 101 because DC inherits CC's n(), and BC inherits AC's n()
354  expect_identical(DC$new()$n(), 101)
355
356  # Skipping two level of inheritance ---------------------------------
357  AC <- R6Class("AC", portable = TRUE,
358    public = list(n = function() 0 + 1)
359  )
360  expect_identical(AC$new()$n(), 1)
361
362  BC <- R6Class("BC", portable = TRUE, inherit = AC)
363  expect_identical(BC$new()$n(), 1)
364
365  CC <- R6Class("CC", portable = TRUE, inherit = BC)
366  expect_identical(CC$new()$n(), 1)
367})
368
369
370test_that("sub and superclass must both be portable or non-portable", {
371  AC <- R6Class("AC", portable = FALSE, public = list(x=1))
372  BC <- R6Class("BC", portable = TRUE, inherit = AC)
373  expect_error(BC$new())
374
375  AC <- R6Class("AC", portable = TRUE, public = list(x=1))
376  BC <- R6Class("BC", portable = FALSE, inherit = AC)
377  expect_error(BC$new())
378})
379
380
381test_that("Inheritance is dynamic", {
382  AC <- R6Class("AC",
383    public = list(x = 1, initialize = function() self$x <<- self$x + 10)
384  )
385  BC <- R6Class("BC", inherit = AC)
386  expect_identical(BC$new()$x, 11)
387
388  AC <- R6Class("AC",
389    public = list(x = 2, initialize = function() self$x <<- self$x + 20)
390  )
391  expect_identical(BC$new()$x, 22)
392
393  # BC doesn't contain AC, and it has less stuff in it, so it should be smaller
394  # than AC.
395  if (requireNamespace("pryr", quietly = TRUE)) {
396    expect_true(pryr::object_size(BC) < pryr::object_size(AC))
397  }
398})
399
400
401test_that("Private env is created when all private members are inherited", {
402  # Private contains fields only
403  AC <- R6Class("AC",
404    public = list(getx = function() private$x),
405    private = list(x = 1)
406  )
407  BC <- R6Class("BC", inherit = AC)
408  expect_identical(BC$new()$getx(), 1)
409
410
411  # Private contains functions only
412  AC <- R6Class("AC",
413    public = list(getx = function() private$x()),
414    private = list(x = function() 1)
415  )
416  BC <- R6Class("BC", inherit = AC)
417  expect_identical(BC$new()$getx(), 1)
418})
419