Merge pull request #18 from wch/dynamic-inherit

Dynamic inheritance. Fixes #12 and fixes #13

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: R6
 Title: Classes with reference semantics
-Version: 1.0.1.9001
+Version: 1.0.1.9002
 Authors@R: "Winston Chang <winston@stdout.org> [aut, cre]"
 Description: The R6 package allows the creation of classes with reference
     semantics, similar to R's built-in reference classes. Compared to reference

NEWS.md

@@ -1,8 +1,12 @@
-# R6 1.0.1.99
+# R6 1.0.1.9002
 
 * [BREAKING CHANGE] Added `portable` option, which allows inheritance across
   different package namespaces, and made it the default.
 
+* Inheritance of superclasses is dynamic; instead of reading in the superclass
+  when a class is created, this happens each time an object is instantiated.
+  (Fixes #12)
+
 * Added trailing newline when printing R6 objects. (Thanks to Gabor Csardi)
 
 * The `print` method of R6 objects can be redefined. (Thanks to Gabor Csardi)

R/env_utils.R

@@ -12,7 +12,7 @@ assign_func_envs <- function(objs, target_env) {
 # Get names of all superclasses
 get_superclassnames <- function(inherit) {
   if (is.null(inherit)) return(NULL)
-  c(inherit$classname, get_superclassnames(inherit$inherit))
+  c(inherit$classname, get_superclassnames(inherit$get_inherit()))
 }
 
 # Wrapper around list2env with a NULL check

R/r6_class.R

@@ -293,27 +293,22 @@ R6Class <- function(classname = NULL, public = list(),
   public_methods <- get_functions(public)
   private_methods <- get_functions(private)
 
-  # Merge in fields from superclasses
-  public_fields <- merge_vectors(inherit$public_fields, public_fields)
-  private_fields <- merge_vectors(inherit$private_fields, private_fields)
-
-  if (!is.null(inherit)) {
-    if (!inherits(inherit, "R6ClassGenerator"))
-      stop("`inherit` must be a R6ClassGenerator.")
-
-    if (!identical(portable, inherit$portable))
-      stop("Sub and superclass must both be portable or non-portable.")
+  # Capture the unevaluated expression for the superclass; when evaluated in
+  # the parent_env, it should return the superclass object.
+  inherit <- substitute(inherit)
+
+  # This function returns the superclass object
+  get_inherit <- function() {
+    # The baseenv() arg speeds up eval a tiny bit
+    eval(inherit, parent_env, baseenv())
   }
 
-  if (class) {
-    classes <- c(classname, get_superclassnames(inherit), "R6")
-  } else {
-    classes <- NULL
-  }
+  if (!is.null(inherit) && !inherits(get_inherit(), "R6ClassGenerator"))
+    stop("`inherit` must be a R6ClassGenerator.")
 
-  newfun <- R6_newfun(classes, public_fields, public_methods,
+  newfun <- R6_newfun(classname, public_fields, public_methods,
                       private_fields, private_methods, active,
-                      inherit, lock, portable, parent_env)
+                      get_inherit, lock, portable, parent_env, class)
 
   structure(
     list(
@@ -325,6 +320,7 @@ R6Class <- function(classname = NULL, public = list(),
       private_methods = private_methods,
       active = active,
       inherit = inherit,
+      get_inherit = get_inherit,
       portable = portable,
       parent_env = parent_env,
       lock = lock
@@ -335,30 +331,56 @@ R6Class <- function(classname = NULL, public = list(),
 
 
 # Create the $new function for a R6ClassGenerator
-R6_newfun <- function(classes, public_fields, public_methods,
+R6_newfun <- function(classname, public_fields, public_methods,
                       private_fields, private_methods, active,
-                      inherit, lock, portable, parent_env) {
+                      get_inherit, lock, portable, parent_env, class) {
+
+  function(...) {
+    # Get superclass object -------------------------------------------
+    inherit <- get_inherit()
 
-  # Precompute some things that we'll use repeatedly
-  has_private <- !(is.null(private_fields) && is.null(private_methods))
+    # Some checks on superclass ---------------------------------------
+    if (!is.null(inherit)) {
+      if (!inherits(inherit, "R6ClassGenerator"))
+        stop("`inherit` must be a R6ClassGenerator.")
+
+      if (!identical(portable, inherit$portable))
+        stop("Sub and superclass must both be portable or non-portable.")
+
+      # Merge fields over superclass fields, recursively --------------
+      recursive_merge <- function(obj, which) {
+        if (is.null(obj)) return(NULL)
+        merge_vectors(recursive_merge(obj$get_inherit(), which), obj[[which]])
+      }
+      public_fields  <- merge_vectors(recursive_merge(inherit, "public_fields"),
+                                      public_fields)
+      private_fields <- merge_vectors(recursive_merge(inherit, "private_fields"),
+                                      private_fields)
+    }
+
+    if (class) {
+      classes <- c(classname, get_superclassnames(inherit), "R6")
+    } else {
+      classes <- NULL
+    }
+
+    # Precompute some things ------------------------------------------
+    has_private <- !(is.null(private_fields) && is.null(private_methods))
 
-  hash_private <- length(private_fields) + length(private_methods) > 100
-  hash_public <- length(public_fields) + length(public_methods) > 100
 
-  function(...) {
     # Create binding and enclosing environments -----------------------
     if (portable) {
       # When portable==TRUE, the public binding environment is separate from the
       # enclosing environment.
 
       # Binding environment for private objects (where private objects are found)
       if (has_private)
-        private_bind_env <- new.env(parent = emptyenv(), hash = hash_private)
+        private_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
       else
         private_bind_env <- NULL
 
       # Binding environment for public objects (where public objects are found)
-      public_bind_env <- new.env(parent = emptyenv(), hash = hash_public)
+      public_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
 
       # The enclosing environment for methods
       enclos_env <- new.env(parent = parent_env, hash = FALSE)
@@ -369,11 +391,11 @@ R6_newfun <- function(classes, public_fields, public_methods,
       # If present, the private binding env is the parent of the public binding
       # env.
       if (has_private) {
-        private_bind_env <- new.env(parent = parent_env, hash = hash_private)
-        public_bind_env <- new.env(parent = private_bind_env, hash = hash_public)
+        private_bind_env <- new.env(parent = parent_env, hash = FALSE)
+        public_bind_env <- new.env(parent = private_bind_env, hash = FALSE)
       } else {
         private_bind_env <- NULL
-        public_bind_env <- new.env(parent = parent_env, hash = hash_public)
+        public_bind_env <- new.env(parent = parent_env, hash = FALSE)
       }
 
       enclos_env <- public_bind_env
@@ -457,8 +479,6 @@ create_super_env <- function(inherit, public_bind_env, private_bind_env = NULL,
   private_methods <- inherit$private_methods
   active          <- inherit$active
 
-  use_hash <- length(public_methods) + length(private_methods) + length(active) > 100
-
   # Set up super enclosing and binding environments -------------------
 
   # The environment in which functions run is a child of the public bind env
@@ -477,7 +497,7 @@ create_super_env <- function(inherit, public_bind_env, private_bind_env = NULL,
 
   # The binding environment is a new environment. Its parent doesn't matter
   # because it's not the enclosing environment for any functions.
-  super_bind_env <- new.env(parent = emptyenv(), hash = use_hash)
+  super_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
 
   # Add self/private pointers -----------------------------------------
   if (portable) {
@@ -494,8 +514,9 @@ create_super_env <- function(inherit, public_bind_env, private_bind_env = NULL,
   active          <- assign_func_envs(active, super_enclos_env)
 
   # Recurse if there are more superclasses ----------------------------
-  if (!is.null(inherit$inherit)) {
-    super_struct <- create_super_env(inherit$inherit, public_bind_env,
+  inherit_inherit <- inherit$get_inherit()
+  if (!is.null(inherit_inherit)) {
+    super_struct <- create_super_env(inherit_inherit, public_bind_env,
                                      private_bind_env, portable)
     super_enclos_env$super <- super_struct$bind_env
 

tests/testthat/test-r6-portable.R

@@ -520,10 +520,41 @@ test_that("Inheritance hierarchy for super$ methods", {
   expect_identical(CC$new()$n(), 1)
 })
 
+
 test_that("sub and superclass must both be portable or non-portable", {
   AC <- R6Class("AC", portable = FALSE, public = list(x=1))
-  expect_error(R6Class("BC", portable = TRUE, inherit = AC))
+  BC <- R6Class("BC", portable = TRUE, inherit = AC)
+  expect_error(BC$new())
 
   AC <- R6Class("AC", portable = TRUE, public = list(x=1))
-  expect_error(R6Class("BC", portable = FALSE, inherit = AC))
+  BC <- R6Class("BC", portable = FALSE, inherit = AC)
+  expect_error(BC$new())
+})
+
+
+test_that("Inheritance is dynamic", {
+  AC <- R6Class("AC",
+    public = list(x = 1, initialize = function() self$x <<- self$x + 10)
+  )
+  BC <- R6Class("BC", inherit = AC)
+  expect_identical(BC$new()$x, 11)
+
+  AC <- R6Class("AC",
+    public = list(x = 2, initialize = function() self$x <<- self$x + 20)
+  )
+  expect_identical(BC$new()$x, 22)
+
+  # BC doesn't contain AC, and it has less stuff in it, so it should be smaller
+  # than AC.
+  expect_true(object.size(BC) < object.size(AC))
+})
+
+
+test_that("Private env is created when all private members are inherited", {
+  AC <- R6Class("AC",
+    public = list(getx = function() private$x),
+    private = list(x = 1)
+  )
+  BC <- R6Class("BC", inherit = AC)
+  expect_identical(BC$new()$getx(), 1)
 })

tests/testthat/test-r6.R

@@ -419,3 +419,19 @@ test_that("default print method has a trailing newline", {
   A <- AC$new()
   expect_output_n(print(A))
 })
+
+
+test_that("Private env is created when all private members are inherited", {
+  AC <- R6Class("AC",
+    portable = FALSE,
+    public = list(
+      getx = function() x,
+      getx2 = function() private$x
+    ),
+    private = list(x = 1)
+  )
+  BC <- R6Class("BC", portable = FALSE, inherit = AC)
+
+  expect_identical(BC$new()$getx(), 1)
+  expect_identical(BC$new()$getx2(), 1)
+})