Create activeBinding to mod object within modules

Cache -- for simList -- include the module environment make active binding to mod
PredictiveEcology · Nov 28, 2018 · 4bee16c · 4bee16c · lintr-bot · Nov 28, 2018
1 parent 936f710
commit 4bee16c
Show file tree

Hide file tree

Showing 7 changed files with 185 additions and 25 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -9,8 +9,8 @@ Description: Provide the core discrete event simulation (DES) framework for
 URL:
     http://spades-core.predictiveecology.org/,
     https://github.com/PredictiveEcology/SpaDES.core
-Date: 2018-11-26
-Version: 0.2.3.9004
+Date: 2018-11-27
+Version: 0.2.3.9005
 Authors@R: c(
     person("Alex M", "Chubaty", email = "alex.chubaty@gmail.com",
     role = c("aut", "cre"), comment = c(ORCID = "0000-0001-7146-8135")),

diff --git a/NEWS.md b/NEWS.md
@@ -8,6 +8,7 @@ version 0.2.3.9000
 * lorem ipsum
 
 ## new features
+* New active binding, `mod` that works as a module-specific variable, similar to a private object, i.e., `mod$a` is a local object inside the module that persists across events. It is a pointer to `sim[[currentModule(sim)]]$a`
 * New function `scheduleConditionalEvent`, which allows an event to be scheduled based on a condition. Still experimental.
 * An experimental new function and feature, `objectSynonyms`, which will create active bindings of two names to a single object
 * User can now specify `modulePath` as a character vector, e.g., `simInit(..., paths = list(modulePath = c(".", "test")))`. This means that a user can organize the modules in different locations.

diff --git a/R/cache.R b/R/cache.R
@@ -37,14 +37,16 @@ setMethod(
                         quick, classOptions) {
 
     outerObjs <- ls(object@.xData, all.names = TRUE)
-    moduleEnvirs <- mget(outerObjs[outerObjs %in% unlist(modules(object))], envir = object@.xData)
+    moduleEnvirs <- mget(outerObjs[outerObjs %in% unlist(modules(object))],
+                         envir = object@.xData)
     moduleObjs <- lapply(moduleEnvirs, function(me) ls(me, all.names = TRUE))
     allObjsInSimList <- append(list(".xData" = outerObjs), moduleObjs)
     allEnvsInSimList <- append(list(object@.xData), moduleEnvirs)
 
     ord <- .orderDotsUnderscoreFirst(allObjsInSimList)
     allObjsInSimList <- allObjsInSimList[ord]
     allEnvsInSimList <- allEnvsInSimList[ord]
+    names(allEnvsInSimList) <- names(allObjsInSimList)
 
     isObjectEmpty <- if (!missing(objects)) {
       if (!is.null(objects)) {
@@ -70,15 +72,16 @@ setMethod(
     } else {
       objects <- allObjsInSimList
     }
-    envirHash <- lapply(seq(allObjsInSimList), function(objs) {
-      objectsToDigest <- sort(allObjsInSimList[[objs]], method = "radix")
+    envirHash <- Map(objs = allObjsInSimList, name = names(allObjsInSimList),
+                     function(objs, name) {
+      objectsToDigest <- sort(objs, method = "radix")
       objectsToDigest <- objectsToDigest[objectsToDigest %in%
-                                           objects[[names(allObjsInSimList)[objs]]]]
-      .robustDigest(mget(objectsToDigest, envir = allEnvsInSimList[[objs]]),
+                                           objects[[name]]]
+      .robustDigest(mget(objectsToDigest, envir = allEnvsInSimList[[name]]),
                     quick = quick,
                     length = length)
     })
-    names(envirHash) <- names(allObjsInSimList)
+    #names(envirHash) <- names(allObjsInSimList)
     lens <- unlist(lapply(envirHash, function(x) length(x) > 0))
     envirHash <- envirHash[lens]
 
@@ -341,6 +344,7 @@ setMethod(
                     algo = dots$algo,
                     quick = dots$quick,
                     classOptions = dots$classOptions)
+
     changed <- if (length(postDigest$.list)) {
       internalSimList <- unlist(lapply(preDigest[[whSimList]]$.list,
                                        function(x) !any(startsWith(names(x), "doEvent"))))
@@ -349,7 +353,9 @@ setMethod(
       } else {
         which(internalSimList)
       }
-      isNewObj <- !names(postDigest$.list[[whSimList2]]) %in% names(preDigest[[whSimList]]$.list[[whSimList2]])
+
+      isNewObj <- !names(postDigest$.list[[whSimList2]]) %in%
+        names(preDigest[[whSimList]]$.list[[whSimList2]])
       newObjs <- names(postDigest$.list[[whSimList2]])[isNewObj]
       newObjs <- newObjs[!startsWith(newObjs, "._")]
       existingObjs <- names(postDigest$.list[[whSimList2]])[!isNewObj]
@@ -436,9 +442,10 @@ setMethod(
         #   makes soft copy of all objects, i.e., they have the identical objects, which are pointers only
         object2 <- Copy(tmpl[[whSimList]], objects = FALSE)
 
-        hasCurrModule <- currentModule(tmpl[[whSimList]])
+        currModules <- currentModule(tmpl[[whSimList]])
         # Convert to numeric index, as some modules don't have names
-        hasCurrModule <- match(hasCurrModule, modules(tmpl[[whSimList]]))
+        hasCurrModule <- match(currModules, modules(tmpl[[whSimList]]))
+        if (length(currModules) == 0) currModules <- modules(tmpl[[whSimList]])
 
         createOutputs <- if (length(hasCurrModule)) {
           tmpl[[whSimList]]@depends@dependencies[[hasCurrModule]]@outputObjects$objectName
@@ -448,8 +455,9 @@ setMethod(
           unique(unlist(aa))
         }
         createOutputs <- na.omit(createOutputs)
+        createOutputs <- c(createOutputs, currModules) # add the environments for each module - allow local objects
         # take only the ones that the file changed, based on attr(object, ".Cache")$changed
-        createOutputs <- createOutputs[createOutputs %in% attr(object, ".Cache")$changed]
+        changedOutputs <- createOutputs[createOutputs %in% attr(object, ".Cache")$changed]
 
         expectsInputs <- if (length(hasCurrModule)) {
           tmpl[[whSimList]]@depends@dependencies[[hasCurrModule]]@inputObjects$objectName
@@ -461,14 +469,9 @@ setMethod(
 
         # Copy all objects from createOutputs only -- all others take from tmpl[[whSimList]]
         lsObjectEnv <- ls(object@.xData, all.names = TRUE)
-        list2env(mget(lsObjectEnv[lsObjectEnv %in% createOutputs | lsObjectEnv %in% expectsInputs],
+        list2env(mget(lsObjectEnv[lsObjectEnv %in% changedOutputs | lsObjectEnv %in% expectsInputs],
                       envir = object@.xData), envir = object2@.xData)
         if (length(object2@current)==0) { # means it is not in a spades call
-          # numCompleted <- if (length(object2@completed)) {
-          #   length(unlist(object2@completed, recursive = FALSE))/(length(object2@completed[[1]]))
-          # } else {
-          #   0
-          # }
           object2@completed <- object@completed
         }
         if (NROW(current(object2)) == 0) {

diff --git a/R/copy.R b/R/copy.R
@@ -39,11 +39,38 @@ setMethod("Copy",
               sim_@events <- object@events
               sim_@current <- object@current
             }
+            sim_@.xData <- new.env(parent = asNamespace("SpaDES.core"))
+            attr(sim_@.xData, "name") <- "sim"
             if (objects) {
-              sim_@.xData <- Copy(sim_@.xData, filebackedDir = cachePath(object))
-            } else {
-              sim_@.xData <- new.env(parent = asNamespace("SpaDES.core"))
+              objNames <- ls(object, all.names = TRUE)
+              names(objNames) <- objNames
+              isEnv <- unlist(lapply(objNames,
+                                     function(obj) is.environment(get(obj, envir = object))))
+              list2env(mget(objNames[!isEnv], envir = object@.xData), envir = sim_@.xData)
+              list2env(lapply(objNames[isEnv], function(x) {
+                e <- new.env(parent = sim_@.xData)
+                attr(e, "name") <- x
+                e
+              }
+              ),
+              envir = sim_@.xData)
+
+              lapply(objNames[isEnv], function(en) {
+                list2env(as.list(object@.xData[[en]], all.names = TRUE),
+                         envir = sim_@.xData[[en]])
+                isFn <- unlist(lapply(ls(sim_@.xData[[en]]), function(obj)
+                  if (is.function(get(obj, envir = sim_@.xData[[en]]))) {
+                    environment(sim_@.xData[[en]][[obj]]) <- sim_@.xData[[en]]
+                  }
+                  ))
+                }
+              )
+              # list2env(Copy(mget(objNames[isEnv], envir = object@.xData), all.names = TRUE),
+              #               filebackedDir = cachePath(object),
+              #          envir = sim_@.xData)
             }
             sim_@.envir <- sim_@.xData
             return(sim_)
 })
+
+
diff --git a/R/simulation-spades.R b/R/simulation-spades.R
@@ -727,6 +727,20 @@ setMethod(
     do.call(setPaths, append(sim@paths, list(silent = TRUE)))
     on.exit({do.call(setPaths, append(list(silent = TRUE), oldGetPaths))}, add = TRUE)
 
+    # Make local activeBindings to mod
+    lapply(modules(sim), function(m) {
+      makeActiveBinding(sym = "mod",
+                        fun = function(value){
+                          if (missing(value)) {
+                            get(m, envir = sim, inherits = FALSE)
+                          } else {
+                            stop("Can't overwrite mod")
+                          }
+                        },
+                        env = sim[[m]])
+
+    })
+
     sim@.xData[["._startClockTime"]] <- Sys.time()
     .pkgEnv$searchPath <- search()
     .pkgEnv[["spades.browserOnError"]] <-
@@ -889,11 +903,14 @@ setMethod(
                       moduleCall, fnEnv, cur, notOlderThan) {
   if (cacheIt) { # means that a module or event is to be cached
     createsOutputs <- sim@depends@dependencies[[cur[["moduleName"]]]]@outputObjects$objectName
+    fns <- ls(fnEnv, all.names = TRUE)
     moduleSpecificObjects <-
       c(ls(sim@.xData, all.names = TRUE, pattern = cur[["moduleName"]]), # functions in the main .xData that are prefixed with moduleName
-        ls(fnEnv, all.names = TRUE), # functions in the namespaced location
+        fns, # functions in the namespaced location
         na.omit(createsOutputs)) # objects outputted by module
-    moduleSpecificOutputObjects <- createsOutputs
+    #fnsWOhidden <- paste0(cur[["moduleName"]], ":",
+    #                      grep("^\\._", fns, value = TRUE, invert = TRUE))
+    moduleSpecificOutputObjects <- c(createsOutputs, cur[["moduleName"]])
     classOptions <- list(events = FALSE, current=FALSE, completed=FALSE, simtimes=FALSE,
                          params = sim@params[[cur[["moduleName"]]]],
                          modules = cur[["moduleName"]])

diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R
@@ -373,6 +373,8 @@ test_that("Cache of sim objects via .Cache attr -- using preDigest and postDiges
       sim$co1 <- 1
       sim$co2 <- 1
       sim$co3 <- 1
+      sim$test$hi <- 1
+      mod$hello <- 2
       ",
       xxx1[[1]][(lineWithInit + 1):lineWithDotInputObjects], "
       aaa <- 1
@@ -385,23 +387,40 @@ test_that("Cache of sim objects via .Cache attr -- using preDigest and postDiges
                    params = list(test = list(.useCache = "init")))
   mySim$co4 <- 5
   mySim$co5 <- 6
-  mySim2 <- spades(mySim)
+  mySim2 <- spades(Copy(mySim))
   expect_true(mySim2$co1 == 1)
   expect_true(mySim2$co2 == 1)
   expect_true(mySim2$co3 == 1)
   expect_true(mySim2$co4 == 5)
   expect_true(mySim2$co5 == 6)
 
+  # Test mod
+  expect_true(mySim2$test$hello == 2)
+
   mySim <- simInit(paths = list(modulePath = tmpdir), modules = as.list(m[1]),
                    objects = list(co4 = 3, co3 = 2, co1 = 4), params =
                      list(test = list(.useCache = "init")))
+
   expect_true(mySim$co3 == 2) # will be changed by init
   expect_true(mySim$co1 == 4)# will be changed by init
-  mySim2 <- spades(mySim)
+  expect_true(is.null(mySim$test$hi)) # will be changed by init
+  mySim2 <- spades(Copy(mySim))
+  expect_true(mySim2$test$hi == 1) # was affected
   expect_true(mySim2$co1 == 1) # was affected
   expect_true(mySim2$co2 == 1)# was affected
   expect_true(mySim2$co3 == 1) # was affected
   expect_false(mySim2$co4 == 5) # wasn't affected by init event
   expect_true(mySim2$co4 == 3) # wasn't affect by init event
   expect_true(is.null(mySim2$co5)) # wan't affected, and isn't there
+
+  # Try again, hi should be there
+  expect_true(is.null(mySim$test$hi)) # is not in the
+  mess1 <- capture_output(mySim2 <- spades(Copy(mySim)))
+  expect_true(mySim2$test$hi == 1) # recovered in Cache
+  expect_true(mySim2$test$hello == 2) # recovered in Cache
+  expect_true(grepl("Using cached copy", mess1))
+
 })
+
+
+
diff --git a/tests/testthat/test-mod.R b/tests/testthat/test-mod.R
@@ -0,0 +1,93 @@
+test_that("local mod object", {
+  testInitOut <- testInit(smcc = FALSE, debug = FALSE)
+  on.exit({
+    testOnExit(testInitOut)
+  }, add = TRUE)
+
+  newModule("test", tmpdir, open = FALSE)
+  newModule("test2", tmpdir, open = FALSE)
+
+  sim <- simInit()
+
+  # Sept 18 2018 -- Changed to use "seconds" -- better comparison with simple loop
+  cat(file = file.path(tmpdir, "test", "test.R"),'
+      defineModule(sim, list(
+      name = "test",
+      description = "insert module description here",
+      keywords = c("insert key words here"),
+      authors = person(c("Eliot", "J", "B"), "McIntire", email = "eliot.mcintire@canada.ca", role = c("aut", "cre")),
+      childModules = character(0),
+      version = list(SpaDES.core = "0.1.0", test = "0.0.1"),
+      spatialExtent = raster::extent(rep(NA_real_, 4)),
+      timeframe = as.POSIXlt(c(NA, NA)),
+      timeunit = "second",
+      citation = list("citation.bib"),
+      documentation = list("README.txt", "test.Rmd"),
+      reqdPkgs = list(),
+      parameters = rbind(
+      ),
+      inputObjects = bind_rows(
+      ),
+      outputObjects = bind_rows(
+      )
+      ))
+
+      doEvent.test = function(sim, eventTime, eventType, debug = FALSE) {
+      switch(
+      eventType,
+      init = {
+      mod$a <- 2
+
+      sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 1, "test", "event1", .skipChecks = TRUE)
+      },
+      event1 = {
+      sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 1, "test", "event1", .skipChecks = TRUE)
+      })
+      return(invisible(sim))
+      }
+      ', fill = TRUE)
+
+  cat(file = file.path(tmpdir, "test2", "test2.R"),'
+      defineModule(sim, list(
+      name = "test2",
+      description = "insert module description here",
+      keywords = c("insert key words here"),
+      authors = person(c("Eliot", "J", "B"), "McIntire", email = "eliot.mcintire@canada.ca", role = c("aut", "cre")),
+      childModules = character(0),
+      version = list(SpaDES.core = "0.1.0", test2 = "0.0.1"),
+      spatialExtent = raster::extent(rep(NA_real_, 4)),
+      timeframe = as.POSIXlt(c(NA, NA)),
+      timeunit = "second",
+      citation = list("citation.bib"),
+      documentation = list("README.txt", "test2.Rmd"),
+      reqdPkgs = list(),
+      parameters = rbind(
+      ),
+      inputObjects = bind_rows(
+      ),
+      outputObjects = bind_rows(
+      )
+      ))
+
+      doEvent.test2 = function(sim, eventTime, eventType, debug = FALSE) {
+      switch(
+      eventType,
+      init = {
+      mod$a <- 1
+      sim <- scheduleEvent(sim, start(sim), "test2", "event1", .skipChecks = TRUE)
+      },
+      event1 = {
+      mod$b <- mod$a + 1
+      sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE)
+      })
+      return(invisible(sim))
+      }
+      ', fill = TRUE)
+  mySim <- simInit(times = list(start = 0, end = 0),
+                   paths = list(modulePath = tmpdir), modules = c("test", "test2"))
+  out <- spades(mySim)
+  expect_true(out$test$a == 2)
+  expect_true(out$test2$a == 1)
+  expect_true(out$test2$b == 2)
+
+})