Deep copy

R/core.r

@@ -43,8 +43,14 @@ Core <- local({
     aclone$core <- new.env(TRUE, emptyenv())
     structure(list(aclone), class = "core")
   }
-
-  # Can not reliably assign attributes to an environment, so need to 
+
+  copy <- function() {
+    aclone <- new.env(FALSE, self[[1]])
+    aclone$core <- list2env(as.list(core), parent = emptyenv(), hash = TRUE)
+    structure(list(aclone), class = "core")
+  }
+
+  # Can not reliably assign attributes to an environment, so need to
   # store it within a list, and assign based on that.
   self <- structure(list(environment()), class = "core")
 })

R/object-inheritance.r

@@ -121,8 +121,53 @@ Object$do({
       call. = FALSE)     
   }
 
+  #' @param do_not_copy list of objects which must not be copying
+  self$deep_copy <- function(do_not_copy = list()) {
+    # Add `Object' to do-not-copy list
+    do_not_copy <- c(do_not_copy, list(Object))
+    do_not_copy_names <- sapply(do_not_copy, function(obj) envname(core(obj)[[1]]))
+
+    # Make copy and disengage it
+    disengage_copy(make_copy(self), do_not_copy_names = do_not_copy_names)
+  }
 })
 
+make_copy <- function(x) {
+   aclone <- list(core(x)$copy())
+   aclone <- structure(aclone, class = "mutatr")
+}
+
+disengage_copy <- function(x, env = new.env(hash = TRUE, parent = emptyenv()), do_not_copy_names) {
+
+  # Save old protos (must be low-lewel)
+  old.protos <- core(x)$get_local_slot("protos")
+
+  # Clear protos list, low-level (to avoid endless recursion)
+  core(x)$set_slot("protos", list())
+
+  new.protos <- lapply(old.protos, function(proto) {
+    name <- envname(core(proto)[[1]]);
+
+    # Check necessity of cloning
+    if (name %in% do_not_copy_names)
+      return (proto)
+
+    if (!exists(name, envir = env)) {
+      # At once copy object
+      env[[name]] <- make_copy(proto)
+      # Then disangage it
+      disengage_copy(env[[name]], env = env, do_not_copy_names = do_not_copy_names)
+    }
+
+    env[[name]]
+  })
+
+  # Low-level set new proto
+  core(x)$set_slot("protos", new.protos)
+
+  x
+}
+
 "$.mutatr" <- function(x, i, ...) {
   get_slot(x, i)
 }

tests/test-deep_clone.r

@@ -0,0 +1,44 @@
+library(testthat)
+library(mutatr)
+
+context("Deep copying")
+
+test_that("Diamond inheritance processed correctly", {
+  # Make diamond inheritance structure
+
+  #   A
+  #  / \
+  # B   C
+  #  \ /
+  #   D
+
+  A <- Object$clone()$do({
+    self$name <- "A"
+  })
+
+  B <- A$clone()$do({
+    self$name <- "B"
+  })
+
+  C <- A$clone()$do({
+    self$name <- "C"
+  })
+
+  D <- B$clone()$do({
+    self$name <- "D"
+  })
+
+  D$append_proto(C)
+
+  D.copy <- D$deep_copy()
+
+
+  D.copy$protos[[1]]$name
+  D.copy$protos[[2]]$name
+
+  A1 <- D.copy$protos[[1]]$protos[[1]]
+  A2 <- D.copy$protos[[2]]$protos[[1]]
+
+  expect_identical(A1, A2)
+  expect_false(identical(A1, A))
+})