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