Nothing
if (!isGeneric(".robustDigest")) {
setGeneric(
".robustDigest",
function(object, .objects, length = Inf, algo = "xxhash64", ...) {
standardGeneric(".robustDigest")
}
)
}
#' `.robustDigest` for `simList` objects
#'
#' This is intended to be used within the `Cache` function, but can be used to evaluate what
#' a `simList` would look like once it is converted to a repeatably digestible object.
#'
#' See [reproducible::.robustDigest()].
#' This method strips out stuff from a `simList` class object that would make it otherwise not
#' reproducibly digestible between sessions, operating systems, or machines.
#' This will likely still not allow identical digest results across R versions.
#'
#' @inheritParams reproducible::.robustDigest
#'
#' @aliases Cache
#' @author Eliot McIntire
#' @exportMethod .robustDigest
#' @importFrom Require modifyList2 invertList
#' @importFrom reproducible asPath .orderDotsUnderscoreFirst .robustDigest .sortDotsUnderscoreFirst
#' @importMethodsFrom reproducible .robustDigest
#' @include simList-class.R
#' @rdname robustDigest
#' @seealso [reproducible::.robustDigest()]
setMethod(
".robustDigest",
signature = "simList",
definition = function(object, .objects, length, algo, quick, classOptions) {
# browser(expr = exists("._robustDigest_1"))
curMod <- currentModule(object)
outerObjs <- ls(object@.xData, all.names = TRUE)
moduleObjs <- ls(object@.xData$.mods, all.names = TRUE)
moduleEnvirs <- mget(moduleObjs[moduleObjs %in% unlist(modules(object))],
envir = object@.xData$.mods)
moduleObjs <- lapply(moduleEnvirs, function(me) ls(me, all.names = TRUE))
allObjsInSimList <- append(list(".xData" = outerObjs), moduleObjs)
allObjsInSimList$.xData <- allObjsInSimList$.xData[!allObjsInSimList$.xData %in% ".mods"]
allEnvsInSimList <- append(list(.xData = object@.xData), moduleEnvirs)
ord1 <- .orderDotsUnderscoreFirst(allObjsInSimList)
ord2 <- .orderDotsUnderscoreFirst(names(allEnvsInSimList))
allObjsInSimList <- allObjsInSimList[ord1]
allEnvsInSimList <- allEnvsInSimList[ord2]
# names(allEnvsInSimList) <- names(allObjsInSimList)
isObjectEmpty <- if (!missing(.objects)) {
if (!is.null(.objects)) {
FALSE
} else {
TRUE
}
} else {
TRUE
}
if (!isObjectEmpty) {
# objects may be provided in a namespaced format: modName:objName --
# e.g., coming from .parseModule
objectsMods <- grep("\\.mods\\$", .objects, value = TRUE)
objectsMods <- gsub("\\.mods\\$", "", objectsMods)
names(objectsMods) <- objectsMods
objects1ByModWhole <- lapply(objectsMods, function(mod) ls(envir = object@.xData$.mods[[mod]], all.names = TRUE))
.objects <- grep("\\.mods\\$", .objects, value = TRUE, invert = TRUE)
objects1 <- strsplit(.objects, split = ":")
lens <- unlist(lapply(objects1, length))
objects1ByMod <- unlist(lapply(objects1[lens > 1], function(x) x[1]))
mods <- unique(objects1ByMod)
objects2 <- lapply(mods, function(mod) {
unlist(lapply(objects1[lens > 1][objects1ByMod == mod], function(x) x[[2]]))
})
names(objects2) <- mods
.objects <- append(list(".xData" = unlist(objects1[lens == 1])), objects2)
if (length(objects1ByModWhole))
.objects <- suppressWarnings(modifyList2(.objects, objects1ByModWhole))
} else {
.objects <- allObjsInSimList
}
envirHash <- Map(objs = allObjsInSimList, name = names(allObjsInSimList),
function(objs, name) {
# browser(expr = exists("._robustDigest_5"))
dotUnderscoreObjs <- objs[startsWith(objs, "._")]
objs <- objs[!objs %in% c(dotUnderscoreObjs, "mod", "Par")]
objs <- objs[objs %in% .objects[[name]]]
if (length(objs) > 1) {
objs <- sort(objs, method = "radix")
}
out <- if (length(objs) > 0) {
a <- mget(objs, envir = allEnvsInSimList[[name]])
nonZero <- unlist(lapply(a, function(x) length(x) > 0))
.robustDigest(a[nonZero],
quick = !isFALSE(quick), # can be character or TRUE --> TRUE
length = length, classOptions = classOptions) # need classOptions
} else {
list()
}
})
#names(envirHash) <- names(allObjsInSimList)
lens <- unlist(lapply(envirHash, function(x) length(x) > 0))
envirHash <- envirHash[lens]
# demote .mods objects into .xData
eh <- envirHash[names(envirHash)[names(envirHash) %in% names(moduleEnvirs)]]
envirHash$.xData[names(eh)] <- eh
envirHash[names(eh)] <- NULL
# browser(expr = exists("._robustDigest_3"))
# Copy all parts except environment, clear that, then convert to list
objectTmp <- object
object <- Copy(object, objects = FALSE, queues = FALSE)
object <- as(object, "simList_")
# Replace the .list slot with the hashes of the slots
object@.Data <- envirHash
# Remove paths (i.e., dirs) as they are not relevant -- it is only the files that are relevant
# i.e., if the same file is located in a different place, that is ok
object@paths <- list()
# don't cache contents of output because file may already exist
object@outputs$file <- basename(object@outputs$file)
object@outputs$file <- tools::file_path_sans_ext(object@outputs$file) # could be qs or rds; doesn't matter for Cache
if (NROW(object@inputs)) {
object@inputs$file <- unlist(.robustDigest(object@inputs$file, quick = quick, length = length)) #nolint
}
deps <- object@depends@dependencies
for (i in seq_along(deps)) {
if (!is.null(deps[[i]])) {
object@depends@dependencies[[i]] <- lapply(
slotNames(object@depends@dependencies[[i]]), function(x) {
slot(object@depends@dependencies[[i]], x)
})
names(object@depends@dependencies[[i]]) <- slotNames(deps[[i]])
object@depends@dependencies[[i]][["timeframe"]] <- as.Date(deps[[i]]@timeframe)
}
}
if (!is.null(classOptions$.globals)) {
newGlobals <- object@params$.globals
}
if (!is.null(classOptions$modules)) if (length(classOptions$modules)) {
object@modules <- list(classOptions$modules)
object@depends@dependencies <- object@depends@dependencies[classOptions$modules]
}
# if this call is within a single module, only keep module-specific params
if (length(curMod) > 0) {
omitParams <- c(".showSimilar", ".useCache")
object@params <- object@params[curMod]
object@params[[curMod]] <- object@params[[curMod]][!names(object@params[[curMod]]) %in% omitParams]
}
object@params <- lapply(object@params, function(x) .sortDotsUnderscoreFirst(x))
object@params <- .sortDotsUnderscoreFirst(object@params)
# Deal with globals
if (!is.null(classOptions$.globals)) {
object@params <- append(list(.globals = newGlobals), object@params)
}
nonDotList <- grep(".list|.Data", slotNames(object), invert = TRUE, value = TRUE)
obj <- list()
obj$.list <- object@.Data
if (length(obj$.list)) {
objNames <- names(obj$.list[[1]])
dotUnderscoreObjs <- objNames[startsWith(objNames, "._")]
obj$.list[[1]][dotUnderscoreObjs] <- NULL
# Now deal with ._ objects inside each module's environment
objNamesInner <- lapply(obj$.list[[1]][], names)
namesObjNamesInner <- names(objNamesInner)
names(namesObjNamesInner) <- namesObjNamesInner
nestedDotUnderscoreObjs <- lapply(namesObjNamesInner,
function(x) {
if (!is.null(objNamesInner[[x]]))
objNamesInner[[x]][startsWith(objNamesInner[[x]], "._")]
})
nestedDotUnderscoreObjs <- nestedDotUnderscoreObjs[names(unlist(nestedDotUnderscoreObjs, recursive = FALSE))]
noneToRm <- unlist(lapply(nestedDotUnderscoreObjs, function(x) length(x) == 0))
nestedDotUnderscoreObjs[noneToRm] <- NULL
obj$.list[[1]][names(nestedDotUnderscoreObjs)] <-
Map(na = obj$.list[[1]][names(nestedDotUnderscoreObjs)],
nduo = nestedDotUnderscoreObjs, function(na, nduo) {
na[nduo] <- NULL
na
})
}
# outputs --> should not be treated like inputs; if they change, it is OK, so just outputs as a data.frame,
# not files
nonDotListNoOutputs <- setdiff(nonDotList, "outputs")
dependsSeparate <- setdiff(nonDotListNoOutputs, "depends")
obj[dependsSeparate] <- lapply(dependsSeparate, function(x) {
.robustDigest(slot(object, x), algo = algo)})
dependsFirst <- obj[["depends"]] <- list()
if (!isTRUE(all(sapply(object@depends@dependencies, is.null)))) {
for (ii in c("inputObjects", "outputObjects", "parameters")) {
dependsFirst[[ii]] <-
.robustDigest(lapply(object@depends@dependencies,
function(mo) {
mo[[ii]][, grep("desc$", colnames(mo[[ii]]), value = TRUE, invert = TRUE)]
}))
}
obj[["depends"]] <- invertList(dependsFirst)
}
otherDependsToDig <- c("childModules", "loadOrder", "reqdPkgs",
"spatialExtent", "timeframe", "timeunit", "version")
dependsSecond <-
.robustDigest(lapply(object@depends@dependencies,
function(mo) {
mo[otherDependsToDig]
} ))
obj[["depends"]] <- modifyList2(obj[["depends"]], dependsSecond)
# obj[["depends"]] <- .robustDigest(object@depends@dependencies, algo = algo)
obj <- .sortDotsUnderscoreFirst(obj)
obj["outputs"] <- .robustDigest(object@outputs[, c("objectName", "saveTime", "file", "arguments")], quick = TRUE)
if (!is.null(classOptions$events)) {
if (FALSE %in% classOptions$events) obj$events <- NULL
}
if (!is.null(classOptions$current)) {
if (FALSE %in% classOptions$current) obj$current <- NULL
}
if (!is.null(classOptions$completed)) {
if (FALSE %in% classOptions$completed) obj$completed <- NULL
}
if (!is.null(classOptions$simtimes)) {
if (FALSE %in% classOptions$simtimes) obj$simtimes <- NULL
}
# browser(expr = exists("._robustDigest_4"))
obj
})
if (!isGeneric(".tagsByClass")) {
setGeneric(".tagsByClass", function(object) {
standardGeneric(".tagsByClass")
})
}
#' `.tagsByClass` for `simList` objects
#'
#' See [reproducible::.tagsByClass()]. Adds current `moduleName`,
#' `eventType`, `eventTime`, and `function:spades` as `userTags`.
#'
#' @inheritParams reproducible::.tagsByClass
#'
#' @author Eliot McIntire
#' @exportMethod .tagsByClass
#' @importFrom reproducible .tagsByClass
#' @importFrom reproducible .grepSysCalls
#' @importMethodsFrom reproducible .tagsByClass
#' @include simList-class.R
#' @seealso [reproducible::.tagsByClass]
#' @rdname tagsByClass
setMethod(
".tagsByClass",
signature = "simList",
definition = function(object) {
cur <- object@current
if (NROW(cur)) {
userTags <- c(
paste0("module:", cur$moduleName),
paste0("eventType:", cur$eventType),
paste0("eventTime:", cur$eventTime),
paste0("otherFunctions:spades")
) # add this because it will be an outer function, if there are events occurring
} else {
scalls <- sys.calls()
parseModuleFrameNum <- .grepSysCalls(scalls, "^.parseModule")[2]
if (!is.na(parseModuleFrameNum)) {
inObj <- .grepSysCalls(scalls, pattern = "^.inputObjects")
if (any(!is.na(inObj))) {
userTags <- c("otherFunctions:.inputObjects")
userTags1 <- tryCatch(paste0("module:", get("m", sys.frame(parseModuleFrameNum))),
error = function(x) NULL)
userTags <- c(userTags, userTags1)
}
} else {
userTags <- NULL
}
}
userTags
})
if (!isGeneric(".cacheMessage")) {
setGeneric(".cacheMessage", function(object, functionName, fromMemoise, verbose) {
standardGeneric(".cacheMessage")
})
}
#' `.cacheMessage` for `simList` objects
#'
#' See [reproducible::.cacheMessage()].
#'
#' @exportMethod .cacheMessage
#' @importFrom cli col_blue
#' @importFrom reproducible .cacheMessage messageCache
#' @importMethodsFrom reproducible .cacheMessage
#' @inheritParams reproducible::.cacheMessage
#' @include simList-class.R
#' @rdname cacheMessage
#' @seealso [reproducible::.cacheMessage]
setMethod(
".cacheMessage",
signature = "simList",
definition = function(object, functionName,
fromMemoise = getOption("reproducible.useMemoise", TRUE),
verbose = getOption("reproducible.verbose")) {
cur <- current(object)
.cacheMessage(NULL, functionName, fromMemoise = fromMemoise, verbose = verbose)
if (NROW(cur)) {
whichCached <- grep(".useCache", object@params)
useCacheVals <- lapply(whichCached, function(x) {
object@params[[x]]$.useCache
})
whCurrent <- match(cur$moduleName, names(object@params)[whichCached])
if (is.na(fromMemoise)) fromMemoise <- FALSE
fromWhere <- c("cached", "memoised")[fromMemoise + 1]
# if (isTRUE(useCacheVals[[whCurrent]])) {
# if (isTRUE(fromMemoise)) {
# message(cli::col_blue(" Loading memoised copy of", cur$moduleName, "module"))
# } else if (!is.na(fromMemoise)) {
# message(cli::col_blue(" loaded cached copy of", cur$moduleName, "module"),
# "\n ",
# cli::col_blue(.message$AddingToMemoised))
# } else {
# message(cli::col_blue(" loaded ", fromWhere," copy of", cur$moduleName, "module"))
# }
# } else {
messageCache(.message$HangingIndent, "for ", cur$eventType, " event in ", cur$moduleName, " module", verbose = verbose)
# }
} else {
messageCache(.message$HangingIndent, "from ", cur$moduleName, " module", verbose = verbose)
}
})
if (!isGeneric(".checkCacheRepo")) {
setGeneric(".checkCacheRepo", function(object, create = FALSE) {
standardGeneric(".checkCacheRepo")
})
}
#' `.checkCacheRepo` for `simList` objects
#'
#' See [reproducible::.checkCacheRepo()].
#'
#' @inheritParams reproducible::.checkCacheRepo
#'
#' @return character string representing a directory path to the cache repo
#'
#' @export
#' @exportMethod .checkCacheRepo
#' @importFrom reproducible .checkCacheRepo .grepSysCalls
#' @importMethodsFrom reproducible .checkCacheRepo
#' @include simList-class.R
#' @rdname checkCacheRepo
#' @seealso [reproducible::.checkCacheRepo]
setMethod(
".checkCacheRepo",
signature = "list",
definition = function(object, create = FALSE) {
object <- .findSimList(object)
whSimList <- unlist(lapply(object, is, "simList"))
if (any(whSimList)) {
# just take the first simList, if there are >1
cachePath <- object[whSimList][[1]]@paths$cachePath
} else {
doEventFrameNum <- .grepSysCalls(sys.calls(), "(^doEvent)|(^.parseModule)")[2]
if (!is.na(doEventFrameNum)) {
sim <- get("sim", envir = sys.frame(doEventFrameNum))
cachePath <- sim@paths$cachePath
} else {
cachePath <- .getOption("reproducible.cachePath")
#checkPath(cachePath, create = TRUE) #SpaDES dependency
}
}
checkPath(path = cachePath, create = create)
})
if (!isGeneric(".addChangedAttr")) {
setGeneric(".addChangedAttr", function(object, preDigest, origArguments, ...) {
standardGeneric(".addChangedAttr")
})
}
#' `.addChangedAttr` for `simList` objects
#'
#' This will evaluate which elements in the `simList` object changed following
#' this Cached function call. It will add a named character string as an
#' attribute `attr(x, ".Cache")$changed`, indicating which ones changed.
#' When this function is subsequently called again, only these changed objects
#' will be returned. All other `simList` objects will remain unchanged.
#'
#' @inheritParams reproducible::.addChangedAttr
#'
#' @return returns the object with attribute added
#'
#' @export
#' @exportMethod .addChangedAttr
#' @importFrom reproducible .addChangedAttr .setSubAttrInList
#' @importMethodsFrom reproducible .addChangedAttr
#' @include simList-class.R
#' @rdname addChangedAttr
#' @seealso [reproducible::.addChangedAttr]
setMethod(
".addChangedAttr",
signature = "simList",
definition = function(object, preDigest, origArguments, ...) {
dots <- list(...)
whSimList <- which(unlist(lapply(origArguments, is, "simList")))[1]
# remove the "newCache" attribute, which is irrelevant for digest
if (!is.null(attr(object, ".Cache")$newCache)) {
object <- .setSubAttrInList(object, ".Cache", "newCache", NULL)
if (!identical(attr(object, ".Cache")$newCache, NULL))
stop("attributes on the cache object are not correct - 4")
}
postDigest <- .robustDigest(object, .objects = dots$.objects,
length = dots$length,
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"))))
whSimList2 <- if (is.null(internalSimList) || isFALSE(internalSimList)) {
1
} else {
# this can be wrongly of length > 1 -- unclear why, but should be safe to take 1st
which(internalSimList)[1]
}
# remove all functions from the module environment; they aren't allowed to be redefined within a function
if (length(preDigest[[whSimList]]$.list)) {
out <- setdiffNamedRecursive(postDigest$.list[[whSimList2]],
preDigest[[whSimList]]$.list[[whSimList2]])
} else {
out <- postDigest$.list[[whSimList2]]
}
for (modNam in modules(object)) {
isModElement <- names(out) == modNam
if (any(isModElement)) {
isDotObjects <- names(out[isModElement][[modNam]]) == ".objects"
if (any(!isDotObjects))
out[isModElement][[modNam]][!isDotObjects] <- NULL
}
}
changedObjs <- out[lengths(out) > 0] # remove empty elements
changed <- changedObjs
changed
} else {
character()
}
object <- .setSubAttrInList(object, ".Cache", "changed", changed)
#attr(object, ".Cache")$changed <- changed
if (!identical(attr(object, ".Cache")$changed, changed))
stop("attributes on the cache object are not correct - 5")
object
})
if (!isGeneric(".preDigestByClass")) {
setGeneric(".preDigestByClass", function(object) {
standardGeneric(".preDigestByClass")
})
}
if (!isGeneric(".prepareOutput")) {
setGeneric(".prepareOutput", function(object) {
standardGeneric(".prepareOutput")
})
}
#' @importFrom Require setdiffNamed
setdiffNamedRecursive <- function(l1, l2, missingFill) {
l1Different <- Require::setdiffNamed(l1, l2)
if (length(l1Different)) {
areList <- unlist(lapply(l1Different, is, "list"))
if (any(areList)) {
l1Different[areList] <- Map(nl1 = names(l1Different)[areList], function(nl1) {
if (nl1 %in% names(l2)) {
setdiffNamedRecursive(l1Different[[nl1]], l2[[nl1]])
} else {
l1Different[[nl1]]
}
})
}
if (any(!areList)) {
l1Different[!areList] <- Require::setdiffNamed(l1Different[!areList], l2)
}
} else {
l1Different <- Require::setdiffNamed(l1, l2)
}
l1Different
}
#' `.prepareOutput` for `simList` objects
#'
#' See [reproducible::.prepareOutput()].
#'
#' @inheritParams reproducible::.prepareOutput
#'
#' @return the modified `object`
#'
#' @export
#' @exportMethod .prepareOutput
#' @include simList-class.R
#' @importFrom data.table setattr
#' @importFrom reproducible .prepareOutput
#' @importMethodsFrom reproducible .prepareOutput
#' @rdname prepareOutput
#' @seealso [reproducible::.prepareOutput]
setMethod(
".prepareOutput",
signature = "simList",
definition = function(object, cachePath, ...) {
simFromCache <- object # rename for internal purposes
simPre <- list(...)
simPre <- .findSimList(simPre)
# only take first simList -- may be a problem:
whSimList <- which(unlist(lapply(simPre, is, "simList")))[1]
simListInput <- !isTRUE(is.na(whSimList))
if (simListInput) {
simPreOrigEnv <- simPre[[whSimList]]@.xData
isListOfSimLists <- if (is.list(simFromCache)) {
if (is(simFromCache[[1]], "simList")) TRUE else FALSE
} else {
FALSE
}
if (isListOfSimLists) {
simPost <- list()
for (i in seq_along(simFromCache)) {
stop("It looks like there are more than one simList in the Cached objects; ",
"Cache does not correctly deal with this currently.")
# need to keep the list(...) slots ...
# i.e., Caching of simLists is mostly about objects in .xData
simPost[[i]] <- Copy(simPre[[whSimList]], objects = FALSE)
simPost[[i]]@.xData <- simFromCache[[i]]@.xData
simPost[[i]]@completed <- simFromCache[[i]]@completed
simPost[[i]]@simtimes <- simFromCache[[i]]@simtimes
simPost[[i]]@current <- simFromCache[[i]]@current
simPost[[i]]@events <- simFromCache[[i]]@events
lsSimPreOrigEnv <- ls(simPreOrigEnv, all.names = TRUE)
keepFromOrig <- !(lsSimPreOrigEnv %in% ls(simPost[[i]]@.xData, all.names = TRUE))
# list2env(mget(lsSimPreOrigEnv[keepFromOrig], envir = simPreOrigEnv),
# envir = simPost[[i]]@.xData)
list2env(mget(lsSimPreOrigEnv[keepFromOrig], envir = simPre[[whSimList]]@.xData),
envir = simPost[[i]]@.xData)
}
} else {
# Setup some things to use throughout
currModules <- currentModule(simPre[[whSimList]])
# Step 1 -- copy the non-simEnv slots
simPost <- Copy(simPre[[whSimList]], objects = FALSE)
# This was unnecessary if the parameters never change; but they can
# -- but draw from Cache only from this module -- other modules may have
# changed during this simInit/spades call --> don't want their cached copies
# UNLESS they changed via the updateParamsFromGlobals mechanism!! Then DO want
# cached copy of other modules
simPost@params[currModules] <- simFromCache@params[currModules]
if (FALSE) { # Eliot Dec 2023 -- removed this because it is already occuring during simInit;
# also, user may have passed individual values for individual modules that should not
# be overridden by globals
anyNewGlobals <- setdiffNamed(simFromCache@params$.globals, simPost@params$.globals)
if (length(anyNewGlobals)) {
suppressMessages(
simPost@params <- updateParamsSlotFromGlobals(simPost@params, simFromCache@params))
}
}
# Step 2 -- copy the objects that are in simPre to simPost
# objsInPre <- ls(simPre[[whSimList]]@.xData, all.names = TRUE)
# objsInPre <- grep("^\\._", objsInPre, value = TRUE, invert = TRUE)
# This needs to have different environments, i.e., like what Copy does
# list2env(mget(objsInPre, envir = simPre[[whSimList]]@.xData), envir = simPost@.xData)
# Step 2 -- figure out where to get objects in simEnv from -- preSim or simRecoveredFromCache
# Convert to numeric index, as some modules don't have names
# hasCurrModule <- match(currModules, modules(simPre[[whSimList]]))
lsObjectEnv <- ls(simFromCache@.xData, all.names = TRUE)
if (!is.null(simFromCache@.xData$.mods))
changedModEnvObjs <- ls(simFromCache@.xData$.mods, all.names = TRUE)
deps <- simPre[[whSimList]]@depends@dependencies
namesAllMods <- names(deps)
if (!is.null(namesAllMods)) { # i.e., no modules exist in the simList
hasCurrModule <- match(currModules, names(deps))
if (length(currModules) == 0) currModules <- namesAllMods
createOutputs <- if (length(hasCurrModule)) {
deps[[hasCurrModule]]@outputObjects$objectName
} else {
aa <- lapply(deps, function(dep) dep@outputObjects$objectName)
unique(unlist(aa))
}
createOutputs <- na.omit(createOutputs)
# add the environments for each module - allow local objects
createOutputs <- c(createOutputs, currModules)
# take only the ones that the file changed, based on attr(simFromCache, ".Cache")$changed
changedOutputs <- createOutputs[createOutputs %in% names(attr(simFromCache, ".Cache")$changed)]
expectsInputs <- if (length(hasCurrModule)) {
deps[[hasCurrModule]]@inputObjects$objectName
} else {
aa <- lapply(deps, function(dep)
dep@inputObjects$objectName)
unique(unlist(aa))
}
lsObjectEnv <- lsObjectEnv[lsObjectEnv %in% changedOutputs | lsObjectEnv %in% expectsInputs]
if (!is.null(simFromCache@.xData$.mods)) {
privateObjectsInModules <- attr(simFromCache, ".Cache")$changed
objsWithChangeInners <- intersect(namesAllMods, names(privateObjectsInModules))
changedModEnvObjs <- privateObjectsInModules[objsWithChangeInners]
}
}
# Copy all objects from createOutputs only -- all others take from simPre[[whSimList]]
list2env(mget(lsObjectEnv, envir = simFromCache@.xData), envir = simPost@.xData)
otherModules <- setdiff(namesAllMods, currModules)
# Need to pull all things from "other modules" i.e., functions and .objects etc. from non currModules
if (length(currModules)) {
lapply(currModules, function(currModule) {
currMods <- simPre[[whSimList]]@.xData$.mods[[currModule]]
objsInModuleActive <- ls(currMods, all.names = TRUE)
dontCopyObjs <- c(".objects", "mod", "Par") # take these from the Cached copy (made 3 lines above)
objsInModuleActive <- setdiff(objsInModuleActive, dontCopyObjs)
if (length(objsInModuleActive))
list2env(mget(objsInModuleActive, envir = simPre[[whSimList]]@.xData$.mods[[currModule]]),
envir = simPost@.xData$.mods[[currModule]])
})
}
if (length(otherModules)) {
lapply(otherModules, function(otherModule) {
otherMods <- simPre[[whSimList]]@.xData$.mods[[otherModule]]
objsInModuleActive <- ls(otherMods, all.names = TRUE)
# dontCopyObjs <- c(".objects", "mod", "Par") # take these from the Cached copy (made 3 lines above)
# objsInModuleActive <- setdiff(objsInModuleActive, dontCopyObjs)
if (length(objsInModuleActive))
list2env(mget(objsInModuleActive, envir = simPre[[whSimList]]@.xData$.mods[[otherModule]]),
envir = simPost@.xData$.mods[[otherModule]])
})
}
# Deal with .mods objects
if (!is.null(simFromCache@.xData$.mods)) {
# These are the unchanged objects
for (modNam in currModules) {
objs <-
setdiffNamedRecursive(as.list(simPre[[1]]$.mods[[modNam]]$.objects, all.names = TRUE),
changedModEnvObjs[[modNam]]$.objects)
if (length(objs))
list2env(objs, simPost$.mods[[modNam]]$.objects)
}
# Now changed objects
if (length(unlist(changedModEnvObjs))) {
Map(nam = names(changedModEnvObjs), objs = changedModEnvObjs, function(nam, objs) {
objNames <- names(objs$.objects)
if (!is.null(objNames))
list2env(mget(objNames, envir = simFromCache@.xData$.mods[[nam]][[".objects"]]),
envir = simPost@.xData$.mods[[nam]][[".objects"]])
})
# override everything first -- this includes .objects -- take from Cache
# list2env(mget(changedModEnvObjs, envir = simFromCache@.xData$.mods), envir = simPost@.xData$.mods)
# BUT functions are so lightweight that they should always return current
}
}
makeSimListActiveBindings(simPost)
if (length(simPost@current) == 0) {
## means it is not in a spades call
simPost@completed <- simFromCache@completed
}
if (NROW(current(simPost)) == 0) {
# this is usually a spades call, i.e., not an event or module doEvent call
simPost@events <- simFromCache@events
simPost@simtimes <- simFromCache@simtimes
} else {
# if this is FALSE, it means that events were added by the event
eventsAddedByThisModule <- events(simFromCache)$moduleName == current(simPost)$moduleName
if (isTRUE(any(eventsAddedByThisModule))) {
if (!isTRUE(all.equal(simFromCache@events, simPost@events))) {
b <- simFromCache@events
b <- lapply(b, function(x) {x[["order"]] <- 2; x})
d <- simPost@events
d <- lapply(d, function(x) {x[["order"]] <- 1; x})
a <- do.call(unique, args = alist(append(b[eventsAddedByThisModule], d)))
# a <- do.call(unique,
# args = list(append(simFromCache@events[eventsAddedByThisModule], simPost@events)))
a1 <- rbindlist(a)
f1 <- a[order(a1$eventTime, a1$eventPriority, a1$order)]
simPost@events <- lapply(f1, function(f) {
f$order <- NULL
f
})
# simPost@events <- do.call(unique,
# args = list(append(simFromCache@events[eventsAddedByThisModule], simPost@events)))
}
}
#simPost@events <- unique(rbindlist(list(simFromCache@events, simPost@events)))
}
simPost@current <- simFromCache@current
# This is for objects that are not in the return environment yet because they are unrelated to the
# current module -- these need to be copied over
lsSimPreOrigEnv <- ls(simPreOrigEnv, all.names = TRUE)
keepFromOrig <- !(lsSimPreOrigEnv %in% ls(simPost@.xData, all.names = TRUE))
list2env(mget(lsSimPreOrigEnv[keepFromOrig], envir = simPreOrigEnv), envir = simPost@.xData)
# Deal with .mods
# lsOrigModsEnv <- ls(simPreOrigEnv$.mods, all.names = TRUE)
# keepFromModsOrig <- !(lsOrigModsEnv %in% ls(simPost@.xData$.mods, all.names = TRUE))
# list2env(mget(lsOrigModsEnv[keepFromModsOrig], envir = simPreOrigEnv$.mods), envir = simPost@.xData$.mods)
if (exists("objectSynonyms", envir = simPost@.xData)) {
objSyns <- lapply(attr(simPost$objectSynonyms, "bindings"), function(x) unname(unlist(x)))
# must remove the "other ones" first
objNonCanonical <- unlist(lapply(objSyns, function(objs) objs[-1]))
objNonCanonicalExist <- unlist(lapply(objNonCanonical, exists, envir = simPost@.xData))
if (any(objNonCanonicalExist))
rm(list = objNonCanonical[objNonCanonicalExist], envir = simPost@.xData)
suppressMessages(objectSynonyms(synonyms = objSyns, envir = simPost@.xData))
}
}
if (!is.null(attr(simFromCache, "removedObjs"))) {
if (length(attr(simFromCache, "removedObjs"))) {
rm(list = attr(simFromCache, "removedObjs"), envir = simPost@.xData)
}
}
# Need the .Cache attributes from the recovered simFromCache
attr(simPost, ".Cache") <- attr(simFromCache, ".Cache")
attrsToGrab <- setdiff(names(attributes(simFromCache)), names(attributes(simPost)))
for (atts in attrsToGrab) {
setattr(simPost, atts, attr(simFromCache, atts))
#attr(simPost, atts) <- attr(simFromCache, atts)
if (!identical(attr(simPost, atts), attr(simFromCache, atts)))
stop("attributes on the cache simFromCache are not correct - 6")
}
return(simPost)
} else {
return(simFromCache)
}
})
#' Pre-digesting method for `simList`
#'
#' Takes a snapshot of `simList` objects.
#'
#' See [reproducible::.preDigestByClass()].
#'
#' @inheritParams reproducible::.preDigestByClass
#'
#' @return character vector corresponding to the names of objects stored in the `.xData` slot
#'
#' @author Eliot McIntire
#' @export
#' @exportMethod .preDigestByClass
#' @importFrom reproducible .preDigestByClass
#' @importMethodsFrom reproducible .preDigestByClass
#' @include simList-class.R
#' @rdname preDigestByClass
#' @seealso [reproducible::.preDigestByClass]
setMethod(
".preDigestByClass",
signature = "simList",
definition = function(object) {
obj <- ls(object@.xData, all.names = TRUE)
return(obj)
})
if (!isGeneric(".addTagsToOutput")) {
setGeneric(".addTagsToOutput", function(object, outputObjects, FUN) {
standardGeneric(".addTagsToOutput")
})
}
#' `.addTagsToOutput` for `simList` objects
#'
#' See [reproducible::.addTagsToOutput()].
#'
#' @inheritParams reproducible::.addTagsToOutput
#'
#' @return modified `object`, with attributes added
#'
#' @author Eliot McIntire
#' @exportMethod .addTagsToOutput
#' @export
#' @importFrom data.table setattr
#' @importFrom reproducible .addTagsToOutput
#' @importMethodsFrom reproducible .addTagsToOutput
#' @include simList-class.R
#' @rdname addTagsToOutput
setMethod(
".addTagsToOutput",
signature = "simList",
definition = function(object, outputObjects, FUN, preDigestByClass) {
if (!is.null(outputObjects)) {
# browser(expr = exists("._addTagsToOutput_2"))
outputToSave <- object
outputToSave@.xData <- new.env(parent = emptyenv())
outputToSave@.xData$.mods <- new.env(parent = asNamespace("SpaDES.core"))
outputToSave@.envir <- outputToSave@.xData
# Some objects are conditionally produced from a module's outputObject
lsEnv <- ls(object@.xData, all.names = TRUE)
whExist <- outputObjects %in% lsEnv
list2env(mget(outputObjects[whExist], envir = object@.xData), envir = outputToSave@.xData)
# Deal with .mods
outputObjectsMods <- grep(".mods", outputObjects, value = TRUE)
outputObjectsMods <- gsub("(.*)\\$", "", outputObjectsMods)
list2env(mget(outputObjectsMods, envir = object@.xData$.mods),
envir = outputToSave@.xData$.mods)
setattr(outputToSave, "tags", attr(object, "tags"))
setattr(outputToSave, "call", attr(object, "call"))
#attr(outputToSave, "tags") <- attr(object, "tags")
#attr(outputToSave, "call") <- attr(object, "call")
if (isS4(FUN)) {
setattr(outputToSave, "function", attr(object, "function"))
# attr(outputToSave, "function") <- attr(object, "function")
}
if (!identical(attr(outputToSave, "tags"), attr(object, "tags")))
stop("attributes on the cache object are not correct - 1")
if (!identical(attr(outputToSave, "call"), attr(object, "call")))
stop("attributes on the cache object are not correct - 2")
} else {
outputToSave <- object
}
# Some objects are removed from a simList
if (!is.null(preDigestByClass)) {
lsInObj <- ls(object@.xData, all.names = TRUE)
removedObjs <- unlist(preDigestByClass)[!(unlist(preDigestByClass) %in% lsInObj)]
attr(outputToSave, "removedObjs") <- removedObjs
}
outputToSave
})
#' Find `simList` in a nested list
#'
#' This is recursive, so it will find the all `simList`s even if they are deeply nested.
#'
#' @param x any object, used here only when it is a list with at least one
#' `simList` in it
#'
#' @rdname findSimList
.findSimList <- function(x) {
if (is.list(x)) {
out <- lapply(x, .findSimList)
out <- unlist(out, recursive = TRUE, use.names = FALSE) # get rid of NULL
if (is.null(out)) out <- list(NULL)
} else {
out <- inherits(x, "simList")
if (out) {
out <- x
} else {
out <- NULL
}
}
return(out)
}
if (!exists("objSize")) {
objSize <- function(x, quick, enclosingEnvs, .prevEnvs, ...) UseMethod("objSize")
}
#' Object size for `simList`
#'
#' Recursively, runs [reproducible::objSize()] on the `simList` environment,
#' so it estimates the correct size of functions stored there (e.g., with their enclosing
#' environments) plus, it adds all other "normal" elements of the `simList`, e.g.,
#' `objSize(completed(sim))`.
#' The output is structured into 2 elements: the `sim` environment and all its objects,
#' and the other slots in the `simList` (e.g., events, completed, modules, etc.).
#' The returned object also has an attribute, "total", which shows the total size.
#'
#' @importFrom reproducible objSize
#' @importFrom lobstr obj_size
#' @inheritParams reproducible::objSize
#'
#' @return an estimate of the size of the object, in bytes.
#'
#' @export
#' @examples
#' a <- simInit(objects = list(d = 1:10, b = 2:20))
#' objSize(a)
#' utils::object.size(a)
objSize.simList <- function(x, quick = TRUE, ...) {
total <- obj_size(x, quick = TRUE)
aa <- objSize(x@.xData, quick = quick, ...)
simSlots <- grep("^\\.envir$|^\\.xData$", slotNames(x), value = TRUE, invert = TRUE)
names(simSlots) <- simSlots
otherParts <- objSize(lapply(simSlots, function(slotNam) slot(x, slotNam)), quick = quick, ...)
if (!quick)
attr(total, "objSizes") <- list(sim = attr(aa, "objSize"),
other = attr(otherParts, "objSize"))
return(total)
}
#' Methods for `.wrap` and `.unwrap`
#'
#'
#' @return The same object as passed into the function, but dealt with so that it can be
#' saved to disk.
#'
#' @param conn A `DBIConnection` object, as returned by `dbConnect()`.
#' @param drv an object that inherits from `DBIDriver`, or an existing
#' `DBIConnection` object (in order to clone an existing connection).
#' @inheritParams reproducible::clearCache
#' @inheritParams reproducible::.wrap
#' @importFrom reproducible .wrap
#' @include simList-class.R
#' @export
#' @rdname dealWithClass
.wrap.simList <- function(obj, cachePath, preDigest, drv = getOption("reproducible.drv", NULL),
conn = getOption("reproducible.conn", NULL),
verbose = getOption("reproducible.verbose"),
outputObjects = NULL,
...) {
# Copy everything (including . and ._) that is NOT a main object -- objects are the potentially very large things
modules <- TRUE
if (!is.null(outputObjects)) {
grepForMods <- "^.mods"
isAModule <- grep(grepForMods, outputObjects)
modules <- gsub(paste0("^.mods", "\\$"), "", outputObjects[isAModule])
}
objTmp <- Copy(obj, objects = 2, modules = modules, drv = drv, conn = conn, verbose = verbose)
# Remove Par and mod active bindings --> these shouldn't be .wrap'd
modulesInSim <- ls(objTmp$.mods)
for (mo in modulesInSim) {
try(rm(list = c("Par", "mod"), envir = objTmp$.mods[[mo]]))
}
# Need to wrap the objects in e.g., .mods for e.g., mod objects that might be e.g., SpatVector
objTmp$.mods <- .wrap(objTmp$.mods, cachePath = cachePath, drv = drv, conn = conn, verbose = verbose)
# Deal with the potentially large things -- convert to list -- not a copy
obj2 <- as.list(obj, all.names = FALSE) # don't copy the . or ._ objects, already done
# Now the individual objects
out <- .wrap(obj2, cachePath = cachePath, outputObjects = outputObjects,
drv = drv, conn = conn, verbose = verbose, ...)
# for (objName in names(out)) obj[[objName]] <- NULL
list2env(out, envir = envir(objTmp))
objTmp
}
#' @export
#' @inheritParams reproducible::.unwrap
#' @importFrom reproducible .unwrap
#' @rdname dealWithClass
.unwrap.simList <- function(obj, cachePath, cacheId,
drv = getOption("reproducible.drv", NULL),
conn = getOption("reproducible.conn", NULL), ...) {
## the as.list doesn't get everything. But with a simList, this is OK; rest will stay
obj$.mods <- .unwrap(obj$.mods, cachePath = cachePath, cacheId = cacheId, drv = drv, conn = conn, ...)
objList <- as.list(obj) # don't overwrite everything, just the ones in the list part
outList <- .unwrap(objList, cachePath = cachePath, cacheId = cacheId,
drv = drv, conn = conn, ...)
list2env(outList, envir = envir(obj))
obj
}
#' Make `simList` correctly work with `memoise`
#'
#' Because of the environment slot, `simList` objects don't correctly
#' memoise a `simList`.
#' This method for `simList` converts the object to a `simList_` first.
#'
#' @inheritParams reproducible::makeMemoisable
#'
#' @return A `simList_` object or a `simList`, in the case of `unmakeMemoisable`.
#'
#' @export
#' @importFrom reproducible makeMemoisable
#' @include simList-class.R
#' @rdname makeMemoisable
#' @seealso [reproducible::makeMemoisable()]
makeMemoisable.simList <- function(x) {
as(x, "simList_")
}
#' @export
#' @importFrom reproducible unmakeMemoisable
#' @inheritParams reproducible::unmakeMemoisable
#' @rdname makeMemoisable
unmakeMemoisable.simList_ <- function(x) {
as(x, "simList")
}
#' Attach missing attributes from `x` to `y`
#'
#' This is an internal helper.
#'
#' @param x an object with attributes
#' @param y an object with attributes
#'
#' @importFrom data.table setattr
#' @keywords internal
#' @rdname keepAttrs
.keepAttrs <- function(x, y, omitAttrs = c(".envir", ".list", ".xData", ".Data")) {
keepAttrs <- setdiff(names(attributes(x)), names(attributes(y)))
keepAttrs <- setdiff(keepAttrs, omitAttrs)
keepAttrs <- keepAttrs[keepAttrs != "names"]
for (att in keepAttrs) {
setattr(y, att, attr(x, att))
if (!identical(attr(y, att), attr(x, att)))
stop("attributes on the cache object are not correct - 3")
#attr(y, att) <- attr(x, att)
}
return(y)
}
if (!isGeneric("clearCache")) {
setGeneric(
"clearCache",
function(x, userTags = character(), after = NULL, before = NULL,
ask = getOption("reproducible.ask"),
useCloud = FALSE,
cloudFolderID = NULL, ...) {
standardGeneric("clearCache")
}
)
}
#' `clearCache` for `simList` objects
#'
#' This will take the `cachePath(object)` and pass
#'
#' @inheritParams .wrap.simList
#'
#' @inheritParams reproducible::clearCache
#'
#' @return A `data.table` object showing the subset of items in the cache, located at `cachePath`
#' of the `sim` object, if `sim` is provided, or located in `cachePath`.
#' For `clearCache` (invoked for its side effect of clearing objects matching `userTags`, or those
#' between `after` or `before`), the returned `data.table` shows the removed items (invisibly).
#'
#' @export
#' @importFrom reproducible clearCache
#' @importMethodsFrom reproducible clearCache
#' @rdname clearCache
setMethod(
"clearCache",
signature = "simList",
definition = function(x, userTags, after = NULL, before = NULL, ask, useCloud = FALSE,
cloudFolderID = getOption("reproducible.cloudFolderID", NULL),
drv = getOption("reproducible.drv", NULL),
conn = getOption("reproducible.conn", NULL), ...) {
x <- x@paths$cachePath
clearCache(x = x, userTags = userTags, after = after, before = before,
ask = ask, useCloud = useCloud,
cloudFolderID = cloudFolderID,
...)
})
if (!isGeneric("showCache")) {
setGeneric("showCache", function(x, userTags = character(),
after = NULL, before = NULL, ...) {
standardGeneric("showCache")
})
}
#' `showCache` for `simList` objects
#'
#' @export
#' @importFrom reproducible showCache
#' @importMethodsFrom reproducible showCache
#' @rdname clearCache
setMethod(
"showCache",
signature = "simList",
definition = function(x, userTags, after = NULL, before = NULL, ...) {
x <- x@paths$cachePath
showCache(x = x, userTags = userTags, after = after, before = before, ...)
})
if (!isGeneric("keepCache")) {
setGeneric("keepCache", function(x, userTags = character(),
after = NULL, before = NULL, ...) {
standardGeneric("keepCache")
})
}
#' `keepCache` for `simList` objects
#'
#' @export
#' @importFrom reproducible keepCache
#' @importMethodsFrom reproducible keepCache
#' @rdname clearCache
setMethod(
"keepCache",
signature = "simList",
definition = function(x, userTags, after = NULL, before = NULL, ...) {
x <- x@paths$cachePath
keepCache(x = x, userTags = userTags, after = after, before = before,
...)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.