Nothing
################################################################################
#' Named list of core `SpaDES` modules
#'
#' Internal function.
#'
#' @return Returns a named list of the core modules.
#'
#' @author Alex Chubaty
#' @keywords internal
#' @name .coreModules
#' @rdname coreModules
.coreModules <- function() {
list(checkpoint = "checkpoint", save = "save", progress = "progress", load = "load",
restartR = "restartR")
}
#' @keywords internal
#' @include environment.R
.pkgEnv$.coreModules <- .coreModules() %>% unname()
#' @keywords internal
#' @include environment.R
.pkgEnv$.coreModulesMinusSave <- setdiff(.coreModules(), "save") %>% unname()
#' @keywords internal
.pkgEnv$.progressEmpty <- list(type = NA_character_, interval = NA_real_)
################################################################################
#' Blank (template) event list
#'
#' Internal function called from `spades`, returning an empty event list.
#'
#' Event lists are sorted (keyed) first by time, second by priority.
#' Each event is represented by a [data.table()] row consisting of:
#' \tabular{ll}{
#' `eventTime` \tab The time the event is to occur.\cr
#' `moduleName` \tab The module from which the event is taken.\cr
#' `eventType` \tab A character string for the programmer-defined event type.\cr
#' `eventPriority` \tab The priority given to the event. \cr
#' }
#'
#' @param eventTime The time the event is to occur.
#' @param moduleName The module from which the event is taken.
#' @param eventType A character string for the programmer-defined event type.
#' @param eventPriority The priority given to the event.
#'
#' @return Returns an empty event list.
#'
#' @author Alex Chubaty
#' @importFrom data.table data.table
#' @keywords internal
#' @name emptyEventList
#' @rdname emptyEventList
.emptyEventListDT <- data.table(eventTime = integer(0L), moduleName = character(0L),
eventType = character(0L), eventPriority = numeric(0L))
#' @importFrom data.table data.table
#' @keywords internal
#' @rdname emptyEventList
.singleEventListDT <- data.table(eventTime = integer(1L), moduleName = character(1L),
eventType = character(1L), eventPriority = numeric(1L))
#' @keywords internal
#' @rdname emptyEventList
setGeneric(".emptyEventList", function(eventTime, moduleName, eventType, eventPriority) {
standardGeneric(".emptyEventList")
})
#' @keywords internal
#' @rdname emptyEventList
#' @importFrom data.table set copy
setMethod(
".emptyEventList",
signature(eventTime = "numeric", moduleName = "character",
eventType = "character", eventPriority = "numeric"),
definition = function(eventTime, moduleName, eventType, eventPriority) {
# This is faster than direct call to new data.table
eeldt <- copy(.singleEventListDT)
set(eeldt, NULL, "eventTime", eventTime)
set(eeldt, NULL, "moduleName", moduleName)
set(eeldt, NULL, "eventType", eventType)
set(eeldt, NULL, "eventPriority", eventPriority)
eeldt # don't set key because it is set later when used
})
#' @keywords internal
#' @rdname emptyEventList
setMethod(
".emptyEventList",
signature(eventTime = "missing", moduleName = "missing",
eventType = "missing", eventPriority = "missing"),
definition = function() {
copy(.emptyEventListDT)
})
#' @keywords internal
#' @rdname emptyEventList
.emptyEventListCols <- colnames(.emptyEventList())
#' Default (empty) metadata
#'
#' Internal use only.
#' Default values to use for metadata elements when not otherwise supplied.
#'
#' @param x Not used. Should be missing.
#'
#' @author Alex Chubaty
#' @importFrom raster extent
#' @include simList-class.R
#' @keywords internal
#' @rdname emptyMetadata
setGeneric(".emptyMetadata", function(x) {
standardGeneric(".emptyMetadata")
})
#' @rdname emptyMetadata
setMethod(
".emptyMetadata",
signature(x = "missing"),
definition = function() {
out <- list(
name = moduleDefaults[["name"]],
description = moduleDefaults[["description"]],
keywords = moduleDefaults[["keywords"]],
childModules = moduleDefaults[["childModules"]],
authors = moduleDefaults[["authors"]],
version = moduleDefaults[["version"]],
spatialExtent = raster::extent(rep(NA_real_, 4)), ## match up with moduleDefaults
timeframe = as.POSIXlt(c(NA, NA)), ## match up with moduleDefaults
timeunit = moduleDefaults[["timeunit"]],
citation = moduleDefaults[["citation"]],
documentation = moduleDefaults[["documentation"]],
reqdPkgs = moduleDefaults[["reqdPkgs"]],
parameters = defineParameter(),
inputObjects = ._inputObjectsDF(),
outputObjects = ._outputObjectsDF()
)
return(out)
})
#' Find objects if passed as character strings
#'
#' Objects are passed into simList via `simInit` call or `objects(simList)`
#' assignment. This function is an internal helper to find those objects from their
#' environments by searching the call stack.
#'
#' @param objects A character vector of object names
#' @param functionCall A character string identifying the function name to be
#' searched in the call stack. Default is "simInit"
#'
#' @author Eliot McIntire
#' @importFrom reproducible .grepSysCalls
#' @keywords internal
#' @name findObjects
#' @rdname findObjects
.findObjects <- function(objects, functionCall = "simInit") {
scalls <- sys.calls()
grep1 <- .grepSysCalls(scalls, functionCall)
grep1 <- pmax(min(grep1[sapply(scalls[grep1], function(x) {
tryCatch(is(parse(text = x), "expression"), error = function(y) NA)
})], na.rm = TRUE) - 1, 1)
# Convert character strings to their objects
lapply(objects, function(x) get(x, envir = sys.frames()[[grep1]]))
}
#' Modify package order in search path
#'
#' Intended for internal use only. It modifies the search path (i.e., `search()`)
#' such that the packages required by the current module are placed first in the
#' search path. Note, several "core" packages are not touched; or more specifically,
#' they will remain in the search path, but may move down if packages are rearranged.
#' The current set of these core packages used by SpaDES can be found here:
#' `SpaDES.core:::.corePackages`
#'
#' @param pkgs The packages that are to be placed at the beginning of the search path,
#'
#' @param removeOthers Logical. If `TRUE`, then only the packages in
#' `c(pkgs, SpaDES.core:::.corePackages)`
#' will remain in the search path, i.e., all others will be removed.
#'
#' @param skipNamespacing Logical. If `FALSE`, then the running of an event in a module
#' will not trigger a rearrangement of the search() path. This will
#' generally speed up module simulations, but may create name
#' conflicts between packages.
#'
#' @return Nothing. This is used for its side effects, which are "severe".
#'
#' @author Eliot McIntire
#' @keywords internal
#' @rdname modifySearchPath
.modifySearchPath <- function(pkgs, removeOthers = FALSE,
skipNamespacing = !getOption("spades.switchPkgNamespaces")) {
if (!skipNamespacing) {
pkgs <- c("SpaDES.core", pkgs)
pkgs <- unlist(pkgs)[!(pkgs %in% .corePackages)]
pkgsWithPrefix <- paste0("package:", unlist(pkgs))
pkgPositions <- pmatch(pkgsWithPrefix, search())
# Find all packages that are not in the first sequence after .GlobalEnv
whNotAtTop <- !((seq_along(pkgPositions) + 1) %in% pkgPositions)
if (any(whNotAtTop)) {
whAdd <- which(is.na(pkgPositions))
if (removeOthers) {
pkgsToRm <- setdiff(search(), pkgsWithPrefix)
pkgsToRm <- grep(pkgsToRm, pattern = .corePackagesGrep, invert = TRUE, value = TRUE)
whRm <- seq_along(pkgsToRm)
} else {
whRm <- which(pkgPositions > min(which(whNotAtTop)))
pkgsToRm <- pkgs[whRm]
}
if (length(whRm) > 0) {
# i.e,. ones that need reordering
suppressWarnings(
lapply(unique(gsub(pkgsToRm, pattern = "package:", replacement = "")[whRm]), function(pack) {
try(detach(paste0("package:", pack), character.only = TRUE), silent = TRUE)
})
)
}
#if (!removeOthers) {
if (length(whAdd)) {
suppressMessages(
lapply(rev(pkgs[whAdd]), function(pack) {
try(attachNamespace(pack), silent = TRUE)
})
)
}
#}
}
}
}
#' @keywords internal
.corePackages <- c(".GlobalEnv","Autoloads","SpaDES.core","base","grDevices",
"rstudio","devtools_shims",
"methods","utils","graphics","datasets","stats", "testthat") # nolint
.corePackagesGrep <- paste(.corePackages, collapse = "|")
# .pkgEnv$corePackagesVec <- unlist(strsplit(.corePackagesGrep, split = "\\|"))
.corePackagesVec <- c(.corePackages[(1:2)],
paste0("package:", .corePackages[-(1:2)]))
#' tryCatch that keeps warnings, errors and value (result)
#'
#' This is from https://stackoverflow.com/a/24569739/3890027
#'
#' @keywords internal
#' @rdname tryCatch
.tryCatch <- function(expr) {
warn <- err <- NULL
value <- withCallingHandlers(
tryCatch(expr, error = function(e) {
err <<- e
NULL
}), warning = function(w) {
warn <<- w
invokeRestart("muffleWarning")
})
list(value = value, warning = warn, error = err)
}
#' All equal method for simLists
#'
#' This function removes a few attributes that are added internally
#' by SpaDES.core and are not relevant to the `all.equal`. One
#' key element removed is any time stamps, as these are guaranteed
#' to be different.
#'
#' @inheritParams base::all.equal
#' @export
#' @return
#' See [base::all.equal()]
all.equal.simList <- function(target, current, ...) {
attr(target, ".Cache")$newCache <- NULL
attr(current, ".Cache")$newCache <- NULL
attr(target, "removedObjs") <- NULL
attr(current, "removedObjs") <- NULL
if (length(target@completed))
completed(target) <- completed(target, times = FALSE)
if (length(current@completed))
completed(current) <- completed(current, times = FALSE)
# remove all objects starting with ._ in the simList@.xData
objNamesTarget <- ls(envir = envir(target), all.names = TRUE, pattern = "^._")
objNamesCurrent <- ls(envir = envir(current), all.names = TRUE, pattern = "^._")
objsTarget <- mget(objNamesTarget, envir = envir(target))
objsCurrent <- mget(objNamesCurrent, envir = envir(current))
on.exit({
list2env(objsTarget, envir = envir(target))
list2env(objsCurrent, envir = envir(current))
})
rm(list = objNamesTarget, envir = envir(target))
rm(list = objNamesCurrent, envir = envir(current))
# suppressWarnings(rm("._startClockTime", envir = envir(target)))
# suppressWarnings(rm("._startClockTime", envir = envir(current)))
# suppressWarnings(rm("._firstEventClockTime", envir = envir(target)))
# suppressWarnings(rm("._firstEventClockTime", envir = envir(current)))
# suppressWarnings(rm(".timestamp", envir = envir(target)))
# suppressWarnings(rm(".timestamp", envir = envir(current)))
all.equal.default(target, current, check.environment = FALSE)
}
needInstall <- function(pkg = "methods", minVersion = NULL,
messageStart = paste0(pkg, if (!is.null(minVersion)) paste0("(>=", minVersion, ")"), " is required. Try: ")) {
need <- FALSE
if (!requireNamespace(pkg, quietly = TRUE)) {
need <- TRUE
} else {
if (isTRUE(packageVersion(pkg) < minVersion))
need <- TRUE
}
if (need) {
stop(messageStart,
"install.packages('",pkg,"')")
}
}
isAbsolutePath <- getFromNamespace("isAbsolutePath", "reproducible")
.moduleNameNoUnderscore <- function(mod) gsub("_", ".", basename(mod))
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.