From ca0a296a63b61bd4d4fb417e83253e1bf4502426 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 19 Jun 2024 16:16:58 -0600 Subject: [PATCH 001/128] createDESCRIPTIONandDocs --- DESCRIPTION | 5 +- NAMESPACE | 1 + R/convertToPackage.R | 237 +++++++++++------------- R/createDESCRIPTIONandDocs.R | 310 ++++++++++++++++++++++++++++++++ man/createDESCRIPTIONandDocs.Rd | 145 +++++++++++++++ 5 files changed, 561 insertions(+), 137 deletions(-) create mode 100644 R/createDESCRIPTIONandDocs.R create mode 100644 man/createDESCRIPTIONandDocs.Rd diff --git a/DESCRIPTION b/DESCRIPTION index ab925215..8fe334d3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-06-12 -Version: 2.1.5.9000 +Date: 2024-06-14 +Version: 2.1.5.9002 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), @@ -102,6 +102,7 @@ Collate: 'code-checking.R' 'convertToPackage.R' 'copy.R' + 'createDESCRIPTIONandDocs.R' 'debugging.R' 'downloadData.R' 'simulation-parseModule.R' diff --git a/NAMESPACE b/NAMESPACE index acafbea7..192dc7cd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -84,6 +84,7 @@ export(conditionalEvents) export(convertTimeunit) export(convertToPackage) export(copyModule) +export(createDESCRIPTIONandDocs) export(createsOutput) export(current) export(currentModule) diff --git a/R/convertToPackage.R b/R/convertToPackage.R index 6a08f23c..a15edc08 100644 --- a/R/convertToPackage.R +++ b/R/convertToPackage.R @@ -152,6 +152,8 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" whDefModule <- which(defModule) whNotDefModule <- which(!defModule) + linesWithDefModule <- gpd[grep("defineModule", gpd$text) - 1, ][, c("line1", "line2")] + doEvent <- grepl(paste0("^doEvent.", module), aa) whDoEvent <- which(doEvent) whNoDoEvent <- which(!doEvent & !defModule) @@ -168,67 +170,67 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" linesWithRoxygen <- parseWithRoxygen[, "line1"] nextElement <- c(whNotDefModule[-1], Inf) - fileNames <- Map(element = whDefModule, nextElement = whNotDefModule[1], - function(element, nextElement) { - i <- 0 - fn <- filePath <- fnCh <- parseWithFn <- lineWithFn <- list() - for (elem in c(element, nextElement)) { - i <- i + 1 - if (is.infinite(elem)) { - lineWithFn[[i]] <- length(rlaa) + 1 - break - } - fn[[i]] <- aa[[elem]][[2]] - filePath[[i]] <- filenameFromFunction(packageFolderName, fn[[i]], "R") - fnCh[[i]] <- as.character(fn[[i]]) - gpdLines <- which(gpd$text == fnCh[[i]] & gpd$token == "SYMBOL") - if (length(gpdLines) > 1) - for (gl in gpdLines) { - line1 <- gpd[gl, "line1"] - isTop <- any(gpd[gpd[, "line1"] == line1, "parent"] == 0) - if (isTRUE(isTop)) { - gpdLines <- gl - break - } - } - parseWithFn[[i]] <- gpd[gpdLines, ] - lineWithFn[[i]] <- parseWithFn[[i]][, "line1"] - if (length(lineWithFn[[i]]) > 1) { - if (i == 1) { - lineWithFn[[1]] <- lineWithFn[[1]][1] - } else { - whAfterLine1 <- which(lineWithFn[[2]] > lineWithFn[[1]]) - if (length(whAfterLine1)) - lineWithFn[[2]] <- lineWithFn[[2]][whAfterLine1[1]] - } - } - } - fn <- filenameForMainFunctions(module, path) - cat("#' @export", file = fn, sep = "\n", append = FALSE) - cat(rlaa[lineWithFn[[2]]:length(rlaa)], - file = fn, sep = "\n", append = TRUE) - cat(rlaa[1:(lineWithFn[[2]] - 1)], file = mainModuleFile, - sep = "\n", append = FALSE) - }) - - otherStuffFn <- filenameFromFunction(packageFolderName, "other", "R") - cat(" -makeActiveBinding('mod', SpaDES.core:::activeModBindingFunction, ", - paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") - -makeActiveBinding('Par', SpaDES.core:::activeParBindingFunction, ", - paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") - -", file = otherStuffFn) - - if (length(linesWithRoxygen) > 0) { - message("There was some roxygen2 documentation that was not immediately above ", - "a function; it is being saved in R/documentation.R ... please confirm that ", - "the documentation is correct.") - cat(rlaa[linesWithRoxygen], file = filenameFromFunction(packageFolderName, "documentation", "R") - , sep = "\n", append = FALSE) - linesWithRoxygen <- character() - } + # fileNames <- Map(element = whDefModule, nextElement = whNotDefModule[1], + # function(element, nextElement) { + # i <- 0 + # fn <- filePath <- fnCh <- parseWithFn <- lineWithFn <- list() + # for (elem in c(element, nextElement)) { + # i <- i + 1 + # if (is.infinite(elem)) { + # lineWithFn[[i]] <- length(rlaa) + 1 + # break + # } + # fn[[i]] <- aa[[elem]][[2]] + # filePath[[i]] <- filenameFromFunction(packageFolderName, fn[[i]], "R") + # fnCh[[i]] <- as.character(fn[[i]]) + # gpdLines <- which(gpd$text == fnCh[[i]] & gpd$token == "SYMBOL") + # if (length(gpdLines) > 1) + # for (gl in gpdLines) { + # line1 <- gpd[gl, "line1"] + # isTop <- any(gpd[gpd[, "line1"] == line1, "parent"] == 0) + # if (isTRUE(isTop)) { + # gpdLines <- gl + # break + # } + # } + # parseWithFn[[i]] <- gpd[gpdLines, ] + # lineWithFn[[i]] <- parseWithFn[[i]][, "line1"] + # if (length(lineWithFn[[i]]) > 1) { + # if (i == 1) { + # lineWithFn[[1]] <- lineWithFn[[1]][1] + # } else { + # whAfterLine1 <- which(lineWithFn[[2]] > lineWithFn[[1]]) + # if (length(whAfterLine1)) + # lineWithFn[[2]] <- lineWithFn[[2]][whAfterLine1[1]] + # } + # } + # } + # fn <- filenameForMainFunctions(module, path) + # cat("#' @export", file = fn, sep = "\n", append = FALSE) + # cat(rlaa[lineWithFn[[2]]:length(rlaa)], + # file = fn, sep = "\n", append = TRUE) + # cat(rlaa[1:(lineWithFn[[2]] - 1)], file = mainModuleFile, + # sep = "\n", append = FALSE) + # }) + +# otherStuffFn <- filenameFromFunction(packageFolderName, "other", "R") +# cat(" +# makeActiveBinding('mod', SpaDES.core:::activeModBindingFunction, ", +# paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") +# +# makeActiveBinding('Par', SpaDES.core:::activeParBindingFunction, ", +# paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") +# +# ", file = otherStuffFn) + + # if (length(linesWithRoxygen) > 0) { + # message("There was some roxygen2 documentation that was not immediately above ", + # "a function; it is being saved in R/documentation.R ... please confirm that ", + # "the documentation is correct.") + # cat(rlaa[linesWithRoxygen], file = filenameFromFunction(packageFolderName, "documentation", "R") + # , sep = "\n", append = FALSE) + # linesWithRoxygen <- character() + # } filePathImportSpadesCore <- filenameFromFunction(packageFolderName, "imports", "R")# file.path(dirname(mainModuleFile), "R", "imports.R") @@ -236,85 +238,25 @@ makeActiveBinding('Par', SpaDES.core:::activeParBindingFunction, ", md <- aa[[whDefModule]][[3]] deps <- unlist(eval(md$reqdPkgs)) - dFile <- DESCRIPTIONfileFromModule(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, packageFolderName) - # d <- list() - # d$Package <- .moduleNameNoUnderscore(module) - # d$Type <- "Package" - # - # d$Title <- md$name - # d$Description <- md$description - # d$Version <- as.character(eval(md$version[[2]])) - # d$Date <- Sys.Date() - # d$Authors <- md$authors - # d$Authors <- c(paste0(" ", format(d$Authors)[1]), format(d$Authors)[-1]) - # - # - # hasSC <- grepl("SpaDES.core", deps) - # if (all(!hasSC)) - # deps <- c("SpaDES.core", deps) - # - # d$Imports <- Require::extractPkgName(deps) - # versionNumb <- Require::extractVersionNumber(deps) - # hasVersionNumb <- !is.na(versionNumb) - # inequality <- paste0("(", gsub("(.+)\\((.+)\\)", "\\2", deps[hasVersionNumb]), ")") - # missingSpace <- !grepl("[[:space:]]", inequality) - # if (any(missingSpace)) - # inequality[missingSpace] <- gsub("([=><]+)", "\\1 ", inequality[missingSpace]) - # - # namespaceImports <- d$Imports - # # Create "import all" for each of the packages, unless it is already in an @importFrom - # if (hasNamespaceFile) { - # nsTxt <- readLines(NAMESPACEFile) - # hasImportFrom <- grepl("importFrom", nsTxt) - # if (any(hasImportFrom)) { - # pkgsNotNeeded <- unique(gsub(".+\\((.+)\\,.+\\)", "\\1", nsTxt[hasImportFrom])) - # namespaceImports <- grep(paste(pkgsNotNeeded, collapse = "|"), - # namespaceImports, invert = TRUE, value = TRUE) - # } - # } - # - # cat(paste0("#' @import ", namespaceImports, "\nNULL\n"), sep = "\n", - # file = filePathImportSpadesCore, fill = TRUE) - # - # d$Imports[hasVersionNumb] <- paste(d$Imports[hasVersionNumb], inequality) - # - # dFile <- filenameFromFunction(packageFolderName, "DESCRIPTION", fileExt = "") - # - # cat(paste("Package:", d$Package), file = dFile, sep = "\n") - # cat(paste("Type:", d$Type), file = dFile, sep = "\n", append = TRUE) - # cat(paste("Title:", d$Title), file = dFile, sep = "\n", append = TRUE) - # cat(paste("Version:", d$Version), file = dFile, sep = "\n", append = TRUE) - # cat(paste("Description:", paste(d$Description, collapse = " ")), file = dFile, sep = "\n", append = TRUE) - # cat(paste("Date:", d$Date), file = dFile, sep = "\n", append = TRUE) - # cat(c("Authors@R: ", format(d$Authors)), file = dFile, sep = "\n", append = TRUE) - # - # if (length(d$Imports)) - # cat(c("Imports:", paste(" ", d$Imports, collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) - # - # Suggests <- c('knitr', 'rmarkdown') - # cat(c("Suggests:", paste(" ", Suggests, collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) - # - # cat("Encoding: UTF-8", sep = "\n", file = dFile, append = TRUE) - # cat("License: GPL-3", sep = "\n", file = dFile, append = TRUE) - # cat("VignetteBuilder: knitr, rmarkdown", sep = "\n", file = dFile, append = TRUE) - # cat("ByteCompile: yes", sep = "\n", file = dFile, append = TRUE) - # cat("Roxygen: list(markdown = TRUE)", sep = "\n", file = dFile, append = TRUE) - # - # - # message("New/updated DESCRIPTION file is: ", dFile) if (isTRUE(buildDocuments)) { message("Building documentation") m <- packageFolderName + tmpSrcForDoc <- "R/tmp.R" + cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) + on.exit(unlink(tmpSrcForDoc)) roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... pkgload::dev_topic_index_reset(m) pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting } RBuildIgnoreFile <- filenameFromFunction(packageFolderName, "", fileExt = ".Rbuildignore") - cat("^.*\\.Rproj$ + + startCat <- readLines(RBuildIgnoreFile) + + rbi <- paste("^.*\\.Rproj$ ^\\.Rproj\\.user$ ^_pkgdown\\.yml$ .*\\.tar\\.gz$ @@ -324,6 +266,8 @@ makeActiveBinding('Par', SpaDES.core:::activeParBindingFunction, ", CONTRIBUTING\\.md cran-comments\\.md ^docs$ +citation.* +figures ^LICENSE$ vignettes/.*_cache$ vignettes/.*\\.log$ @@ -335,9 +279,13 @@ vignettes/.*\\.log$ ^data/* ^.git ^.gitignore -^.gitmodules - ", sep = "\n", - file = RBuildIgnoreFile, fill = TRUE) +^.gitmodules", sep = "\n") + rbi <- strsplit(rbi, split = "\n")[[1]] + + modFiles <- c(paste0(module, ".*"), ".*zip") + + rbi <- unique(c(startCat, rbi, modFiles)) + cat(rbi, file = RBuildIgnoreFile, fill = TRUE, sep = "\n") return(invisible()) } @@ -372,6 +320,9 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP d$Imports <- Require::extractPkgName(deps) versionNumb <- Require::extractVersionNumber(deps) + needRemotes <- which(!is.na(Require::extractPkgGitHub(deps))) + d$Remotes <- Require::trimVersionNumber(deps[needRemotes]) + hasVersionNumb <- !is.na(versionNumb) inequality <- paste0("(", gsub("(.+)\\((.+)\\)", "\\2", deps[hasVersionNumb]), ")") missingSpace <- !grepl("[[:space:]]", inequality) @@ -396,6 +347,7 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP d$Imports[hasVersionNumb] <- paste(d$Imports[hasVersionNumb], inequality) dFile <- filenameFromFunction(packageFolderName, "DESCRIPTION", fileExt = "") + origDESCtxt <- read.dcf(dFile) cat(paste("Package:", d$Package), file = dFile, sep = "\n") cat(paste("Type:", d$Type), file = dFile, sep = "\n", append = TRUE) @@ -405,17 +357,32 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP cat(paste("Date:", d$Date), file = dFile, sep = "\n", append = TRUE) cat(c("Authors@R: ", format(d$Authors)), file = dFile, sep = "\n", append = TRUE) - if (length(d$Imports)) - cat(c("Imports:", paste(" ", d$Imports, collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) + mergeField(origDESCtxt = origDESCtxt, field = d$Imports, fieldName = "Imports", dFile) - Suggests <- c('knitr', 'rmarkdown') - cat(c("Suggests:", paste(" ", Suggests, collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) + suggs <- c('knitr', 'rmarkdown', 'testthat', 'withr', 'roxygen2') + mergeField(origDESCtxt = origDESCtxt, field = suggs, fieldName = "Suggests", dFile) + + mergeField(origDESCtxt = origDESCtxt, field = d$Remotes, fieldName = "Remotes", dFile) cat("Encoding: UTF-8", sep = "\n", file = dFile, append = TRUE) cat("License: GPL-3", sep = "\n", file = dFile, append = TRUE) cat("VignetteBuilder: knitr, rmarkdown", sep = "\n", file = dFile, append = TRUE) cat("ByteCompile: yes", sep = "\n", file = dFile, append = TRUE) cat("Roxygen: list(markdown = TRUE)", sep = "\n", file = dFile, append = TRUE) + cat(paste0("RoxygenNote: ", as.character(packageVersion("roxygen2"))), sep = "\n", file = dFile, append = TRUE) + + message("New/updated DESCRIPTION file is: ", dFile) return(dFile) } + +mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { + fieldVals <- character() + if (fieldName %in% colnames(origDESCtxt)) + fieldVals <- strsplit(origDESCtxt[, fieldName], split = ",+\n")[[1]] + if (length(field)) { + field <- Require:::trimRedundancies(unique(c(field, fieldVals))) + } + cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), + sep = "\n", file = dFile, append = TRUE) +} diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R new file mode 100644 index 00000000..149699bd --- /dev/null +++ b/R/createDESCRIPTIONandDocs.R @@ -0,0 +1,310 @@ +#' Convert standard module code into an R package +#' +#' *EXPERIMENTAL -- USE WITH CAUTION*. This function will create a `DESCRIPTION` +#' file if one does not exist, based on the module metadata. If one exists, it will +#' update it with any additional information: **it will not remove packages that are +#' removed from the metadata**. It will create, if one does not +#' exist, or update a `.Rbuildignore` file. If `importAll = TRUE` It will create a file named `R/imports.R`, +#' which will import all functions. This function will make no changes to +#' any existing source file of a SpaDES.module. If `buildDocumentation = TRUE`, +#' it will build documentation `.Rd` files from `roxygen2` tags. +#' +#' This function does not install anything (e.g., `devtools::install`). After +#' running this function, `simInit` will automatically detect that this is now +#' a package and will load the functions (via `pkgload::load_all`) from the source files. +#' This will have the effect that it emulates the "non-package" behaviour of a +#' SpaDES module exactly. After running this function, current tests show no +#' impact on module behaviour, other than event-level and module-level Caching will show +#' changes and will be rerun. Function-level Caching appears unaffected. +#' In other words, this should cause no changes to running the module code via +#' `simInit` and `spades`. +#' +#' This function will create +#' and fill a minimal `DESCRIPTION` file. This will leave the `defineModule` +#' function call as the only code in the main module file. This `defineModule` +#' and a `doEvent.xxx` are the only 2 elements that are required for an R +#' package to be considered a SpaDES module. With these changes, the module should +#' still function normally, but will be able to act like an +#' R package, e.g., for writing function documentation with `roxygen2`, +#' using the `testthat` infrastructure, etc. +#' +#' This function is intended to be run once for a module that was created using +#' the "standard" SpaDES module structure (e.g., from a `newModule` call). There +#' is currently no way to "revert" the changes from R (though it can be done using +#' version control utilities if all files are under version control, e.g., GitHub). +#' Currently `SpaDES.core` identifies a module as being a package if it has +#' a `DESCRIPTION` file, or if it has been installed to the `.libPaths()` +#' e.g., via `devtools::install` or the like. So one can simply remove the +#' package from `.libPaths` and delete the `DESCRIPTION` file and +#' `SpaDES.core` will treat it as a normal module. +#' +#' @section Reverting: +#' Currently, this is not a reversible process. We recommend trying one module at +#' a time, running your code. If all seems to work, then great. Commit the changes. +#' If things don't seem to work, then revert the changes and continue on as before. +#' Ideally, file a bug report on the `SpaDES.core` GitHub.com pages. +#' +#' Currently +#' @return Invoked for its side effects. There will be a new or modified +#' `DESCRIPTION` file in the root directory of the module. Any functions that +#' were in the main module script (i.e., the .R file whose filename is the name of +#' the module and is in the root directory of the module) will be moved to individual +#' `.R` files in the `R` folder. Any function with a dot prefix will have the +#' dot removed in its respective filename, but the function name is unaffected. +#' +#' Currently, `SpaDES.core` does not install the package under any circumstances. +#' It will load it via `pkgdown::load_all`, and optionally (`option("spades.moduleDocument" = TRUE)`) +#' build documentation via `roxygen2::roxygenise` within the `simInit` call. +#' This means that any modifications to source code +#' will be read in during the `simInit` call, as is the practice when a module +#' is not a package. +#' +#' @section Exported functions: +#' +#' The only function that will be exported by default is the `doEvent.xxx`, +#' where `xxx` is the module name. If any other module is to be exported, it must +#' be explicitly exported with e.g., `@export`, and then building the `NAMESPACE` +#' file, e.g., via `devtools::document(moduleRootPath)`. NOTE: as long as all +#' the functions are being used inside each other, and they all can be traced back +#' to a call in `doEvent.xxx`, then there is no need to export anything else. +#' +#' @section DESCRIPTION: +#' +#' The `DESCRIPTION` file that is created (destroying any existing `DESCRIPTION` +#' file) with this function will have +#' several elements that a user may wish to change. Notably, all packages that were +#' in `reqdPkgs` in the SpaDES module metadata will be in the `Imports` +#' section of the `DESCRIPTION`. To accommodate the need to see these functions, +#' a new R script, `imports.R` will be created with `@import` for each +#' package in `reqdPkgs` of the module metadata. However, if a module already has used +#' `@importFrom` for importing a function from a package, then the generic +#' `@import` will be omitted for that (those) package(s). +#' So, a user should likely follow standard R package +#' best practices and use `@importFrom` to identify the specific functions that +#' are required within external packages, thereby limiting function name collisions +#' (and the warnings that come with them). +#' +#' Other elements of a standard `DESCRIPTION` file that will be missing or possibly +#' inappropriately short are `Title`, `Description`, `URL`, +#' `BugReports`. +#' +#' @section Installing as a package: +#' +#' There is no need to "install" the source code as a package because `simInit` +#' will load it on the fly. But, there may be reasons to install it, e.g., to have +#' access to individual functions, help manual, running tests etc. To do this, +#' simply use the `devtools::install(pathToModuleRoot)`. Even if it is installed, +#' `simInit` will nevertheless run `pkgload::load_all` to ensure the +#' `spades` call will be using the current source code. +#' +#' @param module Character string of module name, without path +#' +#' @param path Character string of `modulePath`. Defaults to `getOption("spades.modulePath")`. +#' +#' @param buildDocuments A logical. If `TRUE`, the default, then the documentation +#' will be built, if any exists, using `roxygen2::roxygenise`. +#' @param importAll A logical. If `TRUE`, then every package named in `reqdPkgs` will +#' have an `@importFrom `, meaning **every** function from every package will +#' be imported. If `FALSE`, then only functions explicitly imported using +#' `@importFrom ` will be imported. +#' +#' @return invoked for the side effect of creating DESCRIPTION file, a `.Rbuildingore` +#' file and possibly building documentatation from roxygen tags. +#' +#' @export +#' @examples +#' if (requireNamespace("ggplot2") && requireNamespace("pkgload") ) { +#' tmpdir <- tempdir2() +#' newModule("test", tmpdir, open = FALSE) +#' createDESCRIPTIONandDocs("test", path = tmpdir) +#' } +createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.modulePath"), + importAll = TRUE, + buildDocuments = TRUE) { + stopifnot( + requireNamespace("pkgload", quietly = TRUE), + requireNamespace("roxygen2", quietly = TRUE) + ) + + mainModuleFile <- file.path(path, unlist(module), paste0(unlist(module), ".R")) + packageFolderName <- dirname(mainModuleFile) + aa <- parse(mainModuleFile, keep.source = TRUE) + rlaa <- readLines(mainModuleFile) + gpd <- getParseData(aa) + + defModule <- grepl("^defineModule", aa) + whDefModule <- which(defModule) + whNotDefModule <- which(!defModule) + + linesWithDefModule <- gpd[grep("defineModule", gpd$text) - 1, ][, c("line1", "line2")] + + doEvent <- grepl(paste0("^doEvent.", module), aa) + whDoEvent <- which(doEvent) + whNoDoEvent <- which(!doEvent & !defModule) + + # file.copy(mainModuleFile, file.path(path, unlist(module), "R", paste0(unlist(module), ".R"))) + + NAMESPACEFile <- filenameFromFunction(packageFolderName, "NAMESPACE", fileExt = "") + hasNamespaceFile <- file.exists(NAMESPACEFile) + + RsubFolder <- file.path(packageFolderName, "R") + checkPath(RsubFolder, create = TRUE) + + parseWithRoxygen <- gpd[grep("#'", gpd$text), ] + linesWithRoxygen <- parseWithRoxygen[, "line1"] + nextElement <- c(whNotDefModule[-1], Inf) + + + filePathImportSpadesCore <- filenameFromFunction(packageFolderName, "imports", "R")# file.path(dirname(mainModuleFile), "R", "imports.R") + + md <- aa[[whDefModule]][[3]] + deps <- unlist(eval(md$reqdPkgs)) + + dFile <- DESCRIPTIONfileFromModule(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, + packageFolderName) + + if (isTRUE(buildDocuments)) { + message("Building documentation") + m <- packageFolderName + tmpSrcForDoc <- "R/tmp.R" + cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) + on.exit(unlink(tmpSrcForDoc)) + roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... + pkgload::dev_topic_index_reset(m) + pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting + } + + RBuildIgnoreFile <- filenameFromFunction(packageFolderName, "", fileExt = ".Rbuildignore") + + startCat <- readLines(RBuildIgnoreFile) + + rbi <- paste("^.*\\.Rproj$ +^\\.Rproj\\.user$ +^_pkgdown\\.yml$ +.*\\.tar\\.gz$ +.*\\.toc$ +.*\\.zip$ +^\\.lintr$ +CONTRIBUTING\\.md +cran-comments\\.md +^docs$ +citation.* +figures +^LICENSE$ +vignettes/.*_cache$ +vignettes/.*\\.log$ +^\\.httr-oauth$ +^revdep$ +^\\.github$ +^codecov\\.yml$ +^CRAN-RELEASE$ +^data/* +^.git +^.gitignore +^.gitmodules", sep = "\n") + rbi <- strsplit(rbi, split = "\n")[[1]] + + modFiles <- c(paste0(module, ".*"), ".*zip") + + rbi <- unique(c(startCat, rbi, modFiles)) + cat(rbi, file = RBuildIgnoreFile, fill = TRUE, sep = "\n") + + return(invisible()) +} + +filenameFromFunction <- function(packageFolderName, fn = "", subFolder = "", fileExt = ".R") { + normPath(file.path(packageFolderName, subFolder, paste0(gsub("\\.", "", fn), fileExt))) +} + +filenameForMainFunctions <- function(module, modulePath = ".") + normPath(file.path(modulePath, unlist(module), "R", paste0(unlist(basename(module)), "Fns.R"))) + + + + +DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, + packageFolderName) { + d <- list() + d$Package <- .moduleNameNoUnderscore(module) + d$Type <- "Package" + + d$Title <- md$name + d$Description <- md$description + d$Version <- as.character(eval(md$version[[2]])) + d$Date <- Sys.Date() + d$Authors <- md$authors + d$Authors <- c(paste0(" ", format(d$Authors)[1]), format(d$Authors)[-1]) + + + hasSC <- grepl("SpaDES.core", deps) + if (all(!hasSC)) + deps <- c("SpaDES.core", deps) + + d$Imports <- Require::extractPkgName(deps) + versionNumb <- Require::extractVersionNumber(deps) + needRemotes <- which(!is.na(Require::extractPkgGitHub(deps))) + d$Remotes <- Require::trimVersionNumber(deps[needRemotes]) + + hasVersionNumb <- !is.na(versionNumb) + inequality <- paste0("(", gsub("(.+)\\((.+)\\)", "\\2", deps[hasVersionNumb]), ")") + missingSpace <- !grepl("[[:space:]]", inequality) + if (any(missingSpace)) + inequality[missingSpace] <- gsub("([=><]+)", "\\1 ", inequality[missingSpace]) + + namespaceImports <- d$Imports + # Create "import all" for each of the packages, unless it is already in an @importFrom + if (hasNamespaceFile) { + nsTxt <- readLines(NAMESPACEFile) + hasImportFrom <- grepl("importFrom", nsTxt) + if (any(hasImportFrom)) { + pkgsNotNeeded <- unique(gsub(".+\\((.+)\\,.+\\)", "\\1", nsTxt[hasImportFrom])) + namespaceImports <- grep(paste(pkgsNotNeeded, collapse = "|"), + namespaceImports, invert = TRUE, value = TRUE) + } + } + + cat(paste0("#' @import ", namespaceImports, "\nNULL\n"), sep = "\n", + file = filePathImportSpadesCore, fill = TRUE) + + d$Imports[hasVersionNumb] <- paste(d$Imports[hasVersionNumb], inequality) + + dFile <- filenameFromFunction(packageFolderName, "DESCRIPTION", fileExt = "") + origDESCtxt <- read.dcf(dFile) + + cat(paste("Package:", d$Package), file = dFile, sep = "\n") + cat(paste("Type:", d$Type), file = dFile, sep = "\n", append = TRUE) + cat(paste("Title:", d$Title), file = dFile, sep = "\n", append = TRUE) + cat(paste("Version:", d$Version), file = dFile, sep = "\n", append = TRUE) + cat(paste("Description:", paste(d$Description, collapse = " ")), file = dFile, sep = "\n", append = TRUE) + cat(paste("Date:", d$Date), file = dFile, sep = "\n", append = TRUE) + cat(c("Authors@R: ", format(d$Authors)), file = dFile, sep = "\n", append = TRUE) + + mergeField(origDESCtxt = origDESCtxt, field = d$Imports, fieldName = "Imports", dFile) + + suggs <- c('knitr', 'rmarkdown', 'testthat', 'withr', 'roxygen2') + mergeField(origDESCtxt = origDESCtxt, field = suggs, fieldName = "Suggests", dFile) + + mergeField(origDESCtxt = origDESCtxt, field = d$Remotes, fieldName = "Remotes", dFile) + + cat("Encoding: UTF-8", sep = "\n", file = dFile, append = TRUE) + cat("License: GPL-3", sep = "\n", file = dFile, append = TRUE) + cat("VignetteBuilder: knitr, rmarkdown", sep = "\n", file = dFile, append = TRUE) + cat("ByteCompile: yes", sep = "\n", file = dFile, append = TRUE) + cat("Roxygen: list(markdown = TRUE)", sep = "\n", file = dFile, append = TRUE) + cat(paste0("RoxygenNote: ", as.character(packageVersion("roxygen2"))), sep = "\n", file = dFile, append = TRUE) + + + message("New/updated DESCRIPTION file is: ", dFile) + return(dFile) +} + +mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { + fieldVals <- character() + if (fieldName %in% colnames(origDESCtxt)) + fieldVals <- strsplit(origDESCtxt[, fieldName], split = ",+\n")[[1]] + if (length(field)) { + field <- Require:::trimRedundancies(unique(c(field, fieldVals))) + } + cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), + sep = "\n", file = dFile, append = TRUE) +} diff --git a/man/createDESCRIPTIONandDocs.Rd b/man/createDESCRIPTIONandDocs.Rd new file mode 100644 index 00000000..4cf130c5 --- /dev/null +++ b/man/createDESCRIPTIONandDocs.Rd @@ -0,0 +1,145 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/createDESCRIPTIONandDocs.R +\name{createDESCRIPTIONandDocs} +\alias{createDESCRIPTIONandDocs} +\title{Convert standard module code into an R package} +\usage{ +createDESCRIPTIONandDocs( + module = NULL, + path = getOption("spades.modulePath"), + importAll = TRUE, + buildDocuments = TRUE +) +} +\arguments{ +\item{module}{Character string of module name, without path} + +\item{path}{Character string of \code{modulePath}. Defaults to \code{getOption("spades.modulePath")}.} + +\item{importAll}{A logical. If \code{TRUE}, then every package named in \code{reqdPkgs} will +have an \verb{@importFrom }, meaning \strong{every} function from every package will +be imported. If \code{FALSE}, then only functions explicitly imported using +\verb{@importFrom } will be imported.} + +\item{buildDocuments}{A logical. If \code{TRUE}, the default, then the documentation +will be built, if any exists, using \code{roxygen2::roxygenise}.} +} +\value{ +Invoked for its side effects. There will be a new or modified +\code{DESCRIPTION} file in the root directory of the module. Any functions that +were in the main module script (i.e., the .R file whose filename is the name of +the module and is in the root directory of the module) will be moved to individual +\code{.R} files in the \code{R} folder. Any function with a dot prefix will have the +dot removed in its respective filename, but the function name is unaffected. + +Currently, \code{SpaDES.core} does not install the package under any circumstances. +It will load it via \code{pkgdown::load_all}, and optionally (\code{option("spades.moduleDocument" = TRUE)}) +build documentation via \code{roxygen2::roxygenise} within the \code{simInit} call. +This means that any modifications to source code +will be read in during the \code{simInit} call, as is the practice when a module +is not a package. + +invoked for the side effect of creating DESCRIPTION file, a \code{.Rbuildingore} +file and possibly building documentatation from roxygen tags. +} +\description{ +\emph{EXPERIMENTAL -- USE WITH CAUTION}. This function will create a \code{DESCRIPTION} +file if one does not exist, based on the module metadata. If one exists, it will +update it with any additional information: \strong{it will not remove packages that are +removed from the metadata}. It will create, if one does not +exist, or update a \code{.Rbuildignore} file. If \code{importAll = TRUE} It will create a file named \code{R/imports.R}, +which will import all functions. This function will make no changes to +any existing source file of a SpaDES.module. If \code{buildDocumentation = TRUE}, +it will build documentation \code{.Rd} files from \code{roxygen2} tags. +} +\details{ +This function does not install anything (e.g., \code{devtools::install}). After +running this function, \code{simInit} will automatically detect that this is now +a package and will load the functions (via \code{pkgload::load_all}) from the source files. +This will have the effect that it emulates the "non-package" behaviour of a +SpaDES module exactly. After running this function, current tests show no +impact on module behaviour, other than event-level and module-level Caching will show +changes and will be rerun. Function-level Caching appears unaffected. +In other words, this should cause no changes to running the module code via +\code{simInit} and \code{spades}. + +This function will create +and fill a minimal \code{DESCRIPTION} file. This will leave the \code{defineModule} +function call as the only code in the main module file. This \code{defineModule} +and a \code{doEvent.xxx} are the only 2 elements that are required for an R +package to be considered a SpaDES module. With these changes, the module should +still function normally, but will be able to act like an +R package, e.g., for writing function documentation with \code{roxygen2}, +using the \code{testthat} infrastructure, etc. + +This function is intended to be run once for a module that was created using +the "standard" SpaDES module structure (e.g., from a \code{newModule} call). There +is currently no way to "revert" the changes from R (though it can be done using +version control utilities if all files are under version control, e.g., GitHub). +Currently \code{SpaDES.core} identifies a module as being a package if it has +a \code{DESCRIPTION} file, or if it has been installed to the \code{.libPaths()} +e.g., via \code{devtools::install} or the like. So one can simply remove the +package from \code{.libPaths} and delete the \code{DESCRIPTION} file and +\code{SpaDES.core} will treat it as a normal module. +} +\section{Reverting}{ + +Currently, this is not a reversible process. We recommend trying one module at +a time, running your code. If all seems to work, then great. Commit the changes. +If things don't seem to work, then revert the changes and continue on as before. +Ideally, file a bug report on the \code{SpaDES.core} GitHub.com pages. + +Currently +} + +\section{Exported functions}{ + + +The only function that will be exported by default is the \code{doEvent.xxx}, +where \code{xxx} is the module name. If any other module is to be exported, it must +be explicitly exported with e.g., \verb{@export}, and then building the \code{NAMESPACE} +file, e.g., via \code{devtools::document(moduleRootPath)}. NOTE: as long as all +the functions are being used inside each other, and they all can be traced back +to a call in \code{doEvent.xxx}, then there is no need to export anything else. +} + +\section{DESCRIPTION}{ + + +The \code{DESCRIPTION} file that is created (destroying any existing \code{DESCRIPTION} +file) with this function will have +several elements that a user may wish to change. Notably, all packages that were +in \code{reqdPkgs} in the SpaDES module metadata will be in the \code{Imports} +section of the \code{DESCRIPTION}. To accommodate the need to see these functions, +a new R script, \code{imports.R} will be created with \verb{@import} for each +package in \code{reqdPkgs} of the module metadata. However, if a module already has used +\verb{@importFrom} for importing a function from a package, then the generic +\verb{@import} will be omitted for that (those) package(s). +So, a user should likely follow standard R package +best practices and use \verb{@importFrom} to identify the specific functions that +are required within external packages, thereby limiting function name collisions +(and the warnings that come with them). + +Other elements of a standard \code{DESCRIPTION} file that will be missing or possibly +inappropriately short are \code{Title}, \code{Description}, \code{URL}, +\code{BugReports}. +} + +\section{Installing as a package}{ + + +There is no need to "install" the source code as a package because \code{simInit} +will load it on the fly. But, there may be reasons to install it, e.g., to have +access to individual functions, help manual, running tests etc. To do this, +simply use the \code{devtools::install(pathToModuleRoot)}. Even if it is installed, +\code{simInit} will nevertheless run \code{pkgload::load_all} to ensure the +\code{spades} call will be using the current source code. +} + +\examples{ +if (requireNamespace("ggplot2") && requireNamespace("pkgload") ) { + tmpdir <- tempdir2() + newModule("test", tmpdir, open = FALSE) + createDESCRIPTIONandDocs("test", path = tmpdir) +} +} From b0dfdb1e3b9671b20dbac81319b0a2bae4a50398 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 21 Jun 2024 19:01:20 -0600 Subject: [PATCH 002/128] bugfix when debug = 2 ... spades call errors with Error in class(xx) <- cl --- R/simulation-spades.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 04d2050c..5d078ad6 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1110,7 +1110,8 @@ setMethod( prevStart <- get(as.character(existingCompleted[1]), envir = sim@completed) # prevEnd <- get(as.character(existingCompleted[length(existingCompleted)]), envir = sim@completed) if (length(.grepSysCalls(sys.calls(), "restartSpades")) == 0 && - length(sim@.xData$._ranInitDuringSimInit) == 0) { # don't crop off completed events if Init(s) ran during simInit + length(sim@.xData$._ranInitDuringSimInit) == 0 && + prevStart$eventType != ".inputObjects") { # don't crop off completed events if Init(s) ran during simInit prevEvUnit <- attr(prevStart[["eventTime"]], "unit") stTime <- start(sim, unit = prevEvUnit) if (stTime <= prevStart[["eventTime"]] && (time(sim, unit = prevEvUnit) == stTime)) From 96c5eab67d60afc77da24de751bdcc1f217ca47a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 24 Jun 2024 20:24:51 -0700 Subject: [PATCH 003/128] fixes for test-mod --- R/convertToPackage.R | 60 ++++++++++++++++++++------- R/createDESCRIPTIONandDocs.R | 11 +++-- R/simulation-parseModule.R | 1 + tests/testthat/helper-initTests.R | 8 ++-- tests/testthat/test-mod.R | 48 ++++++++++++++------- tests/testthat/test-module-template.R | 3 +- 6 files changed, 94 insertions(+), 37 deletions(-) diff --git a/R/convertToPackage.R b/R/convertToPackage.R index a15edc08..38b5755c 100644 --- a/R/convertToPackage.R +++ b/R/convertToPackage.R @@ -131,8 +131,6 @@ #' tmpdir <- tempdir2() #' newModule("test", tmpdir, open = FALSE) #' convertToPackage("test", path = tmpdir) -#' pkgload::load_all(file.path(tmpdir, "test")) -#' pkgload::unload("test") #' } #' convertToPackage <- function(module = NULL, path = getOption("spades.modulePath"), @@ -145,9 +143,10 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" mainModuleFile <- file.path(path, unlist(module), paste0(unlist(module), ".R")) packageFolderName <- dirname(mainModuleFile) aa <- parse(mainModuleFile, keep.source = TRUE) - rlaa <- readLines(mainModuleFile) gpd <- getParseData(aa) + rlaa <- readLines(mainModuleFile) + defModule <- grepl("^defineModule", aa) whDefModule <- which(defModule) whNotDefModule <- which(!defModule) @@ -238,23 +237,25 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" md <- aa[[whDefModule]][[3]] deps <- unlist(eval(md$reqdPkgs)) - dFile <- DESCRIPTIONfileFromModule(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, - packageFolderName) + dFile <- DESCRIPTIONfileFromModule( + module, md, deps, hasNamespaceFile, NAMESPACEFile, + filePathImportSpadesCore, packageFolderName) if (isTRUE(buildDocuments)) { - message("Building documentation") - m <- packageFolderName - tmpSrcForDoc <- "R/tmp.R" - cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) - on.exit(unlink(tmpSrcForDoc)) - roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... - pkgload::dev_topic_index_reset(m) - pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting + documentModule(packageFolderName, gpd, linesWithDefModule) + # message("Building documentation") + # m <- packageFolderName + # tmpSrcForDoc <- "R/tmp.R" + # cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) + # on.exit(unlink(tmpSrcForDoc)) + # roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... + # pkgload::dev_topic_index_reset(m) + # pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting } RBuildIgnoreFile <- filenameFromFunction(packageFolderName, "", fileExt = ".Rbuildignore") - startCat <- readLines(RBuildIgnoreFile) + startCat <- if (file.exists(RBuildIgnoreFile)) readLines(RBuildIgnoreFile) else character() rbi <- paste("^.*\\.Rproj$ ^\\.Rproj\\.user$ @@ -386,3 +387,34 @@ mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) } + + + +documentModule <- function(packageFolderName, gpd, linesWithDefModule) { + message("Building documentation") + m <- packageFolderName + tmpSrcForDoc <- file.path(m, "R/READONLYFromMainModuleFile.R") + mainModuleFile <- file.path(m, paste0(basename(m), ".R")) + # if (missing(rlaa)) { + rlaa <- readLines(mainModuleFile) + # } + + if (missing(linesWithDefModule)) { + if (missing(gpd)) { + aa <- parse(mainModuleFile, keep.source = TRUE) + gpd <- getParseData(aa) + } + linesWithDefModule <- gpd[grep("defineModule", gpd$text) - 1, ][, c("line1", "line2")] + } + if (!dir.exists(file.path(m, "R"))) + dir.create(file.path(m, "R")) + cat(paste0("#% Generated by SpaDES.core: do not edit by hand +#% Please edit documentation in\n#%", mainModuleFile), + file = tmpSrcForDoc) + cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", + file = tmpSrcForDoc, append = TRUE) + # on.exit(unlink(tmpSrcForDoc)) + roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... + pkgload::dev_topic_index_reset(m) + pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting +} diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 149699bd..0b2596a9 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -269,7 +269,7 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP d$Imports[hasVersionNumb] <- paste(d$Imports[hasVersionNumb], inequality) dFile <- filenameFromFunction(packageFolderName, "DESCRIPTION", fileExt = "") - origDESCtxt <- read.dcf(dFile) + origDESCtxt <- if (file.exists(dFile)) read.dcf(dFile) else character() cat(paste("Package:", d$Package), file = dFile, sep = "\n") cat(paste("Type:", d$Type), file = dFile, sep = "\n", append = TRUE) @@ -279,12 +279,15 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP cat(paste("Date:", d$Date), file = dFile, sep = "\n", append = TRUE) cat(c("Authors@R: ", format(d$Authors)), file = dFile, sep = "\n", append = TRUE) - mergeField(origDESCtxt = origDESCtxt, field = d$Imports, fieldName = "Imports", dFile) + if (length(d$Imports) || length(origDESCtxt)) + mergeField(origDESCtxt = origDESCtxt, field = d$Imports, fieldName = "Imports", dFile) suggs <- c('knitr', 'rmarkdown', 'testthat', 'withr', 'roxygen2') - mergeField(origDESCtxt = origDESCtxt, field = suggs, fieldName = "Suggests", dFile) + if (length(suggs) || length(origDESCtxt)) + mergeField(origDESCtxt = origDESCtxt, field = suggs, fieldName = "Suggests", dFile) - mergeField(origDESCtxt = origDESCtxt, field = d$Remotes, fieldName = "Remotes", dFile) + if (length(d$Remotes) || length(origDESCtxt)) + mergeField(origDESCtxt = origDESCtxt, field = d$Remotes, fieldName = "Remotes", dFile) cat("Encoding: UTF-8", sep = "\n", file = dFile, append = TRUE) cat("License: GPL-3", sep = "\n", file = dFile, append = TRUE) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index f645eae8..d65d3c93 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -617,6 +617,7 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = } .isPackage <- function(fullModulePath, sim) { + return(FALSE) modEnv <- sim@.xData$.mods[[basename2(fullModulePath)]] # There are 3 ways to check ... existence of .isPackage is fastest, but may be wrong # if the namespace exists ... 2nd fastest, but also may be wrong if FALSE diff --git a/tests/testthat/helper-initTests.R b/tests/testthat/helper-initTests.R index 62b3d60e..dc5f187e 100644 --- a/tests/testthat/helper-initTests.R +++ b/tests/testthat/helper-initTests.R @@ -107,9 +107,9 @@ testCode <- ' mod$a <- 2 # should have mod$x here sim$testPar1 <- Par$testParA - if (tryCatch(exists("Init", envir = asNamespace("test"), inherits = FALSE), error = function(x) FALSE)) { + # if (tryCatch(exists("Init", envir = asNamespace("test"), inherits = FALSE), error = function(x) FALSE)) { sim <- Init(sim) - } + # } sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 1, "test", "event1", .skipChecks = TRUE) }, @@ -161,9 +161,9 @@ test2Code <- ' switch( eventType, init = { - if (tryCatch(exists("Init", envir = asNamespace("test2"), inherits = FALSE), error = function(x) FALSE)) { + # if (tryCatch(exists("Init", envir = asNamespace("test2"), inherits = FALSE), error = function(x) FALSE)) { sim <- Init(sim) - } + # } if (isTRUE(P(sim)$testParB >= 1100)) { P(sim, "testParB") <- P(sim)$testParB + 756 diff --git a/tests/testthat/test-mod.R b/tests/testthat/test-mod.R index 61652bfc..1f21f1dc 100644 --- a/tests/testthat/test-mod.R +++ b/tests/testthat/test-mod.R @@ -164,13 +164,13 @@ test_that("convertToPackage testing", { testName2 <- paste0("test2.", .rndstr(len = 1)) mainModFile1 <- paste0(testName1, ".R") mainModFile2 <- paste0(testName2, ".R") - try(pkgload::unload(testName1), silent = TRUE) - try(pkgload::unload(testName2), silent = TRUE) + # try(pkgload::unload(testName1), silent = TRUE) + # try(pkgload::unload(testName2), silent = TRUE) - on.exit({ - try(pkgload::unload(testName1), silent = TRUE) - try(pkgload::unload(testName2), silent = TRUE) - }, add = TRUE) + # on.exit({ + # try(pkgload::unload(testName1), silent = TRUE) + # try(pkgload::unload(testName2), silent = TRUE) + # }, add = TRUE) newModule(testName1, tmpdir, open = FALSE) newModule(testName2, tmpdir, open = FALSE) @@ -191,6 +191,7 @@ test_that("convertToPackage testing", { #\' @rdname Init #\' @name Init #\' @param sim A simList + #\' @export Init <- function(sim) { sim$aaaa <- Run1(1) return(sim) @@ -230,7 +231,7 @@ test_that("convertToPackage testing", { expect_true(!file.exists(file.path(tmpdir, tt, "NAMESPACE"))) expect_true(dir.exists(file.path(tmpdir, tt, "R"))) ## list.files(file.path(tmpdir, tt, "R")) - expect_true(file.exists(filenameForMainFunctions(tt, tmpdir))) + # expect_true(file.exists(filenameForMainFunctions(tt, tmpdir))) } mySim9 <- simInit(times = list(start = 0, end = 1), @@ -239,7 +240,7 @@ test_that("convertToPackage testing", { # doesn't document, unless it is first time for (tt in c(testName1, testName2)) { expect_true(file.exists(file.path(tmpdir, tt, "DESCRIPTION"))) - expect_true(file.exists(file.path(tmpdir, tt, "NAMESPACE"))) + # expect_true(file.exists(file.path(tmpdir, tt, "NAMESPACE"))) expect_true(dir.exists(file.path(tmpdir, tt, "R"))) } working <- spades(mySim9, debug = FALSE) @@ -253,19 +254,38 @@ test_that("convertToPackage testing", { # Will run document() so will have the NAMESPACE and for (tt in c(testName1, testName2)) { expect_true(file.exists(file.path(tmpdir, tt, "DESCRIPTION"))) - expect_true(file.exists(file.path(tmpdir, tt, "NAMESPACE"))) - expect_true(sum(grepl("export.+doEvent", readLines(file.path(tmpdir, tt, "NAMESPACE")))) == 1) + # expect_true(file.exists(file.path(tmpdir, tt, "NAMESPACE"))) + # expect_true(sum(grepl("export.+doEvent", readLines(file.path(tmpdir, tt, "NAMESPACE")))) == 1) } # check that inheritance is correct -- Run is in the namespace, Init also... doEvent calls Init calls Run expect_true(is(working, "simList")) expect_true(working$aaaa == 2) expect_true(is(working$cccc, "try-error")) - bbb <- get("Run2", asNamespace(testName2))(2) - fnTxt <- readLines(filenameForMainFunctions(tt, tmpdir)) + # bbb <- get("Run2", asNamespace(testName2))(2) + bbb <- get("Run2", working$.mods[[testName2]])(2) + + packageFoldername <- file.path(tmpdir, testName2) + fnTxt <- readLines(file.path(packageFoldername, paste0(testName2, ".R"))) expect_true(sum(grepl("Need to keep comments", fnTxt)) == 1) expect_true(bbb == 4) - pkgload::unload(testName1) - pkgload::unload(testName2) + + # check documentation + packageFoldername <- file.path(tmpdir, testName1) + expect_false(dir.exists(file.path(packageFoldername, "man"))) + documentModule(packageFoldername) + expect_true(dir.exists(file.path(packageFoldername, "man"))) + pkgload::load_all(packageFoldername) + on.exit({ + try(pkgload::unload(.moduleNameNoUnderscore(basename(packageFoldername)))) + }) + fn <- get("Init", envir = asNamespace(.moduleNameNoUnderscore(basename(packageFoldername)))) + expect_is(fn, "function") + pkgload::unload(.moduleNameNoUnderscore(basename(packageFoldername))) + fn <- try(get("Init", envir = asNamespace(.moduleNameNoUnderscore(basename(packageFoldername)))), silent = TRUE) + expect_true(is(fn, "try-error")) + + # pkgload::unload(testName1) + # pkgload::unload(testName2) #} }) diff --git a/tests/testthat/test-module-template.R b/tests/testthat/test-module-template.R index ea033428..02d9ef5b 100644 --- a/tests/testthat/test-module-template.R +++ b/tests/testthat/test-module-template.R @@ -130,7 +130,8 @@ test_that("newModule with events and functions", { expect_true(out$b == 3) yrsSimulated <- (end(out) - start(out)) expect_true(sum(grepl("hi", mess)) == yrsSimulated) - expect_true(NROW(completed(out)) == yrsSimulated + 6) + expect_true(NROW(completed(out)) == yrsSimulated + + (NROW(.coreModules()) - 1) + length(c(".inputObjects", "next1", "init"))) expect_true(NROW(events(out)) == 1) expect_true(NROW(completed(out)[eventType == "next1"]) == 1) expect_true(NROW(completed(out)[eventType == "plot"]) == yrsSimulated) From b91a295a48ad5f7283399dec277c45a74c994b04 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 26 Jun 2024 18:04:34 -0700 Subject: [PATCH 004/128] use box::use --- R/modActiveBinding.R | 1 + R/simulation-parseModule.R | 20 +- R/simulation-simInit.R | 21 +- tests/testthat/test-mod.R | 2 +- tests/testthat/test-simulation.R | 1824 +++++++++++++++--------------- 5 files changed, 941 insertions(+), 927 deletions(-) diff --git a/R/modActiveBinding.R b/R/modActiveBinding.R index 63571771..a79c63d3 100644 --- a/R/modActiveBinding.R +++ b/R/modActiveBinding.R @@ -11,6 +11,7 @@ makeModActiveBinding <- function(sim, mod) { if (.isPackage(fullModulePath = mod, sim = sim)) { env <- asNamespace(.moduleNameNoUnderscore(mod)) } else { + browser() env <- sim@.xData$.mods[[mod]] if (exists("mod", envir = env, inherits = FALSE)) rm(list = "mod", envir = env, inherits = FALSE) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index d65d3c93..68f083ee 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -267,9 +267,10 @@ setMethod( sim@.xData$.mods[[mBase]]$.objects <- new.env(parent = emptyenv()) sim@.xData$.mods[[mBase]]$.isPackage <- TRUE + browser() activeCode[["main"]] <- evalWithActiveCode(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], asNamespace(.moduleNameNoUnderscore(mBase)), - sim = sim) + sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) } else { sim@.xData$.mods[[mBase]]$.isPackage <- FALSE @@ -282,7 +283,7 @@ setMethod( # eval(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], envir = sim@.xData$.mods[[mBase]]) activeCode[["main"]] <- evalWithActiveCode(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], sim@.xData$.mods[[mBase]], - sim = sim) + sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) # doesntUseNamespacing <- parseOldStyleFnNames(sim, mBase, ) doesntUseNamespacing <- !.isNamespaced(sim, mBase) @@ -297,7 +298,7 @@ setMethod( #lockBinding(mBase, sim@.envir) ## guard against clobbering from module code (#80) out1 <- evalWithActiveCode(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], sim@.xData$.mods, - sim = sim) + sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) #unlockBinding(mBase, sim@.envir) ## will be re-locked later on } @@ -318,13 +319,13 @@ setMethod( if (doesntUseNamespacing) { #eval(parsedFile1, envir = sim@.xData) evalWithActiveCode(parsedFile1, sim@.xData$.mods, - sim = sim) + sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) } # duplicate -- put in namespaces location #eval(parsedFile1, envir = sim@.xData$.mods[[mBase]]) activeCode[[Rfiles]] <- evalWithActiveCode(parsedFile1, sim@.xData$.mods[[mBase]], - sim = sim) + sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) } } @@ -558,7 +559,7 @@ setMethod( #' @keywords internal evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = parent.frame(), - sim) { + sim, pkgs) { # browser(expr = exists("._evalWithActiveCode_1")) # Create a temporary environment to source into, adding the sim object so that @@ -574,6 +575,13 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = ll <- lapply(parsedModuleNoDefineModule, function(x) tryCatch(eval(x, envir = tmpEnvir), error = function(x) "ERROR")) + cm <- currentModule(tmpEnvir$sim) + if (!cm %in% unlist(.coreModules())) { + pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + lapply(pkgs, function(p) eval(as.call(parse(text = paste0("box::use(", p, "[...]", ")")))[[1]], envir = tmpEnvir)) + } + + activeCode <- unlist(lapply(ll, function(x) identical("ERROR", x))) rm("sim", envir = tmpEnvir) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 78c15b2d..86e51f39 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1332,6 +1332,8 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out runFnCallAsExpr <- is.null(attr(sim, "runFnCallAsExpr")) } if (runFnCallAsExpr) { + pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) + do.call(box::use, lapply(pkgs, as.name)) sim <- Cache(.inputObjects, sim, .objects = objectsToEvaluateForCaching, notOlderThan = notOlderThan, @@ -1547,14 +1549,14 @@ loadPkgs <- function(reqdPkgs) { # Check for SpaDES.core minimum version checkSpaDES.coreMinVersion(allPkgs) allPkgs <- grep("^SpaDES.core\\>", allPkgs, value = TRUE, invert = TRUE) - if (getOption("spades.useRequire")) { - getCRANrepos(ind = 1) # running this first is neutral if it is set - Require(allPkgs, standAlone = FALSE, upgrade = FALSE) - # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) - } else { - allPkgs <- unique(Require::extractPkgName(allPkgs)) - loadedPkgs <- lapply(allPkgs, require, character.only = TRUE) - } + # if (getOption("spades.useRequire") && !isMacOSX()) { + # getCRANrepos(ind = 1) # running this first is neutral if it is set + # Require(allPkgs, standAlone = FALSE, upgrade = FALSE) + # # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) + # } else { + # allPkgs <- unique(Require::extractPkgName(allPkgs)) + # loadedPkgs <- lapply(allPkgs, require, character.only = TRUE) + # } } } @@ -1905,3 +1907,6 @@ simNestingOverride <- function(sim, mBase) { sim[["._simNesting"]][len] <- paste0(modName8Chars, ":", cli::col_green(sim@current$eventType)) sim[["._simNesting"]] } + +isMacOSX <- function() + isMac <- tolower(Sys.info()["sysname"]) == "darwin" diff --git a/tests/testthat/test-mod.R b/tests/testthat/test-mod.R index 1f21f1dc..d40981f2 100644 --- a/tests/testthat/test-mod.R +++ b/tests/testthat/test-mod.R @@ -152,7 +152,7 @@ test_that("local mod object", { } }) -test_that("convertToPackage testing", { +# test_that("convertToPackage testing", { skip_on_cran() skip_if_not_installed(c("ggplot2", "pkgload", "roxygen2")) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index e229dbaf..f180799c 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -36,7 +36,7 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { set.seed(123) mySimEvent <- simInit(times, params, modules, objects = list(), paths) |> spades(debug = FALSE, .plotInitialTime = NA, events = "init") - expect_true(all("init" == completed(mySimEvent)$eventType)) + expect_true(all(c(".inputObjects", "init") %in% completed(mySimEvent)$eventType)) expect_true(max(events(mySimEvent)$eventTime) <= end(mySimEvent)) # didn't schedule next event @@ -54,8 +54,8 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { eventTypes <- c("nothing") mySimEvent4 <- simInit(times, params, modules, objects = list(), paths) |> spades(debug = FALSE, .plotInitialTime = NA, events = eventTypes) - expect_true(NROW(completed(mySimEvent4)) == 0) # nothing completed - expect_true(all("init" == events(mySimEvent4)$eventType)) # nothing happened; only inits in queue + expect_true(NROW(completed(mySimEvent4)) == length(modules)) # only .inputObjects completed + expect_true(all(c(".inputObjects", "init") %in% completed(mySimEvent)$eventType)) eventTypes <- list(randomLandscapes = c("init"), fireSpread = c("init", "burn") @@ -72,7 +72,7 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { mySimEvent6 <- simInit(times, params, modules, objects = list(), paths) |> spades(debug = FALSE, .plotInitialTime = NA, events = eventTypes) expect_true(all("randomLandscapes" %in% completed(mySimEvent6)$moduleName)) - expect_true(!all("fireSpread" %in% completed(mySimEvent6)$moduleName)) # didn't run any fireSpread events b/c misspelled + expect_true(sum("fireSpread" %in% completed(mySimEvent6)$moduleName) == 1) # only .inputObjects; didn't run any fireSpread events b/c misspelled expect_true(all("fireSpread" %in% events(mySimEvent6)$moduleName)) # didn't run any fireSpread events b/c misspelled mySimEvent7 <- simInit(times, params, modules, objects = list(), paths) |> @@ -129,911 +129,911 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { expect_true(all(file.exists(outputs(mySimEvent12Out)$file[outputs(mySimEvent12Out)$saved]))) }) -test_that("spades calls - diff't signatures", { - testInit(sampleModReqdPkgs, verbose = TRUE) - - a <- simInit() - a1 <- Copy(a) - opts <- options(spades.saveSimOnExit = FALSE) - expect_message(spades(a, debug = TRUE), "eventTime") - expect_silent(expect_message(spades(a, debug = FALSE), "DTthreads")) - expect_silent(expect_message(spades(a, debug = FALSE, .plotInitialTime = NA), "DTthreads")) - expect_silent(expect_message(spades(a, debug = FALSE, .saveInitialTime = NA), "DTthreads")) - opts <- options(opts) - expect_message(spades(a, debug = TRUE, .plotInitialTime = NA), "eventTime") - expect_message(spades(a, debug = TRUE, .saveInitialTime = NA), "eventTime") - expect_equivalent(capture_output(spades(a, debug = "current", .plotInitialTime = NA)), - capture_output(spades(a, debug = TRUE, .plotInitialTime = NA))) - - if (requireNamespace("logging", quietly = TRUE)) { - expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), - "eventTime *moduleName *eventType *eventPriority") - } else { - expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), - "eventTime *moduleName *eventType *eventPriority") - } - expect_message(spades(a, debug = c("current", "events"), .plotInitialTime = NA), "moduleName") - expect_message(spades(a, debug = "simList", .plotInitialTime = NA), "Completed Events") - - if (interactive()) { - # warnings occur on Rstudio-server related to can't use display 0:, when using devtools::test() interactively - suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "10%")) - suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "20%")) - suppressWarnings(expect_output(spades(a, progress = "text"), "..........| 100%")) - } - opts <- options(spades.saveSimOnExit = FALSE) - expect_silent(expect_message(spades(a, debug = FALSE, progress = FALSE), "DTthreads")) - expect_silent(expect_message(spades(a, debug = FALSE, progress = "rr"), "DTthreads")) - opts <- options(opts) - - paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) - a <- Copy(a1) - expect_message(spades(a, cache = TRUE, debug = TRUE, notOlderThan = Sys.time()), "eventTime") - expect_true(all(basename2(c(CacheDBFile(paths(a)$cachePath), CacheStorageDir(paths(a)$cachePath))) %in% - dir(paths(a)$cachePath))) - file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) - - # test for system time ... in this case, the first time through loop is slow - # because of writing cache to disk, not because of spades being slow. - # simList is empty. - - set.seed(42) - - times <- list(start = 0.0, end = 0, timeunit = "year") - params <- list( - .globals = list(burnStats = "npixelsburned", stackName = "landscape"), - randomLandscapes = list(nx = 20, ny = 20) - ) - modules <- list("randomLandscapes", "fireSpread") - paths <- list(modulePath = getSampleModules(tmpdir)) - - for (i in 1:2) { - a <- simInit(times, params, modules, paths = paths) - paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) - assign(paste0("st", i), system.time(spades(a, cache = TRUE, .plotInitialTime = NA))) - } - params1 <- list( - .globals = list(burnStats = "npixelsburned", stackName = "landscape"), - randomLandscapes = c(nx = 20, ny = 20) - ) - expect_error({ a <- simInit(times, params1, modules, paths = paths) }) - expect_error({ a <- simInit(list(3, "a", "s"), params, modules, paths = paths) }) - err <- capture_error({ - a <- simInit(list(3, "years", start = 1), params, modules, paths = paths) - }) - expect_true(is.null(err)) - - #expect_gt(st1[1], st2[1]) ## no longer true on R >= 3.5.1 ?? - file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) -}) - -test_that("simInit with R subfolder scripts", { - skip_if_not_installed("NLMR") - - testInit() - - newModule("child1", ".", open = FALSE) - cat(file = file.path("child1", "R", "script.R"), - "a <- function(poiuoiu) { - poiuoiu + 1 - }", sep = "\n") - mySim <- simInit(modules = "child1", paths = list(modulePath = tmpdir)) - expect_true(sum(grepl(unlist(lapply(ls(mySim@.xData$.mods, all.names = TRUE), function(x) { - if (is.environment(mySim@.xData$.mods[[x]])) ls(envir = mySim@.xData$.mods[[x]], all.names = TRUE) - })), pattern = "^a$")) == 1) - expect_true(mySim@.xData$.mods$child1$a(2) == 3) # Fns -}) - -test_that("simulation runs with simInit with duplicate modules named", { - testInit(sampleModReqdPkgs) - - set.seed(42) - - times <- list(start = 0.0, end = 10, timeunit = "year") - params <- list( - randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), - caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE) - ) - modules <- list("randomLandscapes", "randomLandscapes", "caribouMovement") - paths <- list(modulePath = getSampleModules(tmpdir)) - - expect_true(any(grepl(capture_messages({ - mySim <- simInit(times, params, modules, objects = list(), paths) - }), pattern = "Duplicate module"))) - expect_true(length(modules(mySim)) != length(modules)) - expect_true(length(modules(mySim)) == length(unique(modules))) -}) - -test_that("simulation runs with simInit with duplicate modules named", { - skip("benchmarking DES") - - testInit() - - 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), - childModules = character(0), - version = list(SpaDES.core = "0.1.0", test = "0.0.1"), - spatialExtent = terra::ext(rep(0, 4)), - timeframe = as.POSIXlt(c(NA, NA)), - timeunit = "second", - citation = list("citation.bib"), - documentation = list("README.md", "test.Rmd"), - reqdPkgs = list(), - parameters = rbind( - ), - inputObjects = bindrows( - ), - outputObjects = bindrows( - ) - )) - - doEvent.test = function(sim, eventTime, eventType, debug = FALSE) { - switch( - eventType, - init = { - 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), - childModules = character(0), - version = list(SpaDES.core = "0.1.0", test2 = "0.0.1"), - spatialExtent = terra::ext(rep(0, 4)), - timeframe = as.POSIXlt(c(NA, NA)), - timeunit = "second", - citation = list("citation.bib"), - documentation = list("README.md", "test2.Rmd"), - reqdPkgs = list(), - parameters = rbind( - ), - inputObjects = bindrows( - ), - outputObjects = bindrows( - ) - )) - - doEvent.test2 = function(sim, eventTime, eventType, debug = FALSE) { - switch( - eventType, - init = { - sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) - }, - event1 = { - sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) - }) - return(invisible(sim)) - } - ', fill = TRUE) - - N <- 5000 - - moduleDir <- file.path(tmpdir) - inputDir <- file.path(moduleDir, "inputs") |> checkPath(create = TRUE) - outputDir <- file.path(moduleDir, "outputs") - cacheDir <- file.path(outputDir, "cache") - times <- list(start = 0, end = N) - parameters <- list( - ) - modules <- list("test") - objects <- list() - paths <- list( - cachePath = cacheDir, - modulePath = moduleDir, - inputPath = inputDir, - outputPath = outputDir - ) - - #options("spades.nCompleted" = 500) - mySim <- simInit(times = times, params = parameters, modules = modules, - objects = objects, paths = paths) - - nTimes <- 20 - - ####################### - # Tested on laptop - ####################### - # laptop was 10.2 seconds -- currently 4.2 seconds or so --> June 29, 2018 is 1.06 seconds - # laptop New with "seconds" -- Sept 21, 2018 is 0.492 seconds --> 98 microseconds/event - # laptop New with "seconds" -- Nov 26, 2018 is 0.458 seconds --> 92 microseconds/event! - # Windows Desktop -- slower -- Nov 26, 2018 0.730 Seconds --> 148 microseconds/event! - # Linux Server -- slower -- Nov 26, 2018 0.795 Seconds --> 159 microseconds/event! - # BorealCloud Server -- slower -- Nov 26, 2018 0.972 Seconds --> 194 microseconds/event! - # laptop -- May 25, 2019 0.603 Seconds --> 120 microseconds/event! - # laptop with new completed as environment -- May 25, 2019 0.357 Seconds --> 71 microseconds/event! - options("spades.keepCompleted" = TRUE) - # microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)}) - # - # # Turn off completed list - # # Changed to use "seconds" -- better comparison with simple loop - # # Old times using "year" -- June 29, 2018 is 0.775 seconds, Sept 19, 2018 0.809 seconds - # # -- This is 161 microseconds per event - # # New times using "second" -- Sept 19, 2018 0.244 Seconds --> 49 microseconds/event - # # New times using "second" -- Nov 26, 2018 0.192 Seconds --> 38 microseconds/event! - # # Windows Desktop -- slower -- Nov 26, 2018 0.348 Seconds --> 70 microseconds/event! - # # Linux Server -- slower -- Nov 26, 2018 0.461 Seconds --> 92 microseconds/event! - # # BorealCloud Server -- slower -- Nov 26, 2018 0.282 Seconds --> 56 microseconds/event! - # # With many new "exists" - # # laptop -- May 25, 2019 0.264 Seconds --> 53 microseconds/event! - # options("spades.keepCompleted" = FALSE) - # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) - # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) - # - # a <- 0 - # a3 <- microbenchmark::microbenchmark( - # for (i in 1:N) { - # a <- a + 1 - # } - # ) - # - # summary(a2)[, "median"]/summary(a3)[, "median"] - # - # ######################################## - # # With 2 modules, therefore sorting - # ######################################## - # modules <- list("test", "test2") - # mySim <- simInit(times = times, params = parameters, modules = modules, - # objects = objects, paths = paths) - # - # nTimes <- 10 - # # Turn off completed list - # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 59 microseconds/event, even with sorting - # options("spades.keepCompleted" = FALSE) - # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) - # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) - # - # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 130 microseconds/event, even with sorting - # options("spades.keepCompleted" = TRUE) - # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) -}) - -test_that("conflicting function types", { - testInit(sampleModReqdPkgs, smcc = TRUE) - - m <- "child4" - newModule(m, tmpdir, open = FALSE) - fileName <- file.path(m, paste0(m, ".R")) # child4/child4.R" - xxx <- readLines(fileName) - lineWithInit <- grep(xxx, pattern = "^Init") - - xxx1 <- gsub(xxx, pattern = 'plotFun', replacement = 'Plot') # nolint - cat(xxx1, file = fileName, sep = "\n") - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "Plot is defined") - - # do functions like raster::levels - cat(xxx[1:lineWithInit], " - library(raster) - poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) - poiuoiu <- poiuoiu - poiuoiu <- scale(poiuoiu) - poiuoiu <- ratify(poiuoiu) - rat <- raster::levels(poiuoiu)[[1]] - - levels(poiuoiu) <- rat - ", - xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - - fullMessage <- c("the following function\\(s\\) is used that", "raster::scale", "scale") - expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) - nonMessage <- c("raster::levels", "levels") - expect_false(all(unlist(lapply(nonMessage, function(x) any(grepl(mm, pattern = x)))))) - - cat(xxx[1:lineWithInit], " - library(raster) - poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) - poiuoiu <- scale(poiuoiu) - ", - xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "raster::scale") - - cat(xxx[1:lineWithInit], " - library(raster) - poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) - poiuoiu <- raster::scale(poiuoiu) - sim$poiuoiu <- poiuoiu - ", - xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "poiuoiu is assigned") - - cat(xxx[1:(lineWithInit - 1)], " - a <- function(x) { - b <- b + 1 - } - ", - xxx[(lineWithInit):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "a: parameter") - - xxx1 <- gsub(xxx, pattern = "\\.plotInitialTime", replacement = "value") - xxx1 <- gsub(xxx1, pattern = "NA, NA, NA", replacement = "'hi', NA, NA") - - cat(xxx1[1:lineWithInit], " - a <- sim$b - d <- sim$d - f <- sim[['f']] - f <- sim[[P(sim)$value]] - poiuoiu <- sim@.xData$d1 - qwerqwer <- sim@.xData[['test']] - sim$g <- f - sim@.xData$g1 <- f - return(list(a, d, f, sim)) - ", - xxx1[(lineWithInit + 1):length(xxx1)], sep = "\n", fill = FALSE, file = fileName) - - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - - fullMessage <- c(# "defineParameter: 'value' is not of specified type 'numeric'", - "defineParameter: 'plotInterval' is not of specified type 'numeric'", - "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", - "defineParameter: 'saveInterval' is not of specified type 'numeric'", - "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", - "Running .inputObjects for child4", - "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", - "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", - "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" - ) - - mm <- cleanMessage(mm) - expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) - - cat(xxx[1:lineWithInit], " - sim$child4 <- 1 - ", - xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_error(simInit(paths = list(modulePath = tmpdir), modules = m), - c(paste0(m, ": You have created an object"))) - - # declared in metadata inputObjects - lineWithInputObjects <- grep(xxx, pattern = " expectsInput") - cat(xxx[1:(lineWithInputObjects - 1)], " - expectsInput('a', 'numeric', '', '') - ", - xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), - c(paste0(m, ": module code: a is declared in metadata inputObjects"))) - - # declared in metadata outputObjects - lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") - cat(xxx[1:(lineWithOutputObjects - 1)], " - createsOutput('b', 'numeric', '') - ", - xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), - c(paste0(m, ": module code: b is declared in metadata outputObjects"))) - - cat(xxx[1:(lineWithInputObjects - 1)], " - expectsInput('a', 'numeric', '', '') - ", - xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], - " - createsOutput('b', 'numeric', '') - ", - xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - expect_true(all(grepl(mm, - pattern = c(paste0(m, ": module code: b is declared in metadata outputObjects|", - "so not checking minimum package|", - m, ": module code: a is declared in metadata inputObjects|", - "Running .inputObjects|", - "Setting:|Paths set to:|", - "Using setDTthreads|", - m, ": using dataPath|", "Elapsed"))))) - - # assign to sim for functions like scheduleEvent - lineWithScheduleEvent <- grep(xxx, pattern = "scheduleEvent")[1] - xxx1 <- xxx - xxx1[lineWithScheduleEvent] <- sub(xxx[lineWithScheduleEvent], pattern = "sim <- scheduleEvent", - replacement = "scheduleEvent") - cat(xxx1, sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), - c(paste0(m, ": module code: scheduleEvent inside doEvent.child4 must"))) - - # Return sim in doEvent - patt <- "return\\(invisible\\(sim\\)\\)" - lineWithReturnSim <- grep(xxx, pattern = patt)[1] - xxx1 <- xxx - xxx1[lineWithReturnSim] <- sub(xxx[lineWithReturnSim], pattern = patt, - replacement = "return(invisible())") - cat(xxx1, sep = "\n", fill = FALSE, file = fileName) - - expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), - c(paste0(m, ": module code: doEvent.", m, " must return"))) - - lineWithInputObjects <- grep(xxx, pattern = " expectsInput") - lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") - lineWithDotInputObjects <- grep(xxx, pattern = "\\.inputObjects")[1] - cat(xxx[1:(lineWithInputObjects - 1)], " - expectsInput('ei1', 'numeric', desc = 'This is a test with spaces - and EOL', ''), - expectsInput('ei2', 'numeric', '', ''), - expectsInput('ei3', 'numeric', '', ''), - expectsInput('ei4', 'numeric', '', 'test.com') - ", - xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " - createsOutput('co1', 'numeric', ''), - createsOutput('co2', 'numeric', desc = 'This is a test with spaces - and EOL on the createsOutputs'), - createsOutput('co3', 'numeric', ''), - createsOutput('co4', 'numeric', '') - ", - xxx[(lineWithOutputObjects + 1):lineWithInit], " - a <- sim$b - sim$g <- f - holy(sim$co4) <- f - moly(sim$aaa) <- f - fff <- sim$ei2 - fff <- sim$co3 - sim$co1 <- 123 - xx <- c(1,2) - xx[sim$ei4] <- NA - ", - xxx[(lineWithInit + 1):lineWithDotInputObjects], " - a <- sim$b - url1 <- extractURL('ei4') - if (!identical(url1, 'test.com')) - stop('extractURL without sim or module fails') - url1 <- extractURL('ei4', sim = sim) - if (!identical(url1, 'test.com')) - stop('extractURL without module fails')", -paste0(" url1 <- extractURL('ei4', sim = sim, module = \"", m, "\")") ," - if (!identical(url1, 'test.com')) - stop('extractURL fails') - sim$g <- 1 - sim$ei1 <- 4 - fff <- sim$ei1 - fff <- sim$co3 - sim$co1 <- 123 - aaa <- sim$.userSuppliedObjNames # in the ignoreObjects - ", - xxx[(lineWithDotInputObjects + 1):length(xxx)], - sep = "\n", fill = FALSE, file = fileName) - - fullMessage <- c( - "Running .inputObjects for child4", - "child4: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", - "child4: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", - "child4: module code: ei3 is declared in metadata inputObjects, but is not used in the module", - "child4: module code: .inputObjects: local variable.*a.*assigned but may not be used", - "child4: module code: .inputObjects: local variable.*fff.*assigned but may not be used", - "child4: module code: Init: local variable.*a.*assigned but may not be used", - "child4: module code: Init: local variable.*fff.*assigned but may not be used", - "child4: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", - "child4: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", - "child4: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", - "child4: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects" - ) - - # Test moduleMetadata without `sim` and where there is a `sim` in the module metadata, - # so needs to load it. A non-error is good enough for now. - md1 <- moduleMetadata(module = m, path = tmpdir) # no sim in metadata - md2 <- moduleMetadata(path = getSampleModules(tmpdir), - module = "randomLandscapes") - - - mm <- capture_messages({ - mySim <- simInit(paths = list(modulePath = tmpdir), modules = m) - }) - mm <- cleanMessage(mm) - expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) - - x1 <- moduleMetadata(mySim) - sns <- slotNames(mySim@depends@dependencies[[m]]) - names(sns) <- sns - x2 <- lapply(sns, function(sn) { - slot(mySim@depends@dependencies[[m]], sn) - }) - - # Now extra spaces are removed automatically on load ######################## - - # When there are more than a certain number of characters, a hidden \n gets inserted - # Our metadata in tests is close to that, and some push past. No point diagnosing further. Accept 1 "TRUE" - expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) - x2 <- rmExtraSpacesEOLList(x2) - expect_true(sum(unlist(lapply(x1, function(v) grepl(" |\n", v)))) <= 1) - expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) - - x1 <- moduleParams(m, dirname(dirname(fileName))) - expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) - x1 <- moduleInputs(m, dirname(dirname(fileName))) - expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) - x1 <- moduleOutputs(m, dirname(dirname(fileName))) - expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) -}) - -test_that("scheduleEvent with NA logical in a non-standard parameter", { - testInit("ggplot2", smcc = TRUE) - m <- "test" - newModule(m, tmpdir, open = FALSE) - fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" - xxx <- readLines(fileName) - #lineWithInit <- grep(xxx, pattern = "^Init") - - xxx1 <- gsub(xxx, pattern = '.plotInitialTime', replacement = '.plotInitialTim') # nolint - xxx2a <- grep(".plotInitialTim\\>", xxx1, value = TRUE)[1] - xxx2b <- gsub(",$", grep("time interval between plot", xxx1, value = TRUE), replacement = "") - xxx3 <- parse(text = paste(xxx2a, xxx2b)) - # show that it is logical - sim <- simInit(times = list(start = 0, end = 2)) - expect_true(is.numeric(eval(xxx3)$default[[1]])) - - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - expect_true(all(unlist(lapply(c("Running .inputObjects", "module code appears clean"), - function(x) any(grepl(mm, pattern = x)))))) -}) - -test_that("messaging with multiple modules", { - testInit("ggplot2", smcc = TRUE) - - m1 <- "test" - m2 <- "test2" - m3 <- "test3" - m4 <- "test4" - m <- c(m1, m2, m3, m4) - newModule(m1, tmpdir, open = FALSE) - newModule(m2, tmpdir, open = FALSE) - newModule(m3, tmpdir, open = FALSE) - newModule(m4, tmpdir, open = FALSE) - #lapply(m, newModule, tmpdir, open = FALSE) - fileNames <- file.path(tmpdir, m, paste0(m, ".R")) - xxx <- lapply(fileNames, readLines) - set.seed(113) - - lineWithInit <- grep(xxx[[1]], pattern = "^Init") - lineWithInputObjects <- grep(xxx[[1]], pattern = " expectsInput") - lineWithOutputObjects <- grep(xxx[[1]], pattern = " createsOutput") - lineWithDotInputObjects <- grep(xxx[[1]], pattern = "\\.inputObjects")[1] - - xxx1 <- list() - #lapply(seq(m), function(yy) sample(c("character", "numeric", "logical"), size = 3, replace = TRUE)) - xxx1[[1]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", - "\\.plotInitialTime\", \"character\", 1", xxx[[1]]) - xxx1[[1]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", - "\\.saveInitialTime\", \"character\", FALSE", xxx1[[1]]) - xxx1[[1]] <- gsub("\\.saveInterval\", \"numeric\", NA", - "\\testtime\", \"logical\", NA_real_", xxx1[[1]]) - - xxx1[[2]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", - "\\.plotInitialTime\", \"character\", TRUE", xxx[[2]]) - xxx1[[2]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", - "\\.saveInitialTime\", \"character\", 'c'", xxx1[[2]]) - xxx1[[2]] <- gsub("\\.saveInterval\", \"numeric\", NA", - "\\testtime\", \"character\", NA_real_", xxx1[[2]]) - - xxx1[[3]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", - "\\.plotInitialTime\", \"character\", 1", xxx[[3]]) - xxx1[[3]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", - "\\hello\", \"character\", 1", xxx1[[3]]) - xxx1[[3]] <- gsub("\\.saveInterval\", \"numeric\", NA", - "\\testtime\", \"logical\", NA_real_", xxx1[[3]]) - xxx1[[4]] <- xxx[[4]] # clean one - - cat(xxx1[[1]][1:(lineWithInputObjects - 1)], " - expectsInput('ei1', 'numeric', '', ''), - expectsInput('ei2', 'numeric', '', ''), - expectsInput('ei3', 'numeric', '', ''), - expectsInput('ei4', 'numeric', '', '') - ", - xxx1[[1]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " - createsOutput('co1', 'numeric', ''), - createsOutput('co2', 'numeric', ''), - createsOutput('co3', 'numeric', ''), - createsOutput('co4', 'numeric', '') - ", - xxx1[[1]][(lineWithInputObjects + 1):lineWithInit], " - a <- sim$b - sim$g <- f - holy(sim$co4) <- f - moly(sim$aaa) <- f - fff <- sim$ei2 - fff <- sim$co3 - sim$co1 <- 123 - xx <- c(1,2) - xx[sim$ei4] <- NA - ", - xxx1[[1]][(lineWithInit + 1):lineWithDotInputObjects], " - a <- sim$b - sim$g <- 1 - sim$ei1 <- 4 - fff <- sim$ei1 - fff <- sim$co3 - sim$co1 <- 123 - ", - xxx1[[1]][(lineWithDotInputObjects + 1):length(xxx1[[1]])], - sep = "\n", fill = FALSE, file = fileNames[1]) - - - cat(xxx1[[2]][1:(lineWithInputObjects - 1)], " - expectsInput('ei1', 'numeric', '', ''), - expectsInput('ei4', 'numeric', '', '') - ", - xxx1[[2]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " - createsOutput('co1', 'numeric', ''), - createsOutput('co4', 'numeric', '') - ", - xxx1[[2]][(lineWithInputObjects + 1):lineWithInit], " - a <- sim$b - xx <- c(1,2) - xx[sim$ei4] <- NA - ", - xxx1[[2]][(lineWithInit + 1):lineWithDotInputObjects], " - a <- sim$b - sim$co1 <- 123 - ", - xxx1[[2]][(lineWithDotInputObjects + 1):length(xxx1[[2]])], - sep = "\n", fill = FALSE, file = fileNames[2]) - - fullMessage <- c( - # "defineParameter: 'plotInitialTime' is not of specified type 'character'", - "defineParameter: 'saveInitialTime' is not of specified type 'character'", - "Running .inputObjects for test", - "test: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", - "test: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", - "test: module code: ei3 is declared in metadata inputObjects, but is not used in the module", - "test: module code: .inputObjects: local variable.*a.*assigned but may not be used", - "test: module code: .inputObjects: local variable.*fff.*assigned but may not be used", - "test: module code: Init: local variable.*a.*assigned but may not be used", - "test: module code: Init: local variable.*fff.*assigned but may not be used", - "test: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", - "test: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", - "test: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", - "test: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects", - # "defineParameter: 'plotInitialTime' is not of specified type 'character'", - "Running .inputObjects for test2", - "test2: module code: co1, co4 are declared in metadata outputObjects, but are not assigned in the module", - "test2: module code: ei1, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", - "test2: module code: ei1 is declared in metadata inputObjects, but is not used in the module", - "test2: module code: .inputObjects: local variable.*a.*assigned but may not be used", - "test2: module code: Init: local variable.*a.*assigned but may not be used", - "test2: inputObjects: co1 is assigned to sim inside .inputObjects, but is not declared in metadata inputObjects", - "test2: inputObjects: b is used from sim inside Init, but is not declared in metadata inputObjects", - "test2: inputObjects: b is used from sim inside .inputObjects, but is not declared in metadata inputObjects", - # "defineParameter: 'plotInitialTime' is not of specified type 'character'", - "defineParameter: 'hello' is not of specified type 'character'", - "Running .inputObjects for test3", - "test3: module code appears clean", - "Running .inputObjects for test4", - "test4: module code appears clean" - ) - - for (y in 3:4) { - cat(xxx1[[y]], sep = "\n", fill = FALSE, file = fileNames[y]) - } - withr::local_options(spades.allowInitDuringSimInit = FALSE) - mm1 <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) - mm1 <- cleanMessage(mm1) - expect_true(all(unlist(lapply(fullMessage, - function(x) any(grepl(mm1, pattern = x)))))) - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) - mm <- cleanMessage(mm) -}) - -test_that("Module code checking -- pipe with matrix product with backtick & data.table", { - testInit("ggplot2", smcc = TRUE) - - m <- "child4" - newModule(m, tmpdir, open = FALSE) - fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" - xxx <- readLines(fileName) - lineWithInit <- grep(xxx, pattern = "^Init") - xxx1 <- xxx - cat(xxx[1:lineWithInit], " - checksums1 <- structure(list(result = c('OK', 'OK'), - expectedFile = c('Land_Cover_2010_TIFF.zip','NA_LandCover_2010_25haMMU.tif'), - actualFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif'), - checksum.x = c('f4f647d11f5ce109', '6b74878f59de5ea9'), - checksum.y = c('f4f647d11f5ce109', '6b74878f59de5ea9'), - algorithm.x = c('xxhash64', 'xxhash64'), - algorithm.y = c('xxhash64', 'xxhash64'), - renamed = c(NA, NA), - module = c('simplifyLCCVeg', 'simplifyLCCVeg')), - .Names = c('result', 'expectedFile', 'actualFile', - 'checksum.x', 'checksum.y', 'algorithm.x', 'algorithm.y', 'renamed', - 'module'), - row.names = c(NA, -2L), - class = c('grouped_df', 'tbl_df', 'tbl', 'data.frame'), - vars = 'expectedFile', - indices = list(0L, 1L), - group_sizes = c(1L, 1L), - biggest_group_size = 1L, - labels = structure(list(expectedFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif')), - .Names = 'expectedFile', - row.names = c(NA, -2L), - class = 'data.frame', vars = 'expectedFile')) - - result1 <- checksums1[checksums1$expectedFile == 'NA_LandCover_2010_25haMMU.tif',]$result - - sim$bvcx <- matrix(1:2) %>% `%*%` (2:3) - sim$bvcx2 <- matrix(1:2) %>% \"%*%\" (2:3) - sim$b <- matrix(1:2) %>% t() - - sim$a <- 1 - ", - xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) - - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - mm <- cleanMessage(mm) - - fullMessage1 <- c( - "Running .inputObjects for child4", - "child4: module code: Init: local variable.*result1.*assigned but may not be used ", - "child4: outputObjects: bvcx, bvcx2, b, a are assigned to sim inside Init, but are not declared in metadata outputObjects") - fullMessageNonInteractive <- c( - "Running .inputObjects for child4", - "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx <- matrix.*", #possibly at .*147", - "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx2 <- matrix.*", #possibly at .*148", - "child4: module code: Init: local variable.*result1.*assigned but may not be used", - "child4: outputObjects: b, a are assigned to sim inside Init, but are not declared in metadata outputObjects" - ) - test1 <- all(unlist(lapply(fullMessage1, function(x) any(grepl(mm, pattern = x))))) - test2 <- all(unlist(lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x))))) - # if (grepl( "emcintir", Sys.info()["user"])) { - # tmpFilename = "c:/Eliot/tmp/test1.txt" - # - # cat("################### test1\n", file = tmpFilename, append = FALSE) - # cat(paste(collapse = " ", lapply(fullMessage1, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) - # cat("\n################### test2\n", file = tmpFilename, append = TRUE) - # cat(paste(collapse = " ", lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) - # cat("\n################### fullMessage1\n", file = tmpFilename, append = TRUE) - # cat(paste(collapse = "\n", fullMessage1), file = tmpFilename, append = TRUE) - # cat("\n################### fullMessageNonInteractive\n", file = tmpFilename, append = TRUE) - # cat(paste(collapse = "\n", fullMessageNonInteractive), file = tmpFilename, append = TRUE) - # cat("\n################### mm\n", file = tmpFilename, append = TRUE) - # cat(paste(collapse = "\n", mm), file = tmpFilename, append = TRUE) - # } - expect_true(test1 || test2) -}) - -test_that("simInitAndSpades", { - - testInit(sampleModReqdPkgs) - - set.seed(42) - - times <- list(start = 0.0, end = 0, timeunit = "year") - params <- list( - .globals = list(burnStats = "npixelsburned", stackName = "landscape"), - randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), - caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), - fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) - ) - modules <- list("randomLandscapes", "caribouMovement", "fireSpread") - paths <- list(modulePath = getSampleModules(tmpdir)) - set.seed(123) - mySim <- simInitAndSpades(times = times, params = params, - modules = modules, objects = list(), paths = paths, debug = FALSE) - - set.seed(123) - mySim2 <- simInit(times = times, params = params, - modules = modules, objects = list(), paths = paths) |> - spades(debug = FALSE) - - expect_true(all.equal(mySim, mySim2)) - -}) - -test_that("scheduleEvent with invalid values for eventTime", { - testInit() - s <- simInit(times = list(start = 1, end = 10)) - expect_error({ - s <- scheduleEvent(s, eventTime = -1, eventType = "test1", moduleName = "test") - }) - expect_warning({ - s <- scheduleEvent(s, eventTime = numeric(), eventType = "test1", moduleName = "test") - }) - expect_error({ - s <- scheduleEvent(s, eventTime = 0, eventType = "test1", moduleName = "test") - }) -}) - -test_that("debug using logging", { - - testInit(c(sampleModReqdPkgs, "logging"), tmpFileExt = "log") - - set.seed(42) - - times <- list(start = 0.0, end = 1, timeunit = "year") - params <- list( - .globals = list(burnStats = "npixelsburned", stackName = "landscape"), - randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA, .useCache = "init"), - caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), - fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) - ) - modules <- list("randomLandscapes") - paths <- list(modulePath = getSampleModules(tmpdir)) - - set.seed(123) - mySim <- simInit(times, params, modules, objects = list(), paths) #|> - logging::logReset() - unlink(tmpfile) - expect_false(file.exists(tmpfile)) - mess1 <- capture_messages({ - mess2 <- capture.output(type = "output", { - mySim2 <- spades(Copy(mySim), - debug = list("console" = list(level = 10), debug = 1), - .plotInitialTime = NA) - }) - }) - expect_false(any(grepl("total elpsd", mess1))) # using new mechanism console - expect_true(any(grepl("total elpsd", mess2))) - expect_true(any(grepl(Sys.Date(), mess2))) # the loginfo does have date - expect_false(any(grepl(Sys.Date(), mess1))) # original debug has date added - - logging::logReset() - mess1 <- capture_messages({ - mess2 <- capture.output(type = "output", { - mySim2 <- spades(Copy(mySim), - debug = list("console" = list(level = 5), - "file" = list(file = tmpfile), - debug = 1), - .plotInitialTime = NA) - }) - }) - - expect_true(file.exists(tmpfile)) - log1 <- readLines(tmpfile) - expect_true(any(grepl("total elpsd", log1))) - expect_true(any(grepl(Sys.Date(), log1))) - expect_false(any(grepl("total elpsd", mess1))) # messages not produced with debug as list - unlink(tmpfile) - - logging::logReset() - mess1 <- capture_messages({ - mess2 <- capture.output(type = "output", { - mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) - }) - }) - expect_false(file.exists(tmpfile)) - expect_true(length(mess2) == 0) - expect_true(any(grepl("total elpsd", mess1))) - expect_true(any(grepl(format(Sys.Date(), "%h%d"), mess1))) # the straight messages don't have date - - # Test whether suppressMessages works - mess1 <- capture_messages({ - mess2 <- capture.output(type = "output", { - suppressMessages({ - mySim2 <- spades(Copy(mySim), - debug = list("console" = list(level = "INFO"), debug = 1), - .plotInitialTime = NA) - }) - }) - }) - expect_true(length(mess1) == 0) - - # Test whether suppressMessages works - mess1 <- capture_messages({ - mess2 <- capture.output(type = "output", { - suppressMessages({ - mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) - }) - }) - }) - expect_true(length(mess1) == 0) -}) +# test_that("spades calls - diff't signatures", { +# testInit(sampleModReqdPkgs, verbose = TRUE) +# +# a <- simInit() +# a1 <- Copy(a) +# opts <- options(spades.saveSimOnExit = FALSE) +# expect_message(spades(a, debug = TRUE), "eventTime") +# expect_silent(expect_message(spades(a, debug = FALSE), "DTthreads")) +# expect_silent(expect_message(spades(a, debug = FALSE, .plotInitialTime = NA), "DTthreads")) +# expect_silent(expect_message(spades(a, debug = FALSE, .saveInitialTime = NA), "DTthreads")) +# opts <- options(opts) +# expect_message(spades(a, debug = TRUE, .plotInitialTime = NA), "eventTime") +# expect_message(spades(a, debug = TRUE, .saveInitialTime = NA), "eventTime") +# expect_equivalent(capture_output(spades(a, debug = "current", .plotInitialTime = NA)), +# capture_output(spades(a, debug = TRUE, .plotInitialTime = NA))) +# +# if (requireNamespace("logging", quietly = TRUE)) { +# expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), +# "eventTime *moduleName *eventType *eventPriority") +# } else { +# expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), +# "eventTime *moduleName *eventType *eventPriority") +# } +# expect_message(spades(a, debug = c("current", "events"), .plotInitialTime = NA), "moduleName") +# expect_message(spades(a, debug = "simList", .plotInitialTime = NA), "Completed Events") +# +# if (interactive()) { +# # warnings occur on Rstudio-server related to can't use display 0:, when using devtools::test() interactively +# suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "10%")) +# suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "20%")) +# suppressWarnings(expect_output(spades(a, progress = "text"), "..........| 100%")) +# } +# opts <- options(spades.saveSimOnExit = FALSE) +# expect_silent(expect_message(spades(a, debug = FALSE, progress = FALSE), "DTthreads")) +# expect_silent(expect_message(spades(a, debug = FALSE, progress = "rr"), "DTthreads")) +# opts <- options(opts) +# +# paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) +# a <- Copy(a1) +# expect_message(spades(a, cache = TRUE, debug = TRUE, notOlderThan = Sys.time()), "eventTime") +# expect_true(all(basename2(c(CacheDBFile(paths(a)$cachePath), CacheStorageDir(paths(a)$cachePath))) %in% +# dir(paths(a)$cachePath))) +# file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) +# +# # test for system time ... in this case, the first time through loop is slow +# # because of writing cache to disk, not because of spades being slow. +# # simList is empty. +# +# set.seed(42) +# +# times <- list(start = 0.0, end = 0, timeunit = "year") +# params <- list( +# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), +# randomLandscapes = list(nx = 20, ny = 20) +# ) +# modules <- list("randomLandscapes", "fireSpread") +# paths <- list(modulePath = getSampleModules(tmpdir)) +# +# for (i in 1:2) { +# a <- simInit(times, params, modules, paths = paths) +# paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) +# assign(paste0("st", i), system.time(spades(a, cache = TRUE, .plotInitialTime = NA))) +# } +# params1 <- list( +# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), +# randomLandscapes = c(nx = 20, ny = 20) +# ) +# expect_error({ a <- simInit(times, params1, modules, paths = paths) }) +# expect_error({ a <- simInit(list(3, "a", "s"), params, modules, paths = paths) }) +# err <- capture_error({ +# a <- simInit(list(3, "years", start = 1), params, modules, paths = paths) +# }) +# expect_true(is.null(err)) +# +# #expect_gt(st1[1], st2[1]) ## no longer true on R >= 3.5.1 ?? +# file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) +# }) +# +# test_that("simInit with R subfolder scripts", { +# skip_if_not_installed("NLMR") +# +# testInit() +# +# newModule("child1", ".", open = FALSE) +# cat(file = file.path("child1", "R", "script.R"), +# "a <- function(poiuoiu) { +# poiuoiu + 1 +# }", sep = "\n") +# mySim <- simInit(modules = "child1", paths = list(modulePath = tmpdir)) +# expect_true(sum(grepl(unlist(lapply(ls(mySim@.xData$.mods, all.names = TRUE), function(x) { +# if (is.environment(mySim@.xData$.mods[[x]])) ls(envir = mySim@.xData$.mods[[x]], all.names = TRUE) +# })), pattern = "^a$")) == 1) +# expect_true(mySim@.xData$.mods$child1$a(2) == 3) # Fns +# }) +# +# test_that("simulation runs with simInit with duplicate modules named", { +# testInit(sampleModReqdPkgs) +# +# set.seed(42) +# +# times <- list(start = 0.0, end = 10, timeunit = "year") +# params <- list( +# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), +# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE) +# ) +# modules <- list("randomLandscapes", "randomLandscapes", "caribouMovement") +# paths <- list(modulePath = getSampleModules(tmpdir)) +# +# expect_true(any(grepl(capture_messages({ +# mySim <- simInit(times, params, modules, objects = list(), paths) +# }), pattern = "Duplicate module"))) +# expect_true(length(modules(mySim)) != length(modules)) +# expect_true(length(modules(mySim)) == length(unique(modules))) +# }) +# +# test_that("simulation runs with simInit with duplicate modules named", { +# skip("benchmarking DES") +# +# testInit() +# +# 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), +# childModules = character(0), +# version = list(SpaDES.core = "0.1.0", test = "0.0.1"), +# spatialExtent = terra::ext(rep(0, 4)), +# timeframe = as.POSIXlt(c(NA, NA)), +# timeunit = "second", +# citation = list("citation.bib"), +# documentation = list("README.md", "test.Rmd"), +# reqdPkgs = list(), +# parameters = rbind( +# ), +# inputObjects = bindrows( +# ), +# outputObjects = bindrows( +# ) +# )) +# +# doEvent.test = function(sim, eventTime, eventType, debug = FALSE) { +# switch( +# eventType, +# init = { +# 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), +# childModules = character(0), +# version = list(SpaDES.core = "0.1.0", test2 = "0.0.1"), +# spatialExtent = terra::ext(rep(0, 4)), +# timeframe = as.POSIXlt(c(NA, NA)), +# timeunit = "second", +# citation = list("citation.bib"), +# documentation = list("README.md", "test2.Rmd"), +# reqdPkgs = list(), +# parameters = rbind( +# ), +# inputObjects = bindrows( +# ), +# outputObjects = bindrows( +# ) +# )) +# +# doEvent.test2 = function(sim, eventTime, eventType, debug = FALSE) { +# switch( +# eventType, +# init = { +# sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) +# }, +# event1 = { +# sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) +# }) +# return(invisible(sim)) +# } +# ', fill = TRUE) +# +# N <- 5000 +# +# moduleDir <- file.path(tmpdir) +# inputDir <- file.path(moduleDir, "inputs") |> checkPath(create = TRUE) +# outputDir <- file.path(moduleDir, "outputs") +# cacheDir <- file.path(outputDir, "cache") +# times <- list(start = 0, end = N) +# parameters <- list( +# ) +# modules <- list("test") +# objects <- list() +# paths <- list( +# cachePath = cacheDir, +# modulePath = moduleDir, +# inputPath = inputDir, +# outputPath = outputDir +# ) +# +# #options("spades.nCompleted" = 500) +# mySim <- simInit(times = times, params = parameters, modules = modules, +# objects = objects, paths = paths) +# +# nTimes <- 20 +# +# ####################### +# # Tested on laptop +# ####################### +# # laptop was 10.2 seconds -- currently 4.2 seconds or so --> June 29, 2018 is 1.06 seconds +# # laptop New with "seconds" -- Sept 21, 2018 is 0.492 seconds --> 98 microseconds/event +# # laptop New with "seconds" -- Nov 26, 2018 is 0.458 seconds --> 92 microseconds/event! +# # Windows Desktop -- slower -- Nov 26, 2018 0.730 Seconds --> 148 microseconds/event! +# # Linux Server -- slower -- Nov 26, 2018 0.795 Seconds --> 159 microseconds/event! +# # BorealCloud Server -- slower -- Nov 26, 2018 0.972 Seconds --> 194 microseconds/event! +# # laptop -- May 25, 2019 0.603 Seconds --> 120 microseconds/event! +# # laptop with new completed as environment -- May 25, 2019 0.357 Seconds --> 71 microseconds/event! +# options("spades.keepCompleted" = TRUE) +# # microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)}) +# # +# # # Turn off completed list +# # # Changed to use "seconds" -- better comparison with simple loop +# # # Old times using "year" -- June 29, 2018 is 0.775 seconds, Sept 19, 2018 0.809 seconds +# # # -- This is 161 microseconds per event +# # # New times using "second" -- Sept 19, 2018 0.244 Seconds --> 49 microseconds/event +# # # New times using "second" -- Nov 26, 2018 0.192 Seconds --> 38 microseconds/event! +# # # Windows Desktop -- slower -- Nov 26, 2018 0.348 Seconds --> 70 microseconds/event! +# # # Linux Server -- slower -- Nov 26, 2018 0.461 Seconds --> 92 microseconds/event! +# # # BorealCloud Server -- slower -- Nov 26, 2018 0.282 Seconds --> 56 microseconds/event! +# # # With many new "exists" +# # # laptop -- May 25, 2019 0.264 Seconds --> 53 microseconds/event! +# # options("spades.keepCompleted" = FALSE) +# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) +# # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) +# # +# # a <- 0 +# # a3 <- microbenchmark::microbenchmark( +# # for (i in 1:N) { +# # a <- a + 1 +# # } +# # ) +# # +# # summary(a2)[, "median"]/summary(a3)[, "median"] +# # +# # ######################################## +# # # With 2 modules, therefore sorting +# # ######################################## +# # modules <- list("test", "test2") +# # mySim <- simInit(times = times, params = parameters, modules = modules, +# # objects = objects, paths = paths) +# # +# # nTimes <- 10 +# # # Turn off completed list +# # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 59 microseconds/event, even with sorting +# # options("spades.keepCompleted" = FALSE) +# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) +# # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) +# # +# # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 130 microseconds/event, even with sorting +# # options("spades.keepCompleted" = TRUE) +# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) +# }) +# +# test_that("conflicting function types", { +# testInit(sampleModReqdPkgs, smcc = TRUE) +# +# m <- "child4" +# newModule(m, tmpdir, open = FALSE) +# fileName <- file.path(m, paste0(m, ".R")) # child4/child4.R" +# xxx <- readLines(fileName) +# lineWithInit <- grep(xxx, pattern = "^Init") +# +# xxx1 <- gsub(xxx, pattern = 'plotFun', replacement = 'Plot') # nolint +# cat(xxx1, file = fileName, sep = "\n") +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "Plot is defined") +# +# # do functions like raster::levels +# cat(xxx[1:lineWithInit], " +# library(raster) +# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) +# poiuoiu <- poiuoiu +# poiuoiu <- scale(poiuoiu) +# poiuoiu <- ratify(poiuoiu) +# rat <- raster::levels(poiuoiu)[[1]] +# +# levels(poiuoiu) <- rat +# ", +# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) +# +# fullMessage <- c("the following function\\(s\\) is used that", "raster::scale", "scale") +# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) +# nonMessage <- c("raster::levels", "levels") +# expect_false(all(unlist(lapply(nonMessage, function(x) any(grepl(mm, pattern = x)))))) +# +# cat(xxx[1:lineWithInit], " +# library(raster) +# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) +# poiuoiu <- scale(poiuoiu) +# ", +# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "raster::scale") +# +# cat(xxx[1:lineWithInit], " +# library(raster) +# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) +# poiuoiu <- raster::scale(poiuoiu) +# sim$poiuoiu <- poiuoiu +# ", +# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "poiuoiu is assigned") +# +# cat(xxx[1:(lineWithInit - 1)], " +# a <- function(x) { +# b <- b + 1 +# } +# ", +# xxx[(lineWithInit):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "a: parameter") +# +# xxx1 <- gsub(xxx, pattern = "\\.plotInitialTime", replacement = "value") +# xxx1 <- gsub(xxx1, pattern = "NA, NA, NA", replacement = "'hi', NA, NA") +# +# cat(xxx1[1:lineWithInit], " +# a <- sim$b +# d <- sim$d +# f <- sim[['f']] +# f <- sim[[P(sim)$value]] +# poiuoiu <- sim@.xData$d1 +# qwerqwer <- sim@.xData[['test']] +# sim$g <- f +# sim@.xData$g1 <- f +# return(list(a, d, f, sim)) +# ", +# xxx1[(lineWithInit + 1):length(xxx1)], sep = "\n", fill = FALSE, file = fileName) +# +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) +# +# fullMessage <- c(# "defineParameter: 'value' is not of specified type 'numeric'", +# "defineParameter: 'plotInterval' is not of specified type 'numeric'", +# "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", +# "defineParameter: 'saveInterval' is not of specified type 'numeric'", +# "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", +# "Running .inputObjects for child4", +# "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", +# "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", +# "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" +# ) +# +# mm <- cleanMessage(mm) +# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) +# +# cat(xxx[1:lineWithInit], " +# sim$child4 <- 1 +# ", +# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_error(simInit(paths = list(modulePath = tmpdir), modules = m), +# c(paste0(m, ": You have created an object"))) +# +# # declared in metadata inputObjects +# lineWithInputObjects <- grep(xxx, pattern = " expectsInput") +# cat(xxx[1:(lineWithInputObjects - 1)], " +# expectsInput('a', 'numeric', '', '') +# ", +# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), +# c(paste0(m, ": module code: a is declared in metadata inputObjects"))) +# +# # declared in metadata outputObjects +# lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") +# cat(xxx[1:(lineWithOutputObjects - 1)], " +# createsOutput('b', 'numeric', '') +# ", +# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), +# c(paste0(m, ": module code: b is declared in metadata outputObjects"))) +# +# cat(xxx[1:(lineWithInputObjects - 1)], " +# expectsInput('a', 'numeric', '', '') +# ", +# xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], +# " +# createsOutput('b', 'numeric', '') +# ", +# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) +# expect_true(all(grepl(mm, +# pattern = c(paste0(m, ": module code: b is declared in metadata outputObjects|", +# "so not checking minimum package|", +# m, ": module code: a is declared in metadata inputObjects|", +# "Running .inputObjects|", +# "Setting:|Paths set to:|", +# "Using setDTthreads|", +# m, ": using dataPath|", "Elapsed"))))) +# +# # assign to sim for functions like scheduleEvent +# lineWithScheduleEvent <- grep(xxx, pattern = "scheduleEvent")[1] +# xxx1 <- xxx +# xxx1[lineWithScheduleEvent] <- sub(xxx[lineWithScheduleEvent], pattern = "sim <- scheduleEvent", +# replacement = "scheduleEvent") +# cat(xxx1, sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), +# c(paste0(m, ": module code: scheduleEvent inside doEvent.child4 must"))) +# +# # Return sim in doEvent +# patt <- "return\\(invisible\\(sim\\)\\)" +# lineWithReturnSim <- grep(xxx, pattern = patt)[1] +# xxx1 <- xxx +# xxx1[lineWithReturnSim] <- sub(xxx[lineWithReturnSim], pattern = patt, +# replacement = "return(invisible())") +# cat(xxx1, sep = "\n", fill = FALSE, file = fileName) +# +# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), +# c(paste0(m, ": module code: doEvent.", m, " must return"))) +# +# lineWithInputObjects <- grep(xxx, pattern = " expectsInput") +# lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") +# lineWithDotInputObjects <- grep(xxx, pattern = "\\.inputObjects")[1] +# cat(xxx[1:(lineWithInputObjects - 1)], " +# expectsInput('ei1', 'numeric', desc = 'This is a test with spaces +# and EOL', ''), +# expectsInput('ei2', 'numeric', '', ''), +# expectsInput('ei3', 'numeric', '', ''), +# expectsInput('ei4', 'numeric', '', 'test.com') +# ", +# xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " +# createsOutput('co1', 'numeric', ''), +# createsOutput('co2', 'numeric', desc = 'This is a test with spaces +# and EOL on the createsOutputs'), +# createsOutput('co3', 'numeric', ''), +# createsOutput('co4', 'numeric', '') +# ", +# xxx[(lineWithOutputObjects + 1):lineWithInit], " +# a <- sim$b +# sim$g <- f +# holy(sim$co4) <- f +# moly(sim$aaa) <- f +# fff <- sim$ei2 +# fff <- sim$co3 +# sim$co1 <- 123 +# xx <- c(1,2) +# xx[sim$ei4] <- NA +# ", +# xxx[(lineWithInit + 1):lineWithDotInputObjects], " +# a <- sim$b +# url1 <- extractURL('ei4') +# if (!identical(url1, 'test.com')) +# stop('extractURL without sim or module fails') +# url1 <- extractURL('ei4', sim = sim) +# if (!identical(url1, 'test.com')) +# stop('extractURL without module fails')", +# paste0(" url1 <- extractURL('ei4', sim = sim, module = \"", m, "\")") ," +# if (!identical(url1, 'test.com')) +# stop('extractURL fails') +# sim$g <- 1 +# sim$ei1 <- 4 +# fff <- sim$ei1 +# fff <- sim$co3 +# sim$co1 <- 123 +# aaa <- sim$.userSuppliedObjNames # in the ignoreObjects +# ", +# xxx[(lineWithDotInputObjects + 1):length(xxx)], +# sep = "\n", fill = FALSE, file = fileName) +# +# fullMessage <- c( +# "Running .inputObjects for child4", +# "child4: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", +# "child4: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", +# "child4: module code: ei3 is declared in metadata inputObjects, but is not used in the module", +# "child4: module code: .inputObjects: local variable.*a.*assigned but may not be used", +# "child4: module code: .inputObjects: local variable.*fff.*assigned but may not be used", +# "child4: module code: Init: local variable.*a.*assigned but may not be used", +# "child4: module code: Init: local variable.*fff.*assigned but may not be used", +# "child4: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", +# "child4: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", +# "child4: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", +# "child4: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects" +# ) +# +# # Test moduleMetadata without `sim` and where there is a `sim` in the module metadata, +# # so needs to load it. A non-error is good enough for now. +# md1 <- moduleMetadata(module = m, path = tmpdir) # no sim in metadata +# md2 <- moduleMetadata(path = getSampleModules(tmpdir), +# module = "randomLandscapes") +# +# +# mm <- capture_messages({ +# mySim <- simInit(paths = list(modulePath = tmpdir), modules = m) +# }) +# mm <- cleanMessage(mm) +# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) +# +# x1 <- moduleMetadata(mySim) +# sns <- slotNames(mySim@depends@dependencies[[m]]) +# names(sns) <- sns +# x2 <- lapply(sns, function(sn) { +# slot(mySim@depends@dependencies[[m]], sn) +# }) +# +# # Now extra spaces are removed automatically on load ######################## +# +# # When there are more than a certain number of characters, a hidden \n gets inserted +# # Our metadata in tests is close to that, and some push past. No point diagnosing further. Accept 1 "TRUE" +# expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) +# x2 <- rmExtraSpacesEOLList(x2) +# expect_true(sum(unlist(lapply(x1, function(v) grepl(" |\n", v)))) <= 1) +# expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) +# +# x1 <- moduleParams(m, dirname(dirname(fileName))) +# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) +# x1 <- moduleInputs(m, dirname(dirname(fileName))) +# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) +# x1 <- moduleOutputs(m, dirname(dirname(fileName))) +# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) +# }) +# +# test_that("scheduleEvent with NA logical in a non-standard parameter", { +# testInit("ggplot2", smcc = TRUE) +# m <- "test" +# newModule(m, tmpdir, open = FALSE) +# fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" +# xxx <- readLines(fileName) +# #lineWithInit <- grep(xxx, pattern = "^Init") +# +# xxx1 <- gsub(xxx, pattern = '.plotInitialTime', replacement = '.plotInitialTim') # nolint +# xxx2a <- grep(".plotInitialTim\\>", xxx1, value = TRUE)[1] +# xxx2b <- gsub(",$", grep("time interval between plot", xxx1, value = TRUE), replacement = "") +# xxx3 <- parse(text = paste(xxx2a, xxx2b)) +# # show that it is logical +# sim <- simInit(times = list(start = 0, end = 2)) +# expect_true(is.numeric(eval(xxx3)$default[[1]])) +# +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) +# expect_true(all(unlist(lapply(c("Running .inputObjects", "module code appears clean"), +# function(x) any(grepl(mm, pattern = x)))))) +# }) +# +# test_that("messaging with multiple modules", { +# testInit("ggplot2", smcc = TRUE) +# +# m1 <- "test" +# m2 <- "test2" +# m3 <- "test3" +# m4 <- "test4" +# m <- c(m1, m2, m3, m4) +# newModule(m1, tmpdir, open = FALSE) +# newModule(m2, tmpdir, open = FALSE) +# newModule(m3, tmpdir, open = FALSE) +# newModule(m4, tmpdir, open = FALSE) +# #lapply(m, newModule, tmpdir, open = FALSE) +# fileNames <- file.path(tmpdir, m, paste0(m, ".R")) +# xxx <- lapply(fileNames, readLines) +# set.seed(113) +# +# lineWithInit <- grep(xxx[[1]], pattern = "^Init") +# lineWithInputObjects <- grep(xxx[[1]], pattern = " expectsInput") +# lineWithOutputObjects <- grep(xxx[[1]], pattern = " createsOutput") +# lineWithDotInputObjects <- grep(xxx[[1]], pattern = "\\.inputObjects")[1] +# +# xxx1 <- list() +# #lapply(seq(m), function(yy) sample(c("character", "numeric", "logical"), size = 3, replace = TRUE)) +# xxx1[[1]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", +# "\\.plotInitialTime\", \"character\", 1", xxx[[1]]) +# xxx1[[1]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", +# "\\.saveInitialTime\", \"character\", FALSE", xxx1[[1]]) +# xxx1[[1]] <- gsub("\\.saveInterval\", \"numeric\", NA", +# "\\testtime\", \"logical\", NA_real_", xxx1[[1]]) +# +# xxx1[[2]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", +# "\\.plotInitialTime\", \"character\", TRUE", xxx[[2]]) +# xxx1[[2]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", +# "\\.saveInitialTime\", \"character\", 'c'", xxx1[[2]]) +# xxx1[[2]] <- gsub("\\.saveInterval\", \"numeric\", NA", +# "\\testtime\", \"character\", NA_real_", xxx1[[2]]) +# +# xxx1[[3]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", +# "\\.plotInitialTime\", \"character\", 1", xxx[[3]]) +# xxx1[[3]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", +# "\\hello\", \"character\", 1", xxx1[[3]]) +# xxx1[[3]] <- gsub("\\.saveInterval\", \"numeric\", NA", +# "\\testtime\", \"logical\", NA_real_", xxx1[[3]]) +# xxx1[[4]] <- xxx[[4]] # clean one +# +# cat(xxx1[[1]][1:(lineWithInputObjects - 1)], " +# expectsInput('ei1', 'numeric', '', ''), +# expectsInput('ei2', 'numeric', '', ''), +# expectsInput('ei3', 'numeric', '', ''), +# expectsInput('ei4', 'numeric', '', '') +# ", +# xxx1[[1]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " +# createsOutput('co1', 'numeric', ''), +# createsOutput('co2', 'numeric', ''), +# createsOutput('co3', 'numeric', ''), +# createsOutput('co4', 'numeric', '') +# ", +# xxx1[[1]][(lineWithInputObjects + 1):lineWithInit], " +# a <- sim$b +# sim$g <- f +# holy(sim$co4) <- f +# moly(sim$aaa) <- f +# fff <- sim$ei2 +# fff <- sim$co3 +# sim$co1 <- 123 +# xx <- c(1,2) +# xx[sim$ei4] <- NA +# ", +# xxx1[[1]][(lineWithInit + 1):lineWithDotInputObjects], " +# a <- sim$b +# sim$g <- 1 +# sim$ei1 <- 4 +# fff <- sim$ei1 +# fff <- sim$co3 +# sim$co1 <- 123 +# ", +# xxx1[[1]][(lineWithDotInputObjects + 1):length(xxx1[[1]])], +# sep = "\n", fill = FALSE, file = fileNames[1]) +# +# +# cat(xxx1[[2]][1:(lineWithInputObjects - 1)], " +# expectsInput('ei1', 'numeric', '', ''), +# expectsInput('ei4', 'numeric', '', '') +# ", +# xxx1[[2]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " +# createsOutput('co1', 'numeric', ''), +# createsOutput('co4', 'numeric', '') +# ", +# xxx1[[2]][(lineWithInputObjects + 1):lineWithInit], " +# a <- sim$b +# xx <- c(1,2) +# xx[sim$ei4] <- NA +# ", +# xxx1[[2]][(lineWithInit + 1):lineWithDotInputObjects], " +# a <- sim$b +# sim$co1 <- 123 +# ", +# xxx1[[2]][(lineWithDotInputObjects + 1):length(xxx1[[2]])], +# sep = "\n", fill = FALSE, file = fileNames[2]) +# +# fullMessage <- c( +# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", +# "defineParameter: 'saveInitialTime' is not of specified type 'character'", +# "Running .inputObjects for test", +# "test: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", +# "test: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", +# "test: module code: ei3 is declared in metadata inputObjects, but is not used in the module", +# "test: module code: .inputObjects: local variable.*a.*assigned but may not be used", +# "test: module code: .inputObjects: local variable.*fff.*assigned but may not be used", +# "test: module code: Init: local variable.*a.*assigned but may not be used", +# "test: module code: Init: local variable.*fff.*assigned but may not be used", +# "test: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", +# "test: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", +# "test: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", +# "test: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects", +# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", +# "Running .inputObjects for test2", +# "test2: module code: co1, co4 are declared in metadata outputObjects, but are not assigned in the module", +# "test2: module code: ei1, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", +# "test2: module code: ei1 is declared in metadata inputObjects, but is not used in the module", +# "test2: module code: .inputObjects: local variable.*a.*assigned but may not be used", +# "test2: module code: Init: local variable.*a.*assigned but may not be used", +# "test2: inputObjects: co1 is assigned to sim inside .inputObjects, but is not declared in metadata inputObjects", +# "test2: inputObjects: b is used from sim inside Init, but is not declared in metadata inputObjects", +# "test2: inputObjects: b is used from sim inside .inputObjects, but is not declared in metadata inputObjects", +# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", +# "defineParameter: 'hello' is not of specified type 'character'", +# "Running .inputObjects for test3", +# "test3: module code appears clean", +# "Running .inputObjects for test4", +# "test4: module code appears clean" +# ) +# +# for (y in 3:4) { +# cat(xxx1[[y]], sep = "\n", fill = FALSE, file = fileNames[y]) +# } +# withr::local_options(spades.allowInitDuringSimInit = FALSE) +# mm1 <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) +# mm1 <- cleanMessage(mm1) +# expect_true(all(unlist(lapply(fullMessage, +# function(x) any(grepl(mm1, pattern = x)))))) +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) +# mm <- cleanMessage(mm) +# }) +# +# test_that("Module code checking -- pipe with matrix product with backtick & data.table", { +# testInit("ggplot2", smcc = TRUE) +# +# m <- "child4" +# newModule(m, tmpdir, open = FALSE) +# fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" +# xxx <- readLines(fileName) +# lineWithInit <- grep(xxx, pattern = "^Init") +# xxx1 <- xxx +# cat(xxx[1:lineWithInit], " +# checksums1 <- structure(list(result = c('OK', 'OK'), +# expectedFile = c('Land_Cover_2010_TIFF.zip','NA_LandCover_2010_25haMMU.tif'), +# actualFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif'), +# checksum.x = c('f4f647d11f5ce109', '6b74878f59de5ea9'), +# checksum.y = c('f4f647d11f5ce109', '6b74878f59de5ea9'), +# algorithm.x = c('xxhash64', 'xxhash64'), +# algorithm.y = c('xxhash64', 'xxhash64'), +# renamed = c(NA, NA), +# module = c('simplifyLCCVeg', 'simplifyLCCVeg')), +# .Names = c('result', 'expectedFile', 'actualFile', +# 'checksum.x', 'checksum.y', 'algorithm.x', 'algorithm.y', 'renamed', +# 'module'), +# row.names = c(NA, -2L), +# class = c('grouped_df', 'tbl_df', 'tbl', 'data.frame'), +# vars = 'expectedFile', +# indices = list(0L, 1L), +# group_sizes = c(1L, 1L), +# biggest_group_size = 1L, +# labels = structure(list(expectedFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif')), +# .Names = 'expectedFile', +# row.names = c(NA, -2L), +# class = 'data.frame', vars = 'expectedFile')) +# +# result1 <- checksums1[checksums1$expectedFile == 'NA_LandCover_2010_25haMMU.tif',]$result +# +# sim$bvcx <- matrix(1:2) %>% `%*%` (2:3) +# sim$bvcx2 <- matrix(1:2) %>% \"%*%\" (2:3) +# sim$b <- matrix(1:2) %>% t() +# +# sim$a <- 1 +# ", +# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) +# +# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) +# mm <- cleanMessage(mm) +# +# fullMessage1 <- c( +# "Running .inputObjects for child4", +# "child4: module code: Init: local variable.*result1.*assigned but may not be used ", +# "child4: outputObjects: bvcx, bvcx2, b, a are assigned to sim inside Init, but are not declared in metadata outputObjects") +# fullMessageNonInteractive <- c( +# "Running .inputObjects for child4", +# "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx <- matrix.*", #possibly at .*147", +# "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx2 <- matrix.*", #possibly at .*148", +# "child4: module code: Init: local variable.*result1.*assigned but may not be used", +# "child4: outputObjects: b, a are assigned to sim inside Init, but are not declared in metadata outputObjects" +# ) +# test1 <- all(unlist(lapply(fullMessage1, function(x) any(grepl(mm, pattern = x))))) +# test2 <- all(unlist(lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x))))) +# # if (grepl( "emcintir", Sys.info()["user"])) { +# # tmpFilename = "c:/Eliot/tmp/test1.txt" +# # +# # cat("################### test1\n", file = tmpFilename, append = FALSE) +# # cat(paste(collapse = " ", lapply(fullMessage1, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) +# # cat("\n################### test2\n", file = tmpFilename, append = TRUE) +# # cat(paste(collapse = " ", lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) +# # cat("\n################### fullMessage1\n", file = tmpFilename, append = TRUE) +# # cat(paste(collapse = "\n", fullMessage1), file = tmpFilename, append = TRUE) +# # cat("\n################### fullMessageNonInteractive\n", file = tmpFilename, append = TRUE) +# # cat(paste(collapse = "\n", fullMessageNonInteractive), file = tmpFilename, append = TRUE) +# # cat("\n################### mm\n", file = tmpFilename, append = TRUE) +# # cat(paste(collapse = "\n", mm), file = tmpFilename, append = TRUE) +# # } +# expect_true(test1 || test2) +# }) +# +# test_that("simInitAndSpades", { +# +# testInit(sampleModReqdPkgs) +# +# set.seed(42) +# +# times <- list(start = 0.0, end = 0, timeunit = "year") +# params <- list( +# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), +# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), +# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), +# fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) +# ) +# modules <- list("randomLandscapes", "caribouMovement", "fireSpread") +# paths <- list(modulePath = getSampleModules(tmpdir)) +# set.seed(123) +# mySim <- simInitAndSpades(times = times, params = params, +# modules = modules, objects = list(), paths = paths, debug = FALSE) +# +# set.seed(123) +# mySim2 <- simInit(times = times, params = params, +# modules = modules, objects = list(), paths = paths) |> +# spades(debug = FALSE) +# +# expect_true(all.equal(mySim, mySim2)) +# +# }) +# +# test_that("scheduleEvent with invalid values for eventTime", { +# testInit() +# s <- simInit(times = list(start = 1, end = 10)) +# expect_error({ +# s <- scheduleEvent(s, eventTime = -1, eventType = "test1", moduleName = "test") +# }) +# expect_warning({ +# s <- scheduleEvent(s, eventTime = numeric(), eventType = "test1", moduleName = "test") +# }) +# expect_error({ +# s <- scheduleEvent(s, eventTime = 0, eventType = "test1", moduleName = "test") +# }) +# }) +# +# test_that("debug using logging", { +# +# testInit(c(sampleModReqdPkgs, "logging"), tmpFileExt = "log") +# +# set.seed(42) +# +# times <- list(start = 0.0, end = 1, timeunit = "year") +# params <- list( +# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), +# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA, .useCache = "init"), +# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), +# fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) +# ) +# modules <- list("randomLandscapes") +# paths <- list(modulePath = getSampleModules(tmpdir)) +# +# set.seed(123) +# mySim <- simInit(times, params, modules, objects = list(), paths) #|> +# logging::logReset() +# unlink(tmpfile) +# expect_false(file.exists(tmpfile)) +# mess1 <- capture_messages({ +# mess2 <- capture.output(type = "output", { +# mySim2 <- spades(Copy(mySim), +# debug = list("console" = list(level = 10), debug = 1), +# .plotInitialTime = NA) +# }) +# }) +# expect_false(any(grepl("total elpsd", mess1))) # using new mechanism console +# expect_true(any(grepl("total elpsd", mess2))) +# expect_true(any(grepl(Sys.Date(), mess2))) # the loginfo does have date +# expect_false(any(grepl(Sys.Date(), mess1))) # original debug has date added +# +# logging::logReset() +# mess1 <- capture_messages({ +# mess2 <- capture.output(type = "output", { +# mySim2 <- spades(Copy(mySim), +# debug = list("console" = list(level = 5), +# "file" = list(file = tmpfile), +# debug = 1), +# .plotInitialTime = NA) +# }) +# }) +# +# expect_true(file.exists(tmpfile)) +# log1 <- readLines(tmpfile) +# expect_true(any(grepl("total elpsd", log1))) +# expect_true(any(grepl(Sys.Date(), log1))) +# expect_false(any(grepl("total elpsd", mess1))) # messages not produced with debug as list +# unlink(tmpfile) +# +# logging::logReset() +# mess1 <- capture_messages({ +# mess2 <- capture.output(type = "output", { +# mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) +# }) +# }) +# expect_false(file.exists(tmpfile)) +# expect_true(length(mess2) == 0) +# expect_true(any(grepl("total elpsd", mess1))) +# expect_true(any(grepl(format(Sys.Date(), "%h%d"), mess1))) # the straight messages don't have date +# +# # Test whether suppressMessages works +# mess1 <- capture_messages({ +# mess2 <- capture.output(type = "output", { +# suppressMessages({ +# mySim2 <- spades(Copy(mySim), +# debug = list("console" = list(level = "INFO"), debug = 1), +# .plotInitialTime = NA) +# }) +# }) +# }) +# expect_true(length(mess1) == 0) +# +# # Test whether suppressMessages works +# mess1 <- capture_messages({ +# mess2 <- capture.output(type = "output", { +# suppressMessages({ +# mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) +# }) +# }) +# }) +# expect_true(length(mess1) == 0) +# }) From 81a5e300f1c649af3dcdd3e25632787787a67643 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 5 Jul 2024 09:52:12 -0700 Subject: [PATCH 005/128] mod masking from other packages e.g., magrittr --- R/modActiveBinding.R | 1 - R/simulation-parseModule.R | 17 +++++++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/R/modActiveBinding.R b/R/modActiveBinding.R index a79c63d3..63571771 100644 --- a/R/modActiveBinding.R +++ b/R/modActiveBinding.R @@ -11,7 +11,6 @@ makeModActiveBinding <- function(sim, mod) { if (.isPackage(fullModulePath = mod, sim = sim)) { env <- asNamespace(.moduleNameNoUnderscore(mod)) } else { - browser() env <- sim@.xData$.mods[[mod]] if (exists("mod", envir = env, inherits = FALSE)) rm(list = "mod", envir = env, inherits = FALSE) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index 68f083ee..1c31704b 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -576,10 +576,19 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = function(x) tryCatch(eval(x, envir = tmpEnvir), error = function(x) "ERROR")) cm <- currentModule(tmpEnvir$sim) - if (!cm %in% unlist(.coreModules())) { - pkgs <- Require::extractPkgName(unlist(eval(pkgs))) - lapply(pkgs, function(p) eval(as.call(parse(text = paste0("box::use(", p, "[...]", ")")))[[1]], envir = tmpEnvir)) - } + if (length(cm)) + if (!cm %in% unlist(.coreModules())) { + pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + lapply(pkgs, function(p) { + allFns <- ls(envir = asNamespace(p)) + val <- paste0("box::use(", p, "[...]", ")") + eval(as.call(parse(text = val))[[1]], envir = tmpEnvir) + if (any("mod" == allFns)) { + rm(list = "mod", envir = parent.env(tmpEnvir)) + messageVerbose("mod will be masked from ", p) + } + }) + } activeCode <- unlist(lapply(ll, function(x) identical("ERROR", x))) From 262856223d45ef22b54d2b97109f48317d992054 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 5 Jul 2024 11:05:04 -0700 Subject: [PATCH 006/128] add box to DESCRIPTION --- DESCRIPTION | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8fe334d3..a7ef85e7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-06-14 -Version: 2.1.5.9002 +Date: 2024-07-05 +Version: 2.1.5.9003 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), @@ -33,6 +33,7 @@ Depends: quickPlot (>= 1.0.2), reproducible (>= 2.1.1) Imports: + box, cli, data.table (>= 1.11.0), fs, From 67be6093580bd025b28f076e9859c85043c22815 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 4 Nov 2024 09:11:26 -0800 Subject: [PATCH 007/128] minor --- R/cache.R | 21 +++++++++++++-------- tests/testthat/test-mod.R | 2 +- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/R/cache.R b/R/cache.R index 03c1a599..ce8faa8c 100644 --- a/R/cache.R +++ b/R/cache.R @@ -927,16 +927,21 @@ if (!exists("objSize")) { #' utils::object.size(a) objSize.simList <- function(x, quick = TRUE, ...) { - total <- obj_size(x, quick = TRUE) - aa <- objSize(x@.xData, quick = quick, ...) + total <- try(obj_size(x, quick = TRUE), silent = TRUE) # failing due to lobstr issue #72 + if (!is(total, "try-error")) { + 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, ...) + 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")) + if (!quick) + attr(total, "objSizes") <- list(sim = attr(aa, "objSize"), + other = attr(otherParts, "objSize")) + + } else { + total <- NA + } return(total) } diff --git a/tests/testthat/test-mod.R b/tests/testthat/test-mod.R index d40981f2..1f21f1dc 100644 --- a/tests/testthat/test-mod.R +++ b/tests/testthat/test-mod.R @@ -152,7 +152,7 @@ test_that("local mod object", { } }) -# test_that("convertToPackage testing", { +test_that("convertToPackage testing", { skip_on_cran() skip_if_not_installed(c("ggplot2", "pkgload", "roxygen2")) From a800f29cd110c4bacc5343ba505c929a4b9b29b2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 4 Nov 2024 16:29:23 -0800 Subject: [PATCH 008/128] cleaning --- man/convertToPackage.Rd | 2 -- tests/testthat/test-cache.R | 3 --- tests/testthat/test-save.R | 1 - 3 files changed, 6 deletions(-) diff --git a/man/convertToPackage.Rd b/man/convertToPackage.Rd index a7dbc1c0..2b3e2681 100644 --- a/man/convertToPackage.Rd +++ b/man/convertToPackage.Rd @@ -153,8 +153,6 @@ if (requireNamespace("ggplot2") && requireNamespace("pkgload") ) { tmpdir <- tempdir2() newModule("test", tmpdir, open = FALSE) convertToPackage("test", path = tmpdir) - pkgload::load_all(file.path(tmpdir, "test")) - pkgload::unload("test") } } diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 554ce106..d872366e 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -47,7 +47,6 @@ test_that("test event-level cache & memory leaks", { landscapeMaps1 <- sims$landscape[[-which(names(sims$landscape) %in% "Fires")]] fireMap1 <- sims$landscape$Fires #._doEvent_3 <<- ._prepareOutput_5 <<- 1 - # bbbb <<- 1 mess1 <- capture_messages({ sims <- spades(Copy(mySim), debug = TRUE) }) @@ -678,8 +677,6 @@ test_that("multifile cache saving", { expect_true(identical(Filenames(s2), Filenames(s))) }) - - test_that("cache of terra objects in the depends", { testInit(sampleModReqdPkgs) diff --git a/tests/testthat/test-save.R b/tests/testthat/test-save.R index bea6e657..a357582f 100644 --- a/tests/testthat/test-save.R +++ b/tests/testthat/test-save.R @@ -255,7 +255,6 @@ test_that("saveSimList works correctly", { mySim <- simLoaded # Now keep as file-backed, but change name - # aaaa <<- 1 saveSimList(mySim, filename = tmpfile[3]) sim <- loadSimList(file = tmpfile[3]) From a77e724b2c4ecef4420f686956eab5be8115bfb2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 4 Nov 2024 16:29:48 -0800 Subject: [PATCH 009/128] restartSpades doesn't have clockTime --- R/restart.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/restart.R b/R/restart.R index 08ff6d78..e58c6651 100755 --- a/R/restart.R +++ b/R/restart.R @@ -102,7 +102,7 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = numMods <- min(length(sim$.recoverableObjs), numEvents) if (numMods > 0) { com <- completed(sim) - etSecs <- sum(com[, et := difftime(clockTime, ._prevEventTimeFinish, units = "secs"), + etSecs <- sum(com[, et := difftime(._clockTime, ._prevEventTimeFinish, units = "secs"), by = seq_len(NROW(com))]$et) # remove the times of the completed events - 1 because the restartSpaDES includes the incompleted event From bb1eadc8c6e136be5e7b23a8cd162c5da85c64cd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 4 Nov 2024 17:31:50 -0800 Subject: [PATCH 010/128] test updates --- tests/testthat/helper-initTests.R | 7 +++++++ tests/testthat/test-1memory.R | 10 ++++++---- tests/testthat/test-downloadData.R | 12 +++++++----- tests/testthat/test-mod.R | 9 +++++++-- tests/testthat/test-objectSynonyms.R | 4 ++-- tests/testthat/test-simulation.R | 22 +++++++++++++++------- 6 files changed, 44 insertions(+), 20 deletions(-) diff --git a/tests/testthat/helper-initTests.R b/tests/testthat/helper-initTests.R index dc5f187e..a6d341a0 100644 --- a/tests/testthat/helper-initTests.R +++ b/tests/testthat/helper-initTests.R @@ -118,6 +118,9 @@ testCode <- ' }) return(invisible(sim)) } + Init <- function(sim) { + return(invisible(sim)) + } .inputObjects <- function(sim) { mod$x <- "sdf" @@ -197,6 +200,10 @@ test2Code <- ' }) return(invisible(sim)) } + Init <- function(sim) { + return(invisible(sim)) + } + .inputObjects <- function(sim) { if (isTRUE(P(sim)$testParB >= 543)) { P(sim, "testParB") <- P(sim)$testParB + 654 diff --git a/tests/testthat/test-1memory.R b/tests/testthat/test-1memory.R index 9fcf343d..90aeea97 100755 --- a/tests/testthat/test-1memory.R +++ b/tests/testthat/test-1memory.R @@ -2,10 +2,12 @@ test_that("testing memoryUse", { # Needs to run first or else memory use test fails skip_on_cran() - testInit(c(sampleModReqdPkgs, "future", "future.callr"), - opts = list(spades.moduleCodeChecks = FALSE, - spades.memoryUseInterval = 0.2, - spades.futurePlan = "callr")) + noisyOutput <- capture.output( + testInit(c(sampleModReqdPkgs, "future", "future.callr"), + opts = list(spades.moduleCodeChecks = FALSE, + spades.memoryUseInterval = 0.2, + spades.futurePlan = "callr")) + ) oldPlan <- future::plan() on.exit({ if (!identical(future::plan(), oldPlan)) { diff --git a/tests/testthat/test-downloadData.R b/tests/testthat/test-downloadData.R index e919a1c3..a3d11971 100644 --- a/tests/testthat/test-downloadData.R +++ b/tests/testthat/test-downloadData.R @@ -2,11 +2,13 @@ test_that("downloadData downloads and unzips module data", { skip_on_cran() opts <- list(reproducible.inputPaths = NULL) - if (isWindows()) { - opts <- append(opts, list(download.file.method = "auto")) - } else { - opts <- append(opts, list(download.file.method = "curl", download.file.extra = "-L")) - } + noisyOutput <- capture.output( + if (isWindows()) { + opts <- append(opts, list(download.file.method = "auto")) + } else { + opts <- append(opts, list(download.file.method = "curl", download.file.extra = "-L")) + } + ) testInit(c("googledrive", "terra"), opts = opts) diff --git a/tests/testthat/test-mod.R b/tests/testthat/test-mod.R index 1f21f1dc..76c782a4 100644 --- a/tests/testthat/test-mod.R +++ b/tests/testthat/test-mod.R @@ -148,7 +148,12 @@ test_that("local mod object", { sim <- savedSimEnv()$.sim sim@params$test2$testRestartSpades <- NULL sim3 <- restartSpades(sim, debug = FALSE) - expect_true(NROW(completed(sim3)) == 7) + expect_true(NROW(completed(sim3)) == + length(modules(sim)) + # .inputObjects + length(setdiff(unlist(.coreModules()), "restartR")) + # core + length(modules(sim)) + # init + 1 # test2 has an event + ) } }) @@ -277,7 +282,7 @@ test_that("convertToPackage testing", { expect_true(dir.exists(file.path(packageFoldername, "man"))) pkgload::load_all(packageFoldername) on.exit({ - try(pkgload::unload(.moduleNameNoUnderscore(basename(packageFoldername)))) + try(pkgload::unload(.moduleNameNoUnderscore(basename(packageFoldername))), silent = TRUE) }) fn <- get("Init", envir = asNamespace(.moduleNameNoUnderscore(basename(packageFoldername)))) expect_is(fn, "function") diff --git a/tests/testthat/test-objectSynonyms.R b/tests/testthat/test-objectSynonyms.R index de8b6c19..fa388936 100644 --- a/tests/testthat/test-objectSynonyms.R +++ b/tests/testthat/test-objectSynonyms.R @@ -112,8 +112,8 @@ test_that("test objectSynonyms", { expect_true(isTRUE(sim$worked)) sim <- Cache(simInit, times, params, modules = modules, - objects = list(age = 1, vegMap = 2, studyArea = 3, objectSynonyms = os), - paths = list(modulePath = tmpdir)) + objects = list(age = 1, vegMap = 2, studyArea = 3, objectSynonyms = os), + paths = list(modulePath = tmpdir)) expect_equal(sim$age, sim$ageMap) expect_equal(sim$veg, sim$vegMap) expect_equal(sim$studyArea, sim$studyArea2) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index f180799c..603b6b51 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -77,28 +77,36 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { mySimEvent7 <- simInit(times, params, modules, objects = list(), paths) |> spades(debug = FALSE, .plotInitialTime = NA, events = eventTypes, cache = TRUE) - expect_true(all("randomLandscapes" %in% completed(mySimEvent7)$moduleName)) - expect_true(!all("fireSpread" %in% completed(mySimEvent7)$moduleName)) # didn't run any fireSpread events b/c misspelled + compped <- completed(mySimEvent7) + compped <- compped[!compped$eventType %in% ".inputObjects"] + expect_true(all("randomLandscapes" %in% compped$moduleName)) + expect_true(!all("fireSpread" %in% compped$moduleName)) # didn't run any fireSpread events b/c misspelled expect_true(all("fireSpread" %in% events(mySimEvent7)$moduleName)) # didn't run any fireSpread events b/c misspelled mySimEvent8 <- simInit(times, params, modules, objects = list(), paths) |> spades(debug = FALSE, .plotInitialTime = NA, events = eventTypes, cache = TRUE) - expect_true(all("randomLandscapes" %in% completed(mySimEvent8)$moduleName)) - expect_true(!all("fireSpread" %in% completed(mySimEvent8)$moduleName)) # didn't run any fireSpread events b/c misspelled + compped <- completed(mySimEvent8) + compped <- compped[!compped$eventType %in% ".inputObjects"] + expect_true(all("randomLandscapes" %in% compped$moduleName)) + expect_true(!all("fireSpread" %in% compped$moduleName)) # didn't run any fireSpread events b/c misspelled expect_true(all("fireSpread" %in% events(mySimEvent8)$moduleName)) # didn't run any fireSpread events b/c misspelled mySimEvent9 <- simInitAndSpades(times, params, modules, objects = list(), paths, debug = FALSE, .plotInitialTime = NA, events = "init") - expect_true(all("init" == completed(mySimEvent9)$eventType)) + compped <- completed(mySimEvent9) + compped <- compped[!compped$eventType %in% ".inputObjects"] + expect_true(all("init" == compped$eventType)) expect_true(max(events(mySimEvent9)$eventTime) <= end(mySimEvent9)) # didn't schedule next event # Test times # Set end time to WAY after the init events mySimEvent10 <- simInitAndSpades(times = list(start = 0, end = 10), params, modules, objects = list(), paths, debug = FALSE, .plotInitialTime = NA, events = "init") + compped <- completed(mySimEvent10) + compped <- compped[!compped$eventType %in% ".inputObjects"] expect_true(time(mySimEvent10) == end(mySimEvent10)) # it is at 10, the end - expect_true(all("init" == completed(mySimEvent10)$eventType)) - expect_true(max(completed(mySimEvent10)$eventTime) == start(mySimEvent10)) # didn't go past start time because init are all at start + expect_true(all("init" == compped$eventType)) + expect_true(max(compped$eventTime) == start(mySimEvent10)) # didn't go past start time because init are all at start simOut <- spades(mySimEvent10) expect_true(time(simOut) == end(simOut)) # it is at 10, the end expect_true(!all("init" == completed(simOut)$eventType)) From 69d826e24a3f1f12497eeab8a9ed844561a4069e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 4 Nov 2024 17:32:21 -0800 Subject: [PATCH 011/128] start using gitcreds --- R/downloadData.R | 3 ++- R/module-repository.R | 57 ++++++++++++++++++++++++++----------------- man/checkModule.Rd | 6 ++--- 3 files changed, 40 insertions(+), 26 deletions(-) diff --git a/R/downloadData.R b/R/downloadData.R index 0721386e..790f07a2 100644 --- a/R/downloadData.R +++ b/R/downloadData.R @@ -259,7 +259,8 @@ setMethod( list( quick = quickCheck, overwrite = overwrite, - destinationPath = dPath + destinationPath = dPath, + verbose = !quiet ), list(...) ) diff --git a/R/module-repository.R b/R/module-repository.R index 0e95c92f..b9294311 100644 --- a/R/module-repository.R +++ b/R/module-repository.R @@ -32,20 +32,20 @@ defaultGitRepoToSpaDESModules <- "PredictiveEcology/SpaDES-modules" #' @rdname getModuleVersion #' @seealso [zipModule()] for creating module \file{.zip} folders. #' -setGeneric("getModuleVersion", function(name, repo) { +setGeneric("getModuleVersion", function(name, repo, token) { standardGeneric("getModuleVersion") }) #' @rdname getModuleVersion setMethod( "getModuleVersion", - signature = c(name = "character", repo = "character"), - definition = function(name, repo) { + signature = c(name = "character", repo = "character", token = "ANY"), + definition = function(name, repo, token) { if (length(name) > 1) { warning("name contains more than one module. Only the first will be used.") name <- name[1] } - moduleFiles <- checkModule(name, repo) + moduleFiles <- checkModule(name, repo, token = token) zipFiles <- grep(paste0(name, "_+.+.zip"), moduleFiles, value = TRUE) # moduleName_....zip only zipFiles <- grep(file.path(name, "data"), zipFiles, invert = TRUE, value = TRUE) # remove any zip in data folder # all zip files is not correct behaviour, only @@ -62,10 +62,10 @@ setMethod( #' @rdname getModuleVersion setMethod("getModuleVersion", - signature = c(name = "character", repo = "missing"), - definition = function(name) { - v <- getModuleVersion(name, getOption("spades.moduleRepo", - defaultGitRepoToSpaDESModules)) + signature = c(name = "character", repo = "missing", token = "ANY"), + definition = function(name, token) { + v <- getModuleVersion(name, token = token, + getOption("spades.moduleRepo", defaultGitRepoToSpaDESModules)) return(v) }) @@ -86,15 +86,15 @@ setMethod("getModuleVersion", #' @importFrom cli col_magenta #' @importFrom utils packageVersion #' @rdname checkModule -setGeneric("checkModule", function(name, repo) { +setGeneric("checkModule", function(name, repo, token) { standardGeneric("checkModule") }) #' @rdname checkModule setMethod( "checkModule", - signature = c(name = "character", repo = "character"), - definition = function(name, repo) { + signature = c(name = "character", repo = "character", token = "ANY"), + definition = function(name, repo, token) { goAhead <- FALSE if (requireNamespace("httr", quietly = TRUE)) { if (packageVersion("httr") >= "1.2.1") { @@ -107,11 +107,15 @@ setMethod( name <- name[1] } apiurl <- paste0("https://api.github.com/repos/", repo, "/git/trees/master?recursive=1") # nolint + ua <- httr::user_agent(getOption("spades.useragent")) - pat <- Sys.getenv("GITHUB_PAT") - request <- if (identical(pat, "")) { - httr::GET(apiurl, ua) + if (missing(token)) + token <- Require:::.getGitCredsToken() + request <- if (!is.null(token)) { + Require:::.GETWauthThenNonAuth(apiurl, token = token, verbose = verbose) + # httr::GET(apiurl, ua) } else { + pat <- Sys.getenv("GITHUB_PAT") message(cli::col_magenta("Using GitHub PAT from envvar GITHUB_PAT", sep = "")) httr::GET(apiurl, ua, config = list(httr::config(token = pat))) } @@ -141,8 +145,8 @@ setMethod( #' @rdname checkModule setMethod("checkModule", - signature = c(name = "character", repo = "missing"), - definition = function(name) { + signature = c(name = "character", repo = "missing", token = "ANY"), + definition = function(name, token) { v <- checkModule(name, getOption("spades.moduleRepo", defaultGitRepoToSpaDESModules)) return(v) @@ -298,8 +302,16 @@ setMethod( # or if overwrite is wanted if (!checkModuleLocal(name, path, version) | overwrite) { # check remotely for module - checkModule(name, repo) - if (is.na(version)) version <- getModuleVersion(name, repo) + # Authentication + token <- NULL + usesGitCreds <- requireNamespace("gitcreds", quietly = TRUE) && + requireNamespace("httr", quietly = TRUE) + if (usesGitCreds) { + token <- Require:::.getGitCredsToken() + } + + checkModule(name, repo, token = token) + if (is.na(version)) version <- getModuleVersion(name, repo, token = token) innerPaths <- c(paste0("/master/modules/", name, "/"), "/master/") for (tries in 1:2) { @@ -310,10 +322,12 @@ setMethod( localzip <- file.path(path, basename(zip)) ua <- httr::user_agent(getOption("spades.useragent")) - pat <- Sys.getenv("GITHUB_PAT") - request <- if (identical(pat, "")) { - httr::GET(zip, ua, httr::write_disk(localzip, overwrite = overwrite)) + request <- if (!is.null(token)) { + message(cli::col_magenta("Using GitHub token stored with gitcreds", sep = "")) + Require:::.GETWauthThenNonAuth(zip, ua, httr::write_disk(localzip, overwrite = overwrite), + token = token) } else { + pat <- Sys.getenv("GITHUB_PAT") message(cli::col_magenta("Using GitHub PAT from envvar GITHUB_PAT", sep = "")) httr::GET(zip, ua, config = list(httr::config(token = pat)), httr::write_disk(localzip, overwrite = overwrite)) @@ -396,7 +410,6 @@ setMethod( quickCheck = "ANY", overwrite = "ANY"), definition = function(name, quickCheck, overwrite) { path <- checkModulePath() - files <- downloadModule(name, path = path, version = NA_character_, repo = getOption("spades.moduleRepo", diff --git a/man/checkModule.Rd b/man/checkModule.Rd index e9cc06bd..9b765e76 100644 --- a/man/checkModule.Rd +++ b/man/checkModule.Rd @@ -6,11 +6,11 @@ \alias{checkModule,character,missing-method} \title{Check for the existence of a remote module} \usage{ -checkModule(name, repo) +checkModule(name, repo, token) -\S4method{checkModule}{character,character}(name, repo) +\S4method{checkModule}{character,character}(name, repo, token) -\S4method{checkModule}{character,missing}(name) +\S4method{checkModule}{character,missing}(name, token) } \arguments{ \item{name}{Character string giving the module name.} From 221d19f48cfa8fa67a1956cdca964457f8e2960a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 5 Nov 2024 07:28:29 -0800 Subject: [PATCH 012/128] quieter tests --- tests/testthat/test-module-deps-methods.R | 2 +- tests/testthat/test-module-template.R | 256 +++++++++++----------- 2 files changed, 131 insertions(+), 127 deletions(-) diff --git a/tests/testthat/test-module-deps-methods.R b/tests/testthat/test-module-deps-methods.R index d5206314..d0bcfcbe 100644 --- a/tests/testthat/test-module-deps-methods.R +++ b/tests/testthat/test-module-deps-methods.R @@ -118,7 +118,7 @@ test_that("depsEdgeList and depsGraph work", { testInit(sampleModReqdPkgs) origRepos <- getOption("repos") - print(origRepos) + # print(origRepos) if (any(unname(origRepos) == "@CRAN@")) { suppressMessages(utils::chooseCRANmirror(ind = 1)) on.exit({ diff --git a/tests/testthat/test-module-template.R b/tests/testthat/test-module-template.R index 02d9ef5b..f2188337 100644 --- a/tests/testthat/test-module-template.R +++ b/tests/testthat/test-module-template.R @@ -40,135 +40,139 @@ test_that("module templates work", { expect_true(file.exists(file.path(mpath, paste0(moduleName, "_0.0.2.zip")))) # Test that the .Rmd file actually can run with knitr - expect_equal(knitr::knit(input = file.path(mpath, paste0(moduleName, ".Rmd")), - output = file.path(mpath, paste0(moduleName, ".md")), - quiet = TRUE), - file.path(mpath, paste0(moduleName, ".md"))) + no <- capture.output( + type = "message", + noisyOutput <- capture.output( + expect_equal(knitr::knit(input = file.path(mpath, paste0(moduleName, ".Rmd")), + output = file.path(mpath, paste0(moduleName, ".md")), + quiet = TRUE), + file.path(mpath, paste0(moduleName, ".md"))) + )) expect_true(file.exists(file.path(mpath, "README.md"))) ## file should exist now, post-knit # Test that the dummy unit tests work #test_file(file.path(mpath, "tests", "testthat", "test-template.R")) # TODO: make it work }) -test_that("empty defineModule", { - testInit() - - sim <- simInit() - sim <- expect_warning(defineModule(sim, list())) - b <- depends(sim) - out <- lapply(names(moduleDefaults), function(modDef) { - if (modDef != "version") { - if (all(!(c("extent", "timeframe") %in% modDef))) { - expect_identical(slot(b@dependencies[[1]], modDef), moduleDefaults[[modDef]]) - } else if (modDef == "extent") { - expect_equivalent(slot(b@dependencies[[1]], "spatialExtent"), eval(moduleDefaults[[modDef]])) - } else if (modDef == "timeframe") { - expect_identical(slot(b@dependencies[[1]], "timeframe"), eval(moduleDefaults[[modDef]])) - } - } - }) -}) - -test_that("newModule with events and functions", { - testInit("ggplot2") - nm <- "test" - unlink(dir(Require::tempdir2(), pattern = nm, full.names = TRUE), recursive = TRUE) - newModule(nm, path = Require::tempdir2(), open = FALSE, - events = list( - init = - { - sim <- Init(sim) - sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "next1") - sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "plot") - } - , - plot = - { - sim$d <- 33 - plotFun(sim) - func() - sim <- scheduleEvent(sim, time(sim) + 1, moduleName = "test", eventType = "plot") - } - , - next1 = - { - sim$b <- 2 - sim$a <- sim$a + 1 - sim <- Init2(sim) - - } - ), - func = function(x) { - message("hi") - - }, - Init = function(sim) { - sim$dd <- "no way" - sim$a <- 1 - return(sim) - }, - Init2 = function(sim) { - a <- 1 - sim$dd <- "no way 2" - sim$b <- max(sim$b, a) + 1 - return(sim) - } - ) - - pdfFile <- tempfile(fileext = ".pdf") - pdf(pdfFile) - mess <- capture_messages( - out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2), - paths = list(modulePath = Require::tempdir2())) - ) - dev.off() - expect_true(file.exists(pdfFile)) - expect_true(file.size(pdfFile) > 0) - - expect_is(out, "simList") - expect_true(out$a == 2) - expect_true(out$b == 3) - yrsSimulated <- (end(out) - start(out)) - expect_true(sum(grepl("hi", mess)) == yrsSimulated) - expect_true(NROW(completed(out)) == yrsSimulated + - (NROW(.coreModules()) - 1) + length(c(".inputObjects", "next1", "init"))) - expect_true(NROW(events(out)) == 1) - expect_true(NROW(completed(out)[eventType == "next1"]) == 1) - expect_true(NROW(completed(out)[eventType == "plot"]) == yrsSimulated) -}) - -test_that("newModule without path specified as arg", { - testInit("ggplot2") - nm <- "test" - setPaths(modulePath = file.path(Require::tempdir2(), "lolololo")) - unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) - expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) - newModule(nm, open = FALSE, - events = list( - init = - { - sim <- Init(sim) - } - ), - Init = function(sim) { - sim$dd <- "no way" - sim$a <- 1 - return(sim) - } - ) - expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) - - mess <- capture_messages( - out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2)) - ) - expect_is(out, "simList") - expect_identical(out$dd, "no way") - expect_true(sum(grepl("init", mess)) == 1) - - - unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) - expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) - newModule(nm, open = FALSE) - expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) - -}) +# test_that("empty defineModule", { +# testInit() +# +# sim <- simInit() +# sim <- expect_warning(defineModule(sim, list())) +# b <- depends(sim) +# out <- lapply(names(moduleDefaults), function(modDef) { +# if (modDef != "version") { +# if (all(!(c("extent", "timeframe") %in% modDef))) { +# expect_identical(slot(b@dependencies[[1]], modDef), moduleDefaults[[modDef]]) +# } else if (modDef == "extent") { +# expect_equivalent(slot(b@dependencies[[1]], "spatialExtent"), eval(moduleDefaults[[modDef]])) +# } else if (modDef == "timeframe") { +# expect_identical(slot(b@dependencies[[1]], "timeframe"), eval(moduleDefaults[[modDef]])) +# } +# } +# }) +# }) +# +# test_that("newModule with events and functions", { +# testInit("ggplot2") +# nm <- "test" +# unlink(dir(Require::tempdir2(), pattern = nm, full.names = TRUE), recursive = TRUE) +# newModule(nm, path = Require::tempdir2(), open = FALSE, +# events = list( +# init = +# { +# sim <- Init(sim) +# sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "next1") +# sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "plot") +# } +# , +# plot = +# { +# sim$d <- 33 +# plotFun(sim) +# func() +# sim <- scheduleEvent(sim, time(sim) + 1, moduleName = "test", eventType = "plot") +# } +# , +# next1 = +# { +# sim$b <- 2 +# sim$a <- sim$a + 1 +# sim <- Init2(sim) +# +# } +# ), +# func = function(x) { +# message("hi") +# +# }, +# Init = function(sim) { +# sim$dd <- "no way" +# sim$a <- 1 +# return(sim) +# }, +# Init2 = function(sim) { +# a <- 1 +# sim$dd <- "no way 2" +# sim$b <- max(sim$b, a) + 1 +# return(sim) +# } +# ) +# +# pdfFile <- tempfile(fileext = ".pdf") +# pdf(pdfFile) +# mess <- capture_messages( +# out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2), +# paths = list(modulePath = Require::tempdir2())) +# ) +# dev.off() +# expect_true(file.exists(pdfFile)) +# expect_true(file.size(pdfFile) > 0) +# +# expect_is(out, "simList") +# expect_true(out$a == 2) +# expect_true(out$b == 3) +# yrsSimulated <- (end(out) - start(out)) +# expect_true(sum(grepl("hi", mess)) == yrsSimulated) +# expect_true(NROW(completed(out)) == yrsSimulated + +# (NROW(.coreModules()) - 1) + length(c(".inputObjects", "next1", "init"))) +# expect_true(NROW(events(out)) == 1) +# expect_true(NROW(completed(out)[eventType == "next1"]) == 1) +# expect_true(NROW(completed(out)[eventType == "plot"]) == yrsSimulated) +# }) +# +# test_that("newModule without path specified as arg", { +# testInit("ggplot2") +# nm <- "test" +# setPaths(modulePath = file.path(Require::tempdir2(), "lolololo")) +# unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) +# expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) +# newModule(nm, open = FALSE, +# events = list( +# init = +# { +# sim <- Init(sim) +# } +# ), +# Init = function(sim) { +# sim$dd <- "no way" +# sim$a <- 1 +# return(sim) +# } +# ) +# expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) +# +# mess <- capture_messages( +# out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2)) +# ) +# expect_is(out, "simList") +# expect_identical(out$dd, "no way") +# expect_true(sum(grepl("init", mess)) == 1) +# +# +# unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) +# expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) +# newModule(nm, open = FALSE) +# expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) +# +# }) From 0b7d14e87ae99be0a2be37384ef0c007c6cecbba Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 10:14:46 -0800 Subject: [PATCH 013/128] hide Rstudio bug about "package:stats" may not be available --- R/simulation-simInit.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 86e51f39..47a5b6e1 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1333,6 +1333,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out } if (runFnCallAsExpr) { pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) + pkgs <- c(pkgs, "stats") do.call(box::use, lapply(pkgs, as.name)) sim <- Cache(.inputObjects, sim, .objects = objectsToEvaluateForCaching, From e2db4c906b4440e2991d9d93e65d539ff04b6745 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 10:15:16 -0800 Subject: [PATCH 014/128] uncomment tests --- tests/testthat/test-module-template.R | 244 +++++++++++++------------- 1 file changed, 122 insertions(+), 122 deletions(-) diff --git a/tests/testthat/test-module-template.R b/tests/testthat/test-module-template.R index f2188337..f639836d 100644 --- a/tests/testthat/test-module-template.R +++ b/tests/testthat/test-module-template.R @@ -54,125 +54,125 @@ test_that("module templates work", { #test_file(file.path(mpath, "tests", "testthat", "test-template.R")) # TODO: make it work }) -# test_that("empty defineModule", { -# testInit() -# -# sim <- simInit() -# sim <- expect_warning(defineModule(sim, list())) -# b <- depends(sim) -# out <- lapply(names(moduleDefaults), function(modDef) { -# if (modDef != "version") { -# if (all(!(c("extent", "timeframe") %in% modDef))) { -# expect_identical(slot(b@dependencies[[1]], modDef), moduleDefaults[[modDef]]) -# } else if (modDef == "extent") { -# expect_equivalent(slot(b@dependencies[[1]], "spatialExtent"), eval(moduleDefaults[[modDef]])) -# } else if (modDef == "timeframe") { -# expect_identical(slot(b@dependencies[[1]], "timeframe"), eval(moduleDefaults[[modDef]])) -# } -# } -# }) -# }) -# -# test_that("newModule with events and functions", { -# testInit("ggplot2") -# nm <- "test" -# unlink(dir(Require::tempdir2(), pattern = nm, full.names = TRUE), recursive = TRUE) -# newModule(nm, path = Require::tempdir2(), open = FALSE, -# events = list( -# init = -# { -# sim <- Init(sim) -# sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "next1") -# sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "plot") -# } -# , -# plot = -# { -# sim$d <- 33 -# plotFun(sim) -# func() -# sim <- scheduleEvent(sim, time(sim) + 1, moduleName = "test", eventType = "plot") -# } -# , -# next1 = -# { -# sim$b <- 2 -# sim$a <- sim$a + 1 -# sim <- Init2(sim) -# -# } -# ), -# func = function(x) { -# message("hi") -# -# }, -# Init = function(sim) { -# sim$dd <- "no way" -# sim$a <- 1 -# return(sim) -# }, -# Init2 = function(sim) { -# a <- 1 -# sim$dd <- "no way 2" -# sim$b <- max(sim$b, a) + 1 -# return(sim) -# } -# ) -# -# pdfFile <- tempfile(fileext = ".pdf") -# pdf(pdfFile) -# mess <- capture_messages( -# out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2), -# paths = list(modulePath = Require::tempdir2())) -# ) -# dev.off() -# expect_true(file.exists(pdfFile)) -# expect_true(file.size(pdfFile) > 0) -# -# expect_is(out, "simList") -# expect_true(out$a == 2) -# expect_true(out$b == 3) -# yrsSimulated <- (end(out) - start(out)) -# expect_true(sum(grepl("hi", mess)) == yrsSimulated) -# expect_true(NROW(completed(out)) == yrsSimulated + -# (NROW(.coreModules()) - 1) + length(c(".inputObjects", "next1", "init"))) -# expect_true(NROW(events(out)) == 1) -# expect_true(NROW(completed(out)[eventType == "next1"]) == 1) -# expect_true(NROW(completed(out)[eventType == "plot"]) == yrsSimulated) -# }) -# -# test_that("newModule without path specified as arg", { -# testInit("ggplot2") -# nm <- "test" -# setPaths(modulePath = file.path(Require::tempdir2(), "lolololo")) -# unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) -# expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) -# newModule(nm, open = FALSE, -# events = list( -# init = -# { -# sim <- Init(sim) -# } -# ), -# Init = function(sim) { -# sim$dd <- "no way" -# sim$a <- 1 -# return(sim) -# } -# ) -# expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) -# -# mess <- capture_messages( -# out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2)) -# ) -# expect_is(out, "simList") -# expect_identical(out$dd, "no way") -# expect_true(sum(grepl("init", mess)) == 1) -# -# -# unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) -# expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) -# newModule(nm, open = FALSE) -# expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) -# -# }) +test_that("empty defineModule", { + testInit() + + sim <- simInit() + sim <- expect_warning(defineModule(sim, list())) + b <- depends(sim) + out <- lapply(names(moduleDefaults), function(modDef) { + if (modDef != "version") { + if (all(!(c("extent", "timeframe") %in% modDef))) { + expect_identical(slot(b@dependencies[[1]], modDef), moduleDefaults[[modDef]]) + } else if (modDef == "extent") { + expect_equivalent(slot(b@dependencies[[1]], "spatialExtent"), eval(moduleDefaults[[modDef]])) + } else if (modDef == "timeframe") { + expect_identical(slot(b@dependencies[[1]], "timeframe"), eval(moduleDefaults[[modDef]])) + } + } + }) +}) + +test_that("newModule with events and functions", { + testInit("ggplot2") + nm <- "test" + unlink(dir(Require::tempdir2(), pattern = nm, full.names = TRUE), recursive = TRUE) + newModule(nm, path = Require::tempdir2(), open = FALSE, + events = list( + init = + { + sim <- Init(sim) + sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "next1") + sim <- scheduleEvent(sim, start(sim) + 1, moduleName = "test", eventType = "plot") + } + , + plot = + { + sim$d <- 33 + plotFun(sim) + func() + sim <- scheduleEvent(sim, time(sim) + 1, moduleName = "test", eventType = "plot") + } + , + next1 = + { + sim$b <- 2 + sim$a <- sim$a + 1 + sim <- Init2(sim) + + } + ), + func = function(x) { + message("hi") + + }, + Init = function(sim) { + sim$dd <- "no way" + sim$a <- 1 + return(sim) + }, + Init2 = function(sim) { + a <- 1 + sim$dd <- "no way 2" + sim$b <- max(sim$b, a) + 1 + return(sim) + } + ) + + pdfFile <- tempfile(fileext = ".pdf") + pdf(pdfFile) + mess <- capture_messages( + out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2), + paths = list(modulePath = Require::tempdir2())) + ) + dev.off() + expect_true(file.exists(pdfFile)) + expect_true(file.size(pdfFile) > 0) + + expect_is(out, "simList") + expect_true(out$a == 2) + expect_true(out$b == 3) + yrsSimulated <- (end(out) - start(out)) + expect_true(sum(grepl("hi", mess)) == yrsSimulated) + expect_true(NROW(completed(out)) == yrsSimulated + + (NROW(.coreModules()) - 1) + length(c(".inputObjects", "next1", "init"))) + expect_true(NROW(events(out)) == 1) + expect_true(NROW(completed(out)[eventType == "next1"]) == 1) + expect_true(NROW(completed(out)[eventType == "plot"]) == yrsSimulated) +}) + +test_that("newModule without path specified as arg", { + testInit("ggplot2") + nm <- "test" + setPaths(modulePath = file.path(Require::tempdir2(), "lolololo")) + unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) + expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) + newModule(nm, open = FALSE, + events = list( + init = + { + sim <- Init(sim) + } + ), + Init = function(sim) { + sim$dd <- "no way" + sim$a <- 1 + return(sim) + } + ) + expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) + + mess <- capture_messages( + out <- simInitAndSpades(module = "test", times = list(start = 0, end = 2)) + ) + expect_is(out, "simList") + expect_identical(out$dd, "no way") + expect_true(sum(grepl("init", mess)) == 1) + + + unlink(dir(getPaths()$modulePath, pattern = nm, full.names = TRUE), recursive = TRUE) + expect_false(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) + newModule(nm, open = FALSE) + expect_true(file.exists(file.path(getPaths()$modulePath, nm, paste0(nm, ".R")))) + +}) From b8093c189ed357e3c36615bc7800ff75d62a7a88 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 11:43:30 -0800 Subject: [PATCH 015/128] new spadesOptions -- spades.reqdPkgsDontLoad - to explicitly prevent loading --- DESCRIPTION | 4 +-- NEWS.md | 5 +++ R/options.R | 6 ++++ R/simulation-simInit.R | 11 ++++++ man/spadesOptions.Rd | 5 +++ tests/testthat/test-simulation.R | 60 ++++++++++++++++++++++++++++++++ 6 files changed, 89 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 089c7dfc..a114707e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-10-13 -Version: 2.1.5.9002 +Date: 2024-11-13 +Version: 2.1.5.9003 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/NEWS.md b/NEWS.md index dc953435..3adc13e8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,11 @@ * fix issue with `Plots()` where plots were discarded if no filename was specified; * minor documentation improvements; +* new option: `spades.reqdPkgsDontLoad`, a character vector. If anything is specified, +then it will not be loaded with `require` or `library`, but it will be installed, if needed, +and if `spades.useRequire = TRUE`, which is the default. Default for this new option is +"box", which is one of potentially many in the R universe that throws an error if it is +loaded. # SpaDES.core 2.1.5 diff --git a/R/options.R b/R/options.R index d02744ee..2754a395 100644 --- a/R/options.R +++ b/R/options.R @@ -136,6 +136,11 @@ #' and the differences can be seen in a hidden object in the stashed `simList`. #' There is a message which describes how to find that. \cr #' +#' `spades.reqdPkgsDontLoad` \tab `"box"` \tab Specify any packages that should not +#' be \emph{loaded} i.e., no `library` or `require`, but they should be installed if +#' listed. The default (`"box"`) is a package that returns a warning if it is +#' loaded, and so it is excluded from loading. +#' #' `spades.saveFileExtensions` \tab `NULL` \tab #' a `data.frame` with 3 columns, `exts`, `fun`, and `package` indicating which #' file extension, and which function from which package will be used when @@ -217,6 +222,7 @@ spadesOptions <- function() { spades.plots = NULL, spades.qsThreads = 1L, spades.recoveryMode = 1, + spades.reqdPkgsDontLoad = "box", spades.restartRInterval = 0, spades.restartR.clearFiles = TRUE, spades.restartR.RDataFilename = "sim_restartR.RData", diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 78c15b2d..569191bc 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1547,9 +1547,20 @@ loadPkgs <- function(reqdPkgs) { # Check for SpaDES.core minimum version checkSpaDES.coreMinVersion(allPkgs) allPkgs <- grep("^SpaDES.core\\>", allPkgs, value = TRUE, invert = TRUE) + + needOnlyInstall <- NULL + if (is.character(getOption("spades.reqdPkgsDontLoad", NULL))) { + allPkgs <- allPkgs[!Require::extractPkgName(allPkgs) %in% getOption("spades.reqdPkgsDontLoad", NULL)] + needOnlyInstall <- getOption("spades.reqdPkgsDontLoad", NULL) + } if (getOption("spades.useRequire")) { getCRANrepos(ind = 1) # running this first is neutral if it is set Require(allPkgs, standAlone = FALSE, upgrade = FALSE) + if (!is.null(needOnlyInstall)) { + verbose <- getOption("reproducible.verbose") + Require::Require(needOnlyInstall, require = FALSE, standAlone = FALSE, + upgrade = FALSE, verbose = verbose - 1) + } # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) } else { allPkgs <- unique(Require::extractPkgName(allPkgs)) diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index e232373a..a47c03b1 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -139,6 +139,11 @@ at the start of the current event. This can be recovered with \code{restartSpade and the differences can be seen in a hidden object in the stashed \code{simList}. There is a message which describes how to find that. \cr +\code{spades.reqdPkgsDontLoad} \tab \code{"box"} \tab Specify any packages that should not +be \emph{loaded} i.e., no \code{library} or \code{require}, but they should be installed if +listed. The default (\code{"box"}) is a package that returns a warning if it is +loaded, and so it is excluded from loading. + \code{spades.saveFileExtensions} \tab \code{NULL} \tab a \code{data.frame} with 3 columns, \code{exts}, \code{fun}, and \code{package} indicating which file extension, and which function from which package will be used when diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index e229dbaf..e3e83cbd 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -1037,3 +1037,63 @@ test_that("debug using logging", { }) expect_true(length(mess1) == 0) }) + +test_that("options('reproducible.reqdPkgsDontLoad", { + dontLoad <- "sp" + + skip_if_not_installed(dontLoad) + unloadNamespace(dontLoad) + withr::local_options(spades.reqdPkgsDontLoad = dontLoad) + + testInit() + + newModule("test", tmpdir, open = FALSE) + + # 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), + childModules = character(0), + version = list(SpaDES.core = "0.1.0", test = "0.0.1"), + spatialExtent = terra::ext(rep(0, 4)), + timeframe = as.POSIXlt(c(NA, NA)), + timeunit = "year", + citation = list("citation.bib"), + documentation = list("README.md", "test.Rmd"), + reqdPkgs = list("sp"), + parameters = rbind( + ), + inputObjects = bindrows( + ), + outputObjects = bindrows( + ) + )) + + doEvent.test = function(sim, eventTime, eventType, debug = FALSE) { + switch( + eventType, + init = { + }) + return(invisible(sim)) + } + +', fill = TRUE) + expect_false(isNamespaceLoaded(dontLoad)) + warn <- capture_warnings( + sim <- simInit(modules = "test", paths = list(modulePath = tmpdir), + times = list(start = 0, end = 1, timeunit = "year")) + ) + expect_false(isNamespaceLoaded(dontLoad)) + + options(spades.reqdPkgsDontLoad = NULL) + warn <- capture_warnings( + sim <- simInit(modules = "test", paths = list(modulePath = tmpdir), + times = list(start = 0, end = 1, timeunit = "year")) + ) + expect_true(isNamespaceLoaded(dontLoad)) + unloadNamespace(dontLoad) + +}) From 71d6b2ebfb6c702f53d648d349e55e83920db03f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 12:12:29 -0800 Subject: [PATCH 016/128] options("spades.useBox"); redoc --- R/options.R | 13 +- R/simulation-simInit.R | 10 +- man/getModuleVersion.Rd | 6 +- man/spadesOptions.Rd | 12 +- tests/testthat/test-simulation.R | 934 +------------------------------ 5 files changed, 47 insertions(+), 928 deletions(-) diff --git a/R/options.R b/R/options.R index 2754a395..cba8b547 100644 --- a/R/options.R +++ b/R/options.R @@ -180,7 +180,17 @@ #' point number comparisons. \cr #' #' `spades.useragent` \tab `"https://github.com/PredictiveEcology/SpaDES"`. -#' \tab : The default user agent to use for downloading modules from GitHub. \cr +#' \tab The default user agent to use for downloading modules from GitHub. \cr +#' +#' `spades.useBox` \tab TRUE +#' \tab Whether to manage which packages are loaded using the package `box`. +#' This will have as an effect that `reqdPkgs` will be strict; if a given +#' module is missing a `reqdPkgs`, then the module will fail to run, with +#' an error saying the package/function doesn't exist. Without `box`, +#' modules may run, even though `reqdPkgs` is incorrect, because other modules +#' may have specified their own packages, which cover the needs of another +#' package. `useBox = TRUE` will force modules to be accurate with their +#' `reqdPkgs` \cr #' #' `spades.useRequire` \tab `!tolower(Sys.getenv("SPADES_USE_REQUIRE")) %in% "false"` #' \tab : The default for that environment variable is unset, so this returns @@ -236,6 +246,7 @@ spadesOptions <- function() { spades.testMemoryLeaks = TRUE, spades.tolerance = .Machine$double.eps ^ 0.5, spades.useragent = "https://github.com/PredictiveEcology/SpaDES", + spades.useBox = TRUE, spades.useRequire = !tolower(Sys.getenv("SPADES_USE_REQUIRE")) %in% "false", spades.keepCompleted = TRUE ) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 1ea87867..c45a5544 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1556,9 +1556,11 @@ loadPkgs <- function(reqdPkgs) { allPkgs <- allPkgs[!Require::extractPkgName(allPkgs) %in% getOption("spades.reqdPkgsDontLoad", NULL)] needOnlyInstall <- getOption("spades.reqdPkgsDontLoad", NULL) } + useBox <- getOption("spades.useBox", FALSE) + require <- !useBox %in% TRUE if (getOption("spades.useRequire")) { getCRANrepos(ind = 1) # running this first is neutral if it is set - Require(allPkgs, standAlone = FALSE, upgrade = FALSE) + Require(allPkgs, require = require, standAlone = FALSE, upgrade = FALSE) if (!is.null(needOnlyInstall)) { verbose <- getOption("reproducible.verbose") Require::Require(needOnlyInstall, require = FALSE, standAlone = FALSE, @@ -1566,8 +1568,10 @@ loadPkgs <- function(reqdPkgs) { } # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) } else { - allPkgs <- unique(Require::extractPkgName(allPkgs)) - loadedPkgs <- lapply(allPkgs, require, character.only = TRUE) + if (!useBox) { + allPkgs <- unique(Require::extractPkgName(allPkgs)) + loadedPkgs <- lapply(allPkgs, base::require, character.only = TRUE) + } } } } diff --git a/man/getModuleVersion.Rd b/man/getModuleVersion.Rd index b5d65669..fcccb927 100644 --- a/man/getModuleVersion.Rd +++ b/man/getModuleVersion.Rd @@ -6,11 +6,11 @@ \alias{getModuleVersion,character,missing-method} \title{Find the latest module version from a SpaDES module repository} \usage{ -getModuleVersion(name, repo) +getModuleVersion(name, repo, token) -\S4method{getModuleVersion}{character,character}(name, repo) +\S4method{getModuleVersion}{character,character}(name, repo, token) -\S4method{getModuleVersion}{character,missing}(name) +\S4method{getModuleVersion}{character,missing}(name, token) } \arguments{ \item{name}{Character string giving the module name.} diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index a47c03b1..86fc129a 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -182,7 +182,17 @@ and suggests alternatives with a warning \cr point number comparisons. \cr \code{spades.useragent} \tab \code{"https://github.com/PredictiveEcology/SpaDES"}. -\tab : The default user agent to use for downloading modules from GitHub. \cr +\tab The default user agent to use for downloading modules from GitHub. \cr + +\code{spades.useBox} \tab TRUE +\tab Whether to manage which packages are loaded using the package \code{box}. +This will have as an effect that \code{reqdPkgs} will be strict; if a given +module is missing a \code{reqdPkgs}, then the module will fail to run, with +an error saying the package/function doesn't exist. Without \code{box}, +modules may run, even though \code{reqdPkgs} is incorrect, because other modules +may have specified their own packages, which cover the needs of another +package. \code{useBox = TRUE} will force modules to be accurate with their +\code{reqdPkgs} \cr \code{spades.useRequire} \tab \code{!tolower(Sys.getenv("SPADES_USE_REQUIRE")) \%in\% "false"} \tab : The default for that environment variable is unset, so this returns diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index 189e1ee7..7d196eff 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -137,914 +137,8 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { expect_true(all(file.exists(outputs(mySimEvent12Out)$file[outputs(mySimEvent12Out)$saved]))) }) -# test_that("spades calls - diff't signatures", { -# testInit(sampleModReqdPkgs, verbose = TRUE) -# -# a <- simInit() -# a1 <- Copy(a) -# opts <- options(spades.saveSimOnExit = FALSE) -# expect_message(spades(a, debug = TRUE), "eventTime") -# expect_silent(expect_message(spades(a, debug = FALSE), "DTthreads")) -# expect_silent(expect_message(spades(a, debug = FALSE, .plotInitialTime = NA), "DTthreads")) -# expect_silent(expect_message(spades(a, debug = FALSE, .saveInitialTime = NA), "DTthreads")) -# opts <- options(opts) -# expect_message(spades(a, debug = TRUE, .plotInitialTime = NA), "eventTime") -# expect_message(spades(a, debug = TRUE, .saveInitialTime = NA), "eventTime") -# expect_equivalent(capture_output(spades(a, debug = "current", .plotInitialTime = NA)), -# capture_output(spades(a, debug = TRUE, .plotInitialTime = NA))) -# -# if (requireNamespace("logging", quietly = TRUE)) { -# expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), -# "eventTime *moduleName *eventType *eventPriority") -# } else { -# expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), -# "eventTime *moduleName *eventType *eventPriority") -# } -# expect_message(spades(a, debug = c("current", "events"), .plotInitialTime = NA), "moduleName") -# expect_message(spades(a, debug = "simList", .plotInitialTime = NA), "Completed Events") -# -# if (interactive()) { -# # warnings occur on Rstudio-server related to can't use display 0:, when using devtools::test() interactively -# suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "10%")) -# suppressWarnings(expect_output(spades(a, progress = "text", debug = TRUE), "20%")) -# suppressWarnings(expect_output(spades(a, progress = "text"), "..........| 100%")) -# } -# opts <- options(spades.saveSimOnExit = FALSE) -# expect_silent(expect_message(spades(a, debug = FALSE, progress = FALSE), "DTthreads")) -# expect_silent(expect_message(spades(a, debug = FALSE, progress = "rr"), "DTthreads")) -# opts <- options(opts) -# -# paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) -# a <- Copy(a1) -# expect_message(spades(a, cache = TRUE, debug = TRUE, notOlderThan = Sys.time()), "eventTime") -# expect_true(all(basename2(c(CacheDBFile(paths(a)$cachePath), CacheStorageDir(paths(a)$cachePath))) %in% -# dir(paths(a)$cachePath))) -# file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) -# -# # test for system time ... in this case, the first time through loop is slow -# # because of writing cache to disk, not because of spades being slow. -# # simList is empty. -# -# set.seed(42) -# -# times <- list(start = 0.0, end = 0, timeunit = "year") -# params <- list( -# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), -# randomLandscapes = list(nx = 20, ny = 20) -# ) -# modules <- list("randomLandscapes", "fireSpread") -# paths <- list(modulePath = getSampleModules(tmpdir)) -# -# for (i in 1:2) { -# a <- simInit(times, params, modules, paths = paths) -# paths(a)$cachePath <- file.path(tempdir(), "cache") |> checkPath(create = TRUE) -# assign(paste0("st", i), system.time(spades(a, cache = TRUE, .plotInitialTime = NA))) -# } -# params1 <- list( -# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), -# randomLandscapes = c(nx = 20, ny = 20) -# ) -# expect_error({ a <- simInit(times, params1, modules, paths = paths) }) -# expect_error({ a <- simInit(list(3, "a", "s"), params, modules, paths = paths) }) -# err <- capture_error({ -# a <- simInit(list(3, "years", start = 1), params, modules, paths = paths) -# }) -# expect_true(is.null(err)) -# -# #expect_gt(st1[1], st2[1]) ## no longer true on R >= 3.5.1 ?? -# file.remove(dir(paths(a)$cachePath, full.names = TRUE, recursive = TRUE)) -# }) -# -# test_that("simInit with R subfolder scripts", { -# skip_if_not_installed("NLMR") -# -# testInit() -# -# newModule("child1", ".", open = FALSE) -# cat(file = file.path("child1", "R", "script.R"), -# "a <- function(poiuoiu) { -# poiuoiu + 1 -# }", sep = "\n") -# mySim <- simInit(modules = "child1", paths = list(modulePath = tmpdir)) -# expect_true(sum(grepl(unlist(lapply(ls(mySim@.xData$.mods, all.names = TRUE), function(x) { -# if (is.environment(mySim@.xData$.mods[[x]])) ls(envir = mySim@.xData$.mods[[x]], all.names = TRUE) -# })), pattern = "^a$")) == 1) -# expect_true(mySim@.xData$.mods$child1$a(2) == 3) # Fns -# }) -# -# test_that("simulation runs with simInit with duplicate modules named", { -# testInit(sampleModReqdPkgs) -# -# set.seed(42) -# -# times <- list(start = 0.0, end = 10, timeunit = "year") -# params <- list( -# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), -# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE) -# ) -# modules <- list("randomLandscapes", "randomLandscapes", "caribouMovement") -# paths <- list(modulePath = getSampleModules(tmpdir)) -# -# expect_true(any(grepl(capture_messages({ -# mySim <- simInit(times, params, modules, objects = list(), paths) -# }), pattern = "Duplicate module"))) -# expect_true(length(modules(mySim)) != length(modules)) -# expect_true(length(modules(mySim)) == length(unique(modules))) -# }) -# -# test_that("simulation runs with simInit with duplicate modules named", { -# skip("benchmarking DES") -# -# testInit() -# -# 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), -# childModules = character(0), -# version = list(SpaDES.core = "0.1.0", test = "0.0.1"), -# spatialExtent = terra::ext(rep(0, 4)), -# timeframe = as.POSIXlt(c(NA, NA)), -# timeunit = "second", -# citation = list("citation.bib"), -# documentation = list("README.md", "test.Rmd"), -# reqdPkgs = list(), -# parameters = rbind( -# ), -# inputObjects = bindrows( -# ), -# outputObjects = bindrows( -# ) -# )) -# -# doEvent.test = function(sim, eventTime, eventType, debug = FALSE) { -# switch( -# eventType, -# init = { -# 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@nrcan-rncan.gc.ca", role = c("aut", "cre")), -# childModules = character(0), -# version = list(SpaDES.core = "0.1.0", test2 = "0.0.1"), -# spatialExtent = terra::ext(rep(0, 4)), -# timeframe = as.POSIXlt(c(NA, NA)), -# timeunit = "second", -# citation = list("citation.bib"), -# documentation = list("README.md", "test2.Rmd"), -# reqdPkgs = list(), -# parameters = rbind( -# ), -# inputObjects = bindrows( -# ), -# outputObjects = bindrows( -# ) -# )) -# -# doEvent.test2 = function(sim, eventTime, eventType, debug = FALSE) { -# switch( -# eventType, -# init = { -# sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) -# }, -# event1 = { -# sim <- scheduleEvent(sim, sim@simtimes[["current"]] + 2, "test2", "event1", .skipChecks = TRUE) -# }) -# return(invisible(sim)) -# } -# ', fill = TRUE) -# -# N <- 5000 -# -# moduleDir <- file.path(tmpdir) -# inputDir <- file.path(moduleDir, "inputs") |> checkPath(create = TRUE) -# outputDir <- file.path(moduleDir, "outputs") -# cacheDir <- file.path(outputDir, "cache") -# times <- list(start = 0, end = N) -# parameters <- list( -# ) -# modules <- list("test") -# objects <- list() -# paths <- list( -# cachePath = cacheDir, -# modulePath = moduleDir, -# inputPath = inputDir, -# outputPath = outputDir -# ) -# -# #options("spades.nCompleted" = 500) -# mySim <- simInit(times = times, params = parameters, modules = modules, -# objects = objects, paths = paths) -# -# nTimes <- 20 -# -# ####################### -# # Tested on laptop -# ####################### -# # laptop was 10.2 seconds -- currently 4.2 seconds or so --> June 29, 2018 is 1.06 seconds -# # laptop New with "seconds" -- Sept 21, 2018 is 0.492 seconds --> 98 microseconds/event -# # laptop New with "seconds" -- Nov 26, 2018 is 0.458 seconds --> 92 microseconds/event! -# # Windows Desktop -- slower -- Nov 26, 2018 0.730 Seconds --> 148 microseconds/event! -# # Linux Server -- slower -- Nov 26, 2018 0.795 Seconds --> 159 microseconds/event! -# # BorealCloud Server -- slower -- Nov 26, 2018 0.972 Seconds --> 194 microseconds/event! -# # laptop -- May 25, 2019 0.603 Seconds --> 120 microseconds/event! -# # laptop with new completed as environment -- May 25, 2019 0.357 Seconds --> 71 microseconds/event! -# options("spades.keepCompleted" = TRUE) -# # microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)}) -# # -# # # Turn off completed list -# # # Changed to use "seconds" -- better comparison with simple loop -# # # Old times using "year" -- June 29, 2018 is 0.775 seconds, Sept 19, 2018 0.809 seconds -# # # -- This is 161 microseconds per event -# # # New times using "second" -- Sept 19, 2018 0.244 Seconds --> 49 microseconds/event -# # # New times using "second" -- Nov 26, 2018 0.192 Seconds --> 38 microseconds/event! -# # # Windows Desktop -- slower -- Nov 26, 2018 0.348 Seconds --> 70 microseconds/event! -# # # Linux Server -- slower -- Nov 26, 2018 0.461 Seconds --> 92 microseconds/event! -# # # BorealCloud Server -- slower -- Nov 26, 2018 0.282 Seconds --> 56 microseconds/event! -# # # With many new "exists" -# # # laptop -- May 25, 2019 0.264 Seconds --> 53 microseconds/event! -# # options("spades.keepCompleted" = FALSE) -# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) -# # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) -# # -# # a <- 0 -# # a3 <- microbenchmark::microbenchmark( -# # for (i in 1:N) { -# # a <- a + 1 -# # } -# # ) -# # -# # summary(a2)[, "median"]/summary(a3)[, "median"] -# # -# # ######################################## -# # # With 2 modules, therefore sorting -# # ######################################## -# # modules <- list("test", "test2") -# # mySim <- simInit(times = times, params = parameters, modules = modules, -# # objects = objects, paths = paths) -# # -# # nTimes <- 10 -# # # Turn off completed list -# # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 59 microseconds/event, even with sorting -# # options("spades.keepCompleted" = FALSE) -# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) -# # #profvis::profvis({for (i in 1:10) spades(mySim, debug = FALSE)}) -# # -# # # New times using "second" -- Nov 26, 2018 0.443 Seconds --> 130 microseconds/event, even with sorting -# # options("spades.keepCompleted" = TRUE) -# # (a2 <- microbenchmark::microbenchmark(times = nTimes, {spades(mySim, debug = FALSE)})) -# }) -# -# test_that("conflicting function types", { -# testInit(sampleModReqdPkgs, smcc = TRUE) -# -# m <- "child4" -# newModule(m, tmpdir, open = FALSE) -# fileName <- file.path(m, paste0(m, ".R")) # child4/child4.R" -# xxx <- readLines(fileName) -# lineWithInit <- grep(xxx, pattern = "^Init") -# -# xxx1 <- gsub(xxx, pattern = 'plotFun', replacement = 'Plot') # nolint -# cat(xxx1, file = fileName, sep = "\n") -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "Plot is defined") -# -# # do functions like raster::levels -# cat(xxx[1:lineWithInit], " -# library(raster) -# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) -# poiuoiu <- poiuoiu -# poiuoiu <- scale(poiuoiu) -# poiuoiu <- ratify(poiuoiu) -# rat <- raster::levels(poiuoiu)[[1]] -# -# levels(poiuoiu) <- rat -# ", -# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) -# -# fullMessage <- c("the following function\\(s\\) is used that", "raster::scale", "scale") -# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) -# nonMessage <- c("raster::levels", "levels") -# expect_false(all(unlist(lapply(nonMessage, function(x) any(grepl(mm, pattern = x)))))) -# -# cat(xxx[1:lineWithInit], " -# library(raster) -# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) -# poiuoiu <- scale(poiuoiu) -# ", -# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "raster::scale") -# -# cat(xxx[1:lineWithInit], " -# library(raster) -# poiuoiu <- raster(extent(0,10,0,10), vals = rep(1:2, length.out = 100)) -# poiuoiu <- raster::scale(poiuoiu) -# sim$poiuoiu <- poiuoiu -# ", -# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "poiuoiu is assigned") -# -# cat(xxx[1:(lineWithInit - 1)], " -# a <- function(x) { -# b <- b + 1 -# } -# ", -# xxx[(lineWithInit):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), "a: parameter") -# -# xxx1 <- gsub(xxx, pattern = "\\.plotInitialTime", replacement = "value") -# xxx1 <- gsub(xxx1, pattern = "NA, NA, NA", replacement = "'hi', NA, NA") -# -# cat(xxx1[1:lineWithInit], " -# a <- sim$b -# d <- sim$d -# f <- sim[['f']] -# f <- sim[[P(sim)$value]] -# poiuoiu <- sim@.xData$d1 -# qwerqwer <- sim@.xData[['test']] -# sim$g <- f -# sim@.xData$g1 <- f -# return(list(a, d, f, sim)) -# ", -# xxx1[(lineWithInit + 1):length(xxx1)], sep = "\n", fill = FALSE, file = fileName) -# -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) -# -# fullMessage <- c(# "defineParameter: 'value' is not of specified type 'numeric'", -# "defineParameter: 'plotInterval' is not of specified type 'numeric'", -# "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", -# "defineParameter: 'saveInterval' is not of specified type 'numeric'", -# "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", -# "Running .inputObjects for child4", -# "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", -# "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", -# "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" -# ) -# -# mm <- cleanMessage(mm) -# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) -# -# cat(xxx[1:lineWithInit], " -# sim$child4 <- 1 -# ", -# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_error(simInit(paths = list(modulePath = tmpdir), modules = m), -# c(paste0(m, ": You have created an object"))) -# -# # declared in metadata inputObjects -# lineWithInputObjects <- grep(xxx, pattern = " expectsInput") -# cat(xxx[1:(lineWithInputObjects - 1)], " -# expectsInput('a', 'numeric', '', '') -# ", -# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), -# c(paste0(m, ": module code: a is declared in metadata inputObjects"))) -# -# # declared in metadata outputObjects -# lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") -# cat(xxx[1:(lineWithOutputObjects - 1)], " -# createsOutput('b', 'numeric', '') -# ", -# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), -# c(paste0(m, ": module code: b is declared in metadata outputObjects"))) -# -# cat(xxx[1:(lineWithInputObjects - 1)], " -# expectsInput('a', 'numeric', '', '') -# ", -# xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], -# " -# createsOutput('b', 'numeric', '') -# ", -# xxx[(lineWithInputObjects + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) -# expect_true(all(grepl(mm, -# pattern = c(paste0(m, ": module code: b is declared in metadata outputObjects|", -# "so not checking minimum package|", -# m, ": module code: a is declared in metadata inputObjects|", -# "Running .inputObjects|", -# "Setting:|Paths set to:|", -# "Using setDTthreads|", -# m, ": using dataPath|", "Elapsed"))))) -# -# # assign to sim for functions like scheduleEvent -# lineWithScheduleEvent <- grep(xxx, pattern = "scheduleEvent")[1] -# xxx1 <- xxx -# xxx1[lineWithScheduleEvent] <- sub(xxx[lineWithScheduleEvent], pattern = "sim <- scheduleEvent", -# replacement = "scheduleEvent") -# cat(xxx1, sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), -# c(paste0(m, ": module code: scheduleEvent inside doEvent.child4 must"))) -# -# # Return sim in doEvent -# patt <- "return\\(invisible\\(sim\\)\\)" -# lineWithReturnSim <- grep(xxx, pattern = patt)[1] -# xxx1 <- xxx -# xxx1[lineWithReturnSim] <- sub(xxx[lineWithReturnSim], pattern = patt, -# replacement = "return(invisible())") -# cat(xxx1, sep = "\n", fill = FALSE, file = fileName) -# -# expect_message(simInit(paths = list(modulePath = tmpdir), modules = m), -# c(paste0(m, ": module code: doEvent.", m, " must return"))) -# -# lineWithInputObjects <- grep(xxx, pattern = " expectsInput") -# lineWithOutputObjects <- grep(xxx, pattern = " createsOutput") -# lineWithDotInputObjects <- grep(xxx, pattern = "\\.inputObjects")[1] -# cat(xxx[1:(lineWithInputObjects - 1)], " -# expectsInput('ei1', 'numeric', desc = 'This is a test with spaces -# and EOL', ''), -# expectsInput('ei2', 'numeric', '', ''), -# expectsInput('ei3', 'numeric', '', ''), -# expectsInput('ei4', 'numeric', '', 'test.com') -# ", -# xxx[(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " -# createsOutput('co1', 'numeric', ''), -# createsOutput('co2', 'numeric', desc = 'This is a test with spaces -# and EOL on the createsOutputs'), -# createsOutput('co3', 'numeric', ''), -# createsOutput('co4', 'numeric', '') -# ", -# xxx[(lineWithOutputObjects + 1):lineWithInit], " -# a <- sim$b -# sim$g <- f -# holy(sim$co4) <- f -# moly(sim$aaa) <- f -# fff <- sim$ei2 -# fff <- sim$co3 -# sim$co1 <- 123 -# xx <- c(1,2) -# xx[sim$ei4] <- NA -# ", -# xxx[(lineWithInit + 1):lineWithDotInputObjects], " -# a <- sim$b -# url1 <- extractURL('ei4') -# if (!identical(url1, 'test.com')) -# stop('extractURL without sim or module fails') -# url1 <- extractURL('ei4', sim = sim) -# if (!identical(url1, 'test.com')) -# stop('extractURL without module fails')", -# paste0(" url1 <- extractURL('ei4', sim = sim, module = \"", m, "\")") ," -# if (!identical(url1, 'test.com')) -# stop('extractURL fails') -# sim$g <- 1 -# sim$ei1 <- 4 -# fff <- sim$ei1 -# fff <- sim$co3 -# sim$co1 <- 123 -# aaa <- sim$.userSuppliedObjNames # in the ignoreObjects -# ", -# xxx[(lineWithDotInputObjects + 1):length(xxx)], -# sep = "\n", fill = FALSE, file = fileName) -# -# fullMessage <- c( -# "Running .inputObjects for child4", -# "child4: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", -# "child4: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", -# "child4: module code: ei3 is declared in metadata inputObjects, but is not used in the module", -# "child4: module code: .inputObjects: local variable.*a.*assigned but may not be used", -# "child4: module code: .inputObjects: local variable.*fff.*assigned but may not be used", -# "child4: module code: Init: local variable.*a.*assigned but may not be used", -# "child4: module code: Init: local variable.*fff.*assigned but may not be used", -# "child4: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", -# "child4: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", -# "child4: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", -# "child4: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects" -# ) -# -# # Test moduleMetadata without `sim` and where there is a `sim` in the module metadata, -# # so needs to load it. A non-error is good enough for now. -# md1 <- moduleMetadata(module = m, path = tmpdir) # no sim in metadata -# md2 <- moduleMetadata(path = getSampleModules(tmpdir), -# module = "randomLandscapes") -# -# -# mm <- capture_messages({ -# mySim <- simInit(paths = list(modulePath = tmpdir), modules = m) -# }) -# mm <- cleanMessage(mm) -# expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm, pattern = x)))))) -# -# x1 <- moduleMetadata(mySim) -# sns <- slotNames(mySim@depends@dependencies[[m]]) -# names(sns) <- sns -# x2 <- lapply(sns, function(sn) { -# slot(mySim@depends@dependencies[[m]], sn) -# }) -# -# # Now extra spaces are removed automatically on load ######################## -# -# # When there are more than a certain number of characters, a hidden \n gets inserted -# # Our metadata in tests is close to that, and some push past. No point diagnosing further. Accept 1 "TRUE" -# expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) -# x2 <- rmExtraSpacesEOLList(x2) -# expect_true(sum(unlist(lapply(x1, function(v) grepl(" |\n", v)))) <= 1) -# expect_true(sum(unlist(lapply(x2, function(v) grepl(" |\n", v)))) <= 1) -# -# x1 <- moduleParams(m, dirname(dirname(fileName))) -# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) -# x1 <- moduleInputs(m, dirname(dirname(fileName))) -# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) -# x1 <- moduleOutputs(m, dirname(dirname(fileName))) -# expect_false(any(unlist(lapply(x1, function(v) grepl(" |\n", v))))) -# }) -# -# test_that("scheduleEvent with NA logical in a non-standard parameter", { -# testInit("ggplot2", smcc = TRUE) -# m <- "test" -# newModule(m, tmpdir, open = FALSE) -# fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" -# xxx <- readLines(fileName) -# #lineWithInit <- grep(xxx, pattern = "^Init") -# -# xxx1 <- gsub(xxx, pattern = '.plotInitialTime', replacement = '.plotInitialTim') # nolint -# xxx2a <- grep(".plotInitialTim\\>", xxx1, value = TRUE)[1] -# xxx2b <- gsub(",$", grep("time interval between plot", xxx1, value = TRUE), replacement = "") -# xxx3 <- parse(text = paste(xxx2a, xxx2b)) -# # show that it is logical -# sim <- simInit(times = list(start = 0, end = 2)) -# expect_true(is.numeric(eval(xxx3)$default[[1]])) -# -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) -# expect_true(all(unlist(lapply(c("Running .inputObjects", "module code appears clean"), -# function(x) any(grepl(mm, pattern = x)))))) -# }) -# -# test_that("messaging with multiple modules", { -# testInit("ggplot2", smcc = TRUE) -# -# m1 <- "test" -# m2 <- "test2" -# m3 <- "test3" -# m4 <- "test4" -# m <- c(m1, m2, m3, m4) -# newModule(m1, tmpdir, open = FALSE) -# newModule(m2, tmpdir, open = FALSE) -# newModule(m3, tmpdir, open = FALSE) -# newModule(m4, tmpdir, open = FALSE) -# #lapply(m, newModule, tmpdir, open = FALSE) -# fileNames <- file.path(tmpdir, m, paste0(m, ".R")) -# xxx <- lapply(fileNames, readLines) -# set.seed(113) -# -# lineWithInit <- grep(xxx[[1]], pattern = "^Init") -# lineWithInputObjects <- grep(xxx[[1]], pattern = " expectsInput") -# lineWithOutputObjects <- grep(xxx[[1]], pattern = " createsOutput") -# lineWithDotInputObjects <- grep(xxx[[1]], pattern = "\\.inputObjects")[1] -# -# xxx1 <- list() -# #lapply(seq(m), function(yy) sample(c("character", "numeric", "logical"), size = 3, replace = TRUE)) -# xxx1[[1]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", -# "\\.plotInitialTime\", \"character\", 1", xxx[[1]]) -# xxx1[[1]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", -# "\\.saveInitialTime\", \"character\", FALSE", xxx1[[1]]) -# xxx1[[1]] <- gsub("\\.saveInterval\", \"numeric\", NA", -# "\\testtime\", \"logical\", NA_real_", xxx1[[1]]) -# -# xxx1[[2]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", -# "\\.plotInitialTime\", \"character\", TRUE", xxx[[2]]) -# xxx1[[2]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", -# "\\.saveInitialTime\", \"character\", 'c'", xxx1[[2]]) -# xxx1[[2]] <- gsub("\\.saveInterval\", \"numeric\", NA", -# "\\testtime\", \"character\", NA_real_", xxx1[[2]]) -# -# xxx1[[3]] <- gsub("\\.plotInitialTime\", \"numeric\", NA", -# "\\.plotInitialTime\", \"character\", 1", xxx[[3]]) -# xxx1[[3]] <- gsub("\\.saveInitialTime\", \"numeric\", NA", -# "\\hello\", \"character\", 1", xxx1[[3]]) -# xxx1[[3]] <- gsub("\\.saveInterval\", \"numeric\", NA", -# "\\testtime\", \"logical\", NA_real_", xxx1[[3]]) -# xxx1[[4]] <- xxx[[4]] # clean one -# -# cat(xxx1[[1]][1:(lineWithInputObjects - 1)], " -# expectsInput('ei1', 'numeric', '', ''), -# expectsInput('ei2', 'numeric', '', ''), -# expectsInput('ei3', 'numeric', '', ''), -# expectsInput('ei4', 'numeric', '', '') -# ", -# xxx1[[1]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " -# createsOutput('co1', 'numeric', ''), -# createsOutput('co2', 'numeric', ''), -# createsOutput('co3', 'numeric', ''), -# createsOutput('co4', 'numeric', '') -# ", -# xxx1[[1]][(lineWithInputObjects + 1):lineWithInit], " -# a <- sim$b -# sim$g <- f -# holy(sim$co4) <- f -# moly(sim$aaa) <- f -# fff <- sim$ei2 -# fff <- sim$co3 -# sim$co1 <- 123 -# xx <- c(1,2) -# xx[sim$ei4] <- NA -# ", -# xxx1[[1]][(lineWithInit + 1):lineWithDotInputObjects], " -# a <- sim$b -# sim$g <- 1 -# sim$ei1 <- 4 -# fff <- sim$ei1 -# fff <- sim$co3 -# sim$co1 <- 123 -# ", -# xxx1[[1]][(lineWithDotInputObjects + 1):length(xxx1[[1]])], -# sep = "\n", fill = FALSE, file = fileNames[1]) -# -# -# cat(xxx1[[2]][1:(lineWithInputObjects - 1)], " -# expectsInput('ei1', 'numeric', '', ''), -# expectsInput('ei4', 'numeric', '', '') -# ", -# xxx1[[2]][(lineWithInputObjects + 1):(lineWithOutputObjects - 1)], " -# createsOutput('co1', 'numeric', ''), -# createsOutput('co4', 'numeric', '') -# ", -# xxx1[[2]][(lineWithInputObjects + 1):lineWithInit], " -# a <- sim$b -# xx <- c(1,2) -# xx[sim$ei4] <- NA -# ", -# xxx1[[2]][(lineWithInit + 1):lineWithDotInputObjects], " -# a <- sim$b -# sim$co1 <- 123 -# ", -# xxx1[[2]][(lineWithDotInputObjects + 1):length(xxx1[[2]])], -# sep = "\n", fill = FALSE, file = fileNames[2]) -# -# fullMessage <- c( -# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", -# "defineParameter: 'saveInitialTime' is not of specified type 'character'", -# "Running .inputObjects for test", -# "test: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", -# "test: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", -# "test: module code: ei3 is declared in metadata inputObjects, but is not used in the module", -# "test: module code: .inputObjects: local variable.*a.*assigned but may not be used", -# "test: module code: .inputObjects: local variable.*fff.*assigned but may not be used", -# "test: module code: Init: local variable.*a.*assigned but may not be used", -# "test: module code: Init: local variable.*fff.*assigned but may not be used", -# "test: outputObjects: g, aaa are assigned to sim inside Init, but are not declared in metadata outputObjects", -# "test: inputObjects: g, co1 are assigned to sim inside .inputObjects, but are not declared in metadata inputObjects", -# "test: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", -# "test: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects", -# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", -# "Running .inputObjects for test2", -# "test2: module code: co1, co4 are declared in metadata outputObjects, but are not assigned in the module", -# "test2: module code: ei1, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", -# "test2: module code: ei1 is declared in metadata inputObjects, but is not used in the module", -# "test2: module code: .inputObjects: local variable.*a.*assigned but may not be used", -# "test2: module code: Init: local variable.*a.*assigned but may not be used", -# "test2: inputObjects: co1 is assigned to sim inside .inputObjects, but is not declared in metadata inputObjects", -# "test2: inputObjects: b is used from sim inside Init, but is not declared in metadata inputObjects", -# "test2: inputObjects: b is used from sim inside .inputObjects, but is not declared in metadata inputObjects", -# # "defineParameter: 'plotInitialTime' is not of specified type 'character'", -# "defineParameter: 'hello' is not of specified type 'character'", -# "Running .inputObjects for test3", -# "test3: module code appears clean", -# "Running .inputObjects for test4", -# "test4: module code appears clean" -# ) -# -# for (y in 3:4) { -# cat(xxx1[[y]], sep = "\n", fill = FALSE, file = fileNames[y]) -# } -# withr::local_options(spades.allowInitDuringSimInit = FALSE) -# mm1 <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) -# mm1 <- cleanMessage(mm1) -# expect_true(all(unlist(lapply(fullMessage, -# function(x) any(grepl(mm1, pattern = x)))))) -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = as.list(m))) -# mm <- cleanMessage(mm) -# }) -# -# test_that("Module code checking -- pipe with matrix product with backtick & data.table", { -# testInit("ggplot2", smcc = TRUE) -# -# m <- "child4" -# newModule(m, tmpdir, open = FALSE) -# fileName <- file.path(m, paste0(m, ".R"))#child4/child4.R" -# xxx <- readLines(fileName) -# lineWithInit <- grep(xxx, pattern = "^Init") -# xxx1 <- xxx -# cat(xxx[1:lineWithInit], " -# checksums1 <- structure(list(result = c('OK', 'OK'), -# expectedFile = c('Land_Cover_2010_TIFF.zip','NA_LandCover_2010_25haMMU.tif'), -# actualFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif'), -# checksum.x = c('f4f647d11f5ce109', '6b74878f59de5ea9'), -# checksum.y = c('f4f647d11f5ce109', '6b74878f59de5ea9'), -# algorithm.x = c('xxhash64', 'xxhash64'), -# algorithm.y = c('xxhash64', 'xxhash64'), -# renamed = c(NA, NA), -# module = c('simplifyLCCVeg', 'simplifyLCCVeg')), -# .Names = c('result', 'expectedFile', 'actualFile', -# 'checksum.x', 'checksum.y', 'algorithm.x', 'algorithm.y', 'renamed', -# 'module'), -# row.names = c(NA, -2L), -# class = c('grouped_df', 'tbl_df', 'tbl', 'data.frame'), -# vars = 'expectedFile', -# indices = list(0L, 1L), -# group_sizes = c(1L, 1L), -# biggest_group_size = 1L, -# labels = structure(list(expectedFile = c('Land_Cover_2010_TIFF.zip', 'NA_LandCover_2010_25haMMU.tif')), -# .Names = 'expectedFile', -# row.names = c(NA, -2L), -# class = 'data.frame', vars = 'expectedFile')) -# -# result1 <- checksums1[checksums1$expectedFile == 'NA_LandCover_2010_25haMMU.tif',]$result -# -# sim$bvcx <- matrix(1:2) %>% `%*%` (2:3) -# sim$bvcx2 <- matrix(1:2) %>% \"%*%\" (2:3) -# sim$b <- matrix(1:2) %>% t() -# -# sim$a <- 1 -# ", -# xxx[(lineWithInit + 1):length(xxx)], sep = "\n", fill = FALSE, file = fileName) -# -# mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) -# mm <- cleanMessage(mm) -# -# fullMessage1 <- c( -# "Running .inputObjects for child4", -# "child4: module code: Init: local variable.*result1.*assigned but may not be used ", -# "child4: outputObjects: bvcx, bvcx2, b, a are assigned to sim inside Init, but are not declared in metadata outputObjects") -# fullMessageNonInteractive <- c( -# "Running .inputObjects for child4", -# "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx <- matrix.*", #possibly at .*147", -# "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx2 <- matrix.*", #possibly at .*148", -# "child4: module code: Init: local variable.*result1.*assigned but may not be used", -# "child4: outputObjects: b, a are assigned to sim inside Init, but are not declared in metadata outputObjects" -# ) -# test1 <- all(unlist(lapply(fullMessage1, function(x) any(grepl(mm, pattern = x))))) -# test2 <- all(unlist(lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x))))) -# # if (grepl( "emcintir", Sys.info()["user"])) { -# # tmpFilename = "c:/Eliot/tmp/test1.txt" -# # -# # cat("################### test1\n", file = tmpFilename, append = FALSE) -# # cat(paste(collapse = " ", lapply(fullMessage1, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) -# # cat("\n################### test2\n", file = tmpFilename, append = TRUE) -# # cat(paste(collapse = " ", lapply(fullMessageNonInteractive, function(x) any(grepl(mm, pattern = x)))), file = tmpFilename, append = TRUE) -# # cat("\n################### fullMessage1\n", file = tmpFilename, append = TRUE) -# # cat(paste(collapse = "\n", fullMessage1), file = tmpFilename, append = TRUE) -# # cat("\n################### fullMessageNonInteractive\n", file = tmpFilename, append = TRUE) -# # cat(paste(collapse = "\n", fullMessageNonInteractive), file = tmpFilename, append = TRUE) -# # cat("\n################### mm\n", file = tmpFilename, append = TRUE) -# # cat(paste(collapse = "\n", mm), file = tmpFilename, append = TRUE) -# # } -# expect_true(test1 || test2) -# }) -# -# test_that("simInitAndSpades", { -# -# testInit(sampleModReqdPkgs) -# -# set.seed(42) -# -# times <- list(start = 0.0, end = 0, timeunit = "year") -# params <- list( -# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), -# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA), -# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), -# fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) -# ) -# modules <- list("randomLandscapes", "caribouMovement", "fireSpread") -# paths <- list(modulePath = getSampleModules(tmpdir)) -# set.seed(123) -# mySim <- simInitAndSpades(times = times, params = params, -# modules = modules, objects = list(), paths = paths, debug = FALSE) -# -# set.seed(123) -# mySim2 <- simInit(times = times, params = params, -# modules = modules, objects = list(), paths = paths) |> -# spades(debug = FALSE) -# -# expect_true(all.equal(mySim, mySim2)) -# -# }) -# -# test_that("scheduleEvent with invalid values for eventTime", { -# testInit() -# s <- simInit(times = list(start = 1, end = 10)) -# expect_error({ -# s <- scheduleEvent(s, eventTime = -1, eventType = "test1", moduleName = "test") -# }) -# expect_warning({ -# s <- scheduleEvent(s, eventTime = numeric(), eventType = "test1", moduleName = "test") -# }) -# expect_error({ -# s <- scheduleEvent(s, eventTime = 0, eventType = "test1", moduleName = "test") -# }) -# }) -# -# test_that("debug using logging", { -# -# testInit(c(sampleModReqdPkgs, "logging"), tmpFileExt = "log") -# -# set.seed(42) -# -# times <- list(start = 0.0, end = 1, timeunit = "year") -# params <- list( -# .globals = list(burnStats = "npixelsburned", stackName = "landscape"), -# randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA, .useCache = "init"), -# caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), -# fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) -# ) -# modules <- list("randomLandscapes") -# paths <- list(modulePath = getSampleModules(tmpdir)) -# -# set.seed(123) -# mySim <- simInit(times, params, modules, objects = list(), paths) #|> -# logging::logReset() -# unlink(tmpfile) -# expect_false(file.exists(tmpfile)) -# mess1 <- capture_messages({ -# mess2 <- capture.output(type = "output", { -# mySim2 <- spades(Copy(mySim), -# debug = list("console" = list(level = 10), debug = 1), -# .plotInitialTime = NA) -# }) -# }) -# expect_false(any(grepl("total elpsd", mess1))) # using new mechanism console -# expect_true(any(grepl("total elpsd", mess2))) -# expect_true(any(grepl(Sys.Date(), mess2))) # the loginfo does have date -# expect_false(any(grepl(Sys.Date(), mess1))) # original debug has date added -# -# logging::logReset() -# mess1 <- capture_messages({ -# mess2 <- capture.output(type = "output", { -# mySim2 <- spades(Copy(mySim), -# debug = list("console" = list(level = 5), -# "file" = list(file = tmpfile), -# debug = 1), -# .plotInitialTime = NA) -# }) -# }) -# -# expect_true(file.exists(tmpfile)) -# log1 <- readLines(tmpfile) -# expect_true(any(grepl("total elpsd", log1))) -# expect_true(any(grepl(Sys.Date(), log1))) -# expect_false(any(grepl("total elpsd", mess1))) # messages not produced with debug as list -# unlink(tmpfile) -# -# logging::logReset() -# mess1 <- capture_messages({ -# mess2 <- capture.output(type = "output", { -# mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) -# }) -# }) -# expect_false(file.exists(tmpfile)) -# expect_true(length(mess2) == 0) -# expect_true(any(grepl("total elpsd", mess1))) -# expect_true(any(grepl(format(Sys.Date(), "%h%d"), mess1))) # the straight messages don't have date -# -# # Test whether suppressMessages works -# mess1 <- capture_messages({ -# mess2 <- capture.output(type = "output", { -# suppressMessages({ -# mySim2 <- spades(Copy(mySim), -# debug = list("console" = list(level = "INFO"), debug = 1), -# .plotInitialTime = NA) -# }) -# }) -# }) -# expect_true(length(mess1) == 0) -# -# # Test whether suppressMessages works -# mess1 <- capture_messages({ -# mess2 <- capture.output(type = "output", { -# suppressMessages({ -# mySim2 <- spades(Copy(mySim), debug = 1, .plotInitialTime = NA) -# }) -# }) -# }) -# expect_true(length(mess1) == 0) -# }) +test_that("spades calls - diff't signatures", { + testInit(sampleModReqdPkgs, verbose = TRUE) a <- simInit() a1 <- Copy(a) @@ -1061,7 +155,7 @@ test_that("simulation runs with simInit and spades with set.seed; events arg", { if (requireNamespace("logging", quietly = TRUE)) { expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), - "eventTime *moduleName *eventType *eventPriority") + "eventTime *moduleName *eventType *eventPriority") } else { expect_message(spades(Copy(a), debug = list(debug = list("current", "events")), .plotInitialTime = NA), "eventTime *moduleName *eventType *eventPriority") @@ -1400,14 +494,14 @@ test_that("conflicting function types", { mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) fullMessage <- c(# "defineParameter: 'value' is not of specified type 'numeric'", - "defineParameter: 'plotInterval' is not of specified type 'numeric'", - "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", - "defineParameter: 'saveInterval' is not of specified type 'numeric'", - "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", - "Running .inputObjects for child4", - "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", - "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", - "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" + "defineParameter: 'plotInterval' is not of specified type 'numeric'", + "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", + "defineParameter: 'saveInterval' is not of specified type 'numeric'", + "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", + "Running .inputObjects for child4", + "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", + "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", + "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" ) mm <- cleanMessage(mm) @@ -1517,7 +611,7 @@ test_that("conflicting function types", { url1 <- extractURL('ei4', sim = sim) if (!identical(url1, 'test.com')) stop('extractURL without module fails')", -paste0(" url1 <- extractURL('ei4', sim = sim, module = \"", m, "\")") ," + paste0(" url1 <- extractURL('ei4', sim = sim, module = \"", m, "\")") ," if (!identical(url1, 'test.com')) stop('extractURL fails') sim$g <- 1 @@ -1936,7 +1030,7 @@ test_that("debug using logging", { mySim2 <- spades(Copy(mySim), debug = list("console" = list(level = "INFO"), debug = 1), .plotInitialTime = NA) - }) + }) }) }) expect_true(length(mess1) == 0) @@ -1997,7 +1091,7 @@ test_that("options('reproducible.reqdPkgsDontLoad", { ', fill = TRUE) expect_false(isNamespaceLoaded(dontLoad)) warn <- capture_warnings( - sim <- simInit(modules = "test", paths = list(modulePath = tmpdir), + sim <- simInit(modules = "test", paths = list(modulePath = tmpdir), times = list(start = 0, end = 1, timeunit = "year")) ) expect_false(isNamespaceLoaded(dontLoad)) From 858ee7cebf9293696dfb9af975868ecfc8f9431a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 13:00:08 -0800 Subject: [PATCH 017/128] reqdPkgsDontLoad --- R/simulation-parseModule.R | 12 ++++++++++++ R/simulation-simInit.R | 14 ++++++-------- tests/testthat/test-simulation.R | 6 +++--- 3 files changed, 21 insertions(+), 11 deletions(-) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index f645eae8..30fd573c 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -643,3 +643,15 @@ newEnvsByModule <- function(sim, modu) { sim@.xData$.mods[[modu]]$.objects <- new.env(parent = emptyenv()) sim } + + +reqdPkgsDontLoad <- function(allPkgs, pkgsDontLoad = getOption("spades.reqdPkgsDontLoad", NULL)) { + if (spadesReqdPkgsDontLoad(pkgsDontLoad)) { + allPkgs <- allPkgs[!Require::extractPkgName(allPkgs) %in% pkgsDontLoad] + } + allPkgs +} + +spadesReqdPkgsDontLoad <- function(pkgsDontLoad) { + is.character(pkgsDontLoad) +} diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 569191bc..95ce3f86 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1548,17 +1548,15 @@ loadPkgs <- function(reqdPkgs) { checkSpaDES.coreMinVersion(allPkgs) allPkgs <- grep("^SpaDES.core\\>", allPkgs, value = TRUE, invert = TRUE) - needOnlyInstall <- NULL - if (is.character(getOption("spades.reqdPkgsDontLoad", NULL))) { - allPkgs <- allPkgs[!Require::extractPkgName(allPkgs) %in% getOption("spades.reqdPkgsDontLoad", NULL)] - needOnlyInstall <- getOption("spades.reqdPkgsDontLoad", NULL) - } + pkgsDontLoad <- getOption("spades.reqdPkgsDontLoad", NULL) + allPkgs <- reqdPkgsDontLoad(allPkgs, pkgsDontLoad) + if (getOption("spades.useRequire")) { getCRANrepos(ind = 1) # running this first is neutral if it is set - Require(allPkgs, standAlone = FALSE, upgrade = FALSE) - if (!is.null(needOnlyInstall)) { + Require(allPkgs, require = require, standAlone = FALSE, upgrade = FALSE) + if (!is.null(pkgsDontLoad)) { verbose <- getOption("reproducible.verbose") - Require::Require(needOnlyInstall, require = FALSE, standAlone = FALSE, + Require::Require(pkgsDontLoad, require = FALSE, standAlone = FALSE, upgrade = FALSE, verbose = verbose - 1) } # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index e3e83cbd..0ccff3fc 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -1039,7 +1039,7 @@ test_that("debug using logging", { }) test_that("options('reproducible.reqdPkgsDontLoad", { - dontLoad <- "sp" + dontLoad <- "ggplot2" # can't be sp, raster because already loaded skip_if_not_installed(dontLoad) unloadNamespace(dontLoad) @@ -1062,8 +1062,8 @@ test_that("options('reproducible.reqdPkgsDontLoad", { timeframe = as.POSIXlt(c(NA, NA)), timeunit = "year", citation = list("citation.bib"), - documentation = list("README.md", "test.Rmd"), - reqdPkgs = list("sp"), + documentation = list("README.md", "test.Rmd"),', +paste0(" reqdPkgs = list(\'", dontLoad, "\'),"),' parameters = rbind( ), inputObjects = bindrows( From a9552db39118cbfc92b42268a4adc1e4bbd2a3a0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 13 Nov 2024 13:48:53 -0800 Subject: [PATCH 018/128] doc fail --- R/options.R | 2 +- man/spadesOptions.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/options.R b/R/options.R index 2754a395..75062414 100644 --- a/R/options.R +++ b/R/options.R @@ -139,7 +139,7 @@ #' `spades.reqdPkgsDontLoad` \tab `"box"` \tab Specify any packages that should not #' be \emph{loaded} i.e., no `library` or `require`, but they should be installed if #' listed. The default (`"box"`) is a package that returns a warning if it is -#' loaded, and so it is excluded from loading. +#' loaded, and so it is excluded from loading.\cr #' #' `spades.saveFileExtensions` \tab `NULL` \tab #' a `data.frame` with 3 columns, `exts`, `fun`, and `package` indicating which diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index a47c03b1..57349dd3 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -142,7 +142,7 @@ There is a message which describes how to find that. \cr \code{spades.reqdPkgsDontLoad} \tab \code{"box"} \tab Specify any packages that should not be \emph{loaded} i.e., no \code{library} or \code{require}, but they should be installed if listed. The default (\code{"box"}) is a package that returns a warning if it is -loaded, and so it is excluded from loading. +loaded, and so it is excluded from loading.\cr \code{spades.saveFileExtensions} \tab \code{NULL} \tab a \code{data.frame} with 3 columns, \code{exts}, \code{fun}, and \code{package} indicating which From 221da243343b476dc9bfef5532db6e6798d9496a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 25 Nov 2024 16:04:02 -0800 Subject: [PATCH 019/128] Revert "restartSpades doesn't have clockTime" This reverts commit a77e724b2c4ecef4420f686956eab5be8115bfb2. --- R/restart.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/restart.R b/R/restart.R index e58c6651..08ff6d78 100755 --- a/R/restart.R +++ b/R/restart.R @@ -102,7 +102,7 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = numMods <- min(length(sim$.recoverableObjs), numEvents) if (numMods > 0) { com <- completed(sim) - etSecs <- sum(com[, et := difftime(._clockTime, ._prevEventTimeFinish, units = "secs"), + etSecs <- sum(com[, et := difftime(clockTime, ._prevEventTimeFinish, units = "secs"), by = seq_len(NROW(com))]$et) # remove the times of the completed events - 1 because the restartSpaDES includes the incompleted event From 8b8c56aea0c47a1a2fc822c513ba7c83e66c68d5 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Mon, 25 Nov 2024 16:07:40 -0800 Subject: [PATCH 020/128] when copying over objs from Cache, don't copy ._*** objs; they are sim specific (e.g., clock time) --- R/cache.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/cache.R b/R/cache.R index ce8faa8c..db79266f 100644 --- a/R/cache.R +++ b/R/cache.R @@ -684,8 +684,10 @@ setMethod( } # Now changed objects if (length(unlist(changedModEnvObjs))) { + # if (identical(currentModule(object), "canClimateData")) browser() Map(nam = names(changedModEnvObjs), objs = changedModEnvObjs, function(nam, objs) { - objNames <- names(objs$.objects) + objNames <- names(objs$.objects) # used to be "names(...)" -- but don't want `._` objs + objNames <- grep("^._.+", objNames, value = TRUE, invert = TRUE) if (!is.null(objNames)) list2env(mget(objNames, envir = simFromCache@.xData$.mods[[nam]][[".objects"]]), envir = simPost@.xData$.mods[[nam]][[".objects"]]) From 71c95ab6d9af6c712666707cd19338c03c3d9d56 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 2 Dec 2024 14:17:07 -0800 Subject: [PATCH 021/128] restartSpades needs temporary sim@current; like simInit --- R/restart.R | 2 ++ R/simulation-parseModule.R | 23 +++++++++++++++++------ 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/R/restart.R b/R/restart.R index 08ff6d78..9babf54d 100755 --- a/R/restart.R +++ b/R/restart.R @@ -203,6 +203,7 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = doesntUseNamespacing <- !.isNamespaced(sim, module) # evaluate the rest of the parsed file + sim <- currentModuleTemporary(sim, mBase) if (doesntUseNamespacing) { out1 <- evalWithActiveCode(pp[[1]], sim@.xData, @@ -225,6 +226,7 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = #list2env(as.list(ee, all.names = TRUE), envir = sim@.xData[[module]]) invisible() }) + sim@current <- list() options(opt) # reset activeBinding mod diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index 7c4c2806..f50f03f4 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -214,12 +214,13 @@ setMethod( mBase <- basename(m) ## temporarily assign current module - sim@current <- list( - eventTime = start(sim), - moduleName = mBase, - eventType = ".inputObjects", - eventPriority = .normal() - ) + sim <- currentModuleTemporary(sim, mBase) + # sim@current <- list( + # eventTime = start(sim), + # moduleName = mBase, + # eventType = ".inputObjects", + # eventPriority = .normal() + # ) prevNamedModules <- if (!is.null(unlist(sim@depends@dependencies))) { unlist(lapply(sim@depends@dependencies, function(x) slot(x, "name"))) @@ -673,3 +674,13 @@ reqdPkgsDontLoad <- function(allPkgs, pkgsDontLoad = getOption("spades.reqdPkgsD spadesReqdPkgsDontLoad <- function(pkgsDontLoad) { is.character(pkgsDontLoad) } + +currentModuleTemporary <- function(sim, mBase) { + sim@current <- list( + eventTime = start(sim), + moduleName = mBase, + eventType = ".inputObjects", + eventPriority = .normal() + ) + sim +} From b8b37dec83e4a1fea28e976771c693120c391376 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 2 Dec 2024 14:17:32 -0800 Subject: [PATCH 022/128] bugfix useBox --> getOption(spades.useBox) --- DESCRIPTION | 4 ++-- R/simulation-simInit.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index dc371444..fd73eec0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-11-13 -Version: 2.1.5.9003 +Date: 2024-12-02 +Version: 2.1.5.9004 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 13194481..21ca38bc 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1564,7 +1564,7 @@ loadPkgs <- function(reqdPkgs) { } # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) } else { - if (!useBox) { + if (!getOption("spades.useBox")) { allPkgs <- unique(Require::extractPkgName(allPkgs)) loadedPkgs <- lapply(allPkgs, base::require, character.only = TRUE) } From 63a5e11ded903a9476b4bdbdf1c47c259d502b2a Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Mon, 2 Dec 2024 14:41:09 -0800 Subject: [PATCH 023/128] restartSpades with box fix; pkgs --- DESCRIPTION | 2 +- R/restart.R | 12 +++++------- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fd73eec0..1b1acca2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core Date: 2024-12-02 -Version: 2.1.5.9004 +Version: 2.1.5.9005 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/restart.R b/R/restart.R index 9babf54d..e13d2fc9 100755 --- a/R/restart.R +++ b/R/restart.R @@ -203,11 +203,10 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = doesntUseNamespacing <- !.isNamespaced(sim, module) # evaluate the rest of the parsed file - sim <- currentModuleTemporary(sim, mBase) + sim <- currentModuleTemporary(sim, module) + pkgs = slot(slot(depends(sim), "dependencies")[[module]], "reqdPkgs") if (doesntUseNamespacing) { - out1 <- evalWithActiveCode(pp[[1]], - sim@.xData, - sim = sim) + out1 <- evalWithActiveCode(pp[[1]], sim@.xData, sim = sim, pkgs = pkgs) } @@ -217,9 +216,8 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = #ee <- new.env() #ee$sim <- sim # sim@.xData[[module]]$sim <- sim - lapply(pp, function(pp1) evalWithActiveCode(pp1, - sim@.xData$.mods[[module]], - sim = sim)) + lapply(pp, function(pp1) + evalWithActiveCode(pp1, sim@.xData$.mods[[module]], sim = sim, pkgs = pkgs)) message(cli::col_blue("Reparsing", module, "source code")) } #rm(list = "sim", envir = ee) From bdff6ae4ee1a433d94f9c208c2ad75f7025b1e04 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Mon, 16 Dec 2024 13:41:20 -0800 Subject: [PATCH 024/128] allow parameter class to be a vector --- R/module-define.R | 12 +++++++++--- R/simulation-simInit.R | 1 - 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/R/module-define.R b/R/module-define.R index 6ba727c2..2716c9e3 100644 --- a/R/module-define.R +++ b/R/module-define.R @@ -441,10 +441,16 @@ defineParameter <- function(name, class, default, min, max, desc, ...) { paramDesc = character(0), stringsAsFactors = FALSE)) if (is.character(name) && is.character(class) && missing(min) && missing(max)) { NAtypes <- c("character", "complex", "integer", "logical", "numeric") # nolint - if (class %in% NAtypes) { + if (any(class %in% NAtypes)) { + + NAtypeToUse <- vapply(class, function(cla) is(default, cla), FUN.VALUE = logical(1)) + NAtypeToUse <- if (any(NAtypeToUse)) + names(NAtypeToUse)[NAtypeToUse] + else + class[1] # coerce `min` and `max` to same type as `default` - min <- as(NA, class) - max <- as(NA, class) + min <- as(NA, NAtypeToUse) # if a vector of possible classes, take first + max <- as(NA, NAtypeToUse) # if a vector of possible classes, take first } else { min <- NA max <- NA diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 21ca38bc..bc2b2375 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -576,7 +576,6 @@ setMethod( ## do multi-pass if there are parent modules; first for parents, then for children all_parsed <- FALSE - # browser(expr = exists("._simInit_5")) while (!all_parsed) { sim <- .parseModule(sim, as.list(sim@modules), From a167fa2f194020b86d240329a65d70e20c48ae93 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Dec 2024 18:15:03 -0800 Subject: [PATCH 025/128] missing userTags in spades module calls --- R/simulation-spades.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index e73671ac..e3b37451 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1372,7 +1372,10 @@ setMethod( classOptions = classOptions, showSimilar = showSimilar, cachePath = sim@paths[["cachePath"]], - .functionName = moduleCall, verbose = verbose)) + .functionName = moduleCall, verbose = verbose, + userTags = c(paste0("module:", cur[["moduleName"]]), + paste0("eventType:", cur[["eventType"]]), + paste0("eventTime:", time(sim))))) } else { ## Faster just to pass the NULL and just call it directly inside .runEvent expression(get(moduleCall, envir = fnEnv)(sim, cur[["eventTime"]], cur[["eventType"]])) From cfea4d3ab891341e6112a6d5267664585f8daa09 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 17 Dec 2024 18:55:58 -0800 Subject: [PATCH 026/128] bump version --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1b1acca2..f5bd2fd4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-12-02 -Version: 2.1.5.9005 +Date: 2024-12-17 +Version: 2.1.5.9006 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), From 732c1928cbb454500227e52b4aef657190ba301a Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:01:20 +0000 Subject: [PATCH 027/128] quick = FALSE default for objSize.simList --- R/cache.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/R/cache.R b/R/cache.R index db79266f..203e87ed 100644 --- a/R/cache.R +++ b/R/cache.R @@ -927,7 +927,7 @@ if (!exists("objSize")) { #' a <- simInit(objects = list(d = 1:10, b = 2:20)) #' objSize(a) #' utils::object.size(a) -objSize.simList <- function(x, quick = TRUE, ...) { +objSize.simList <- function(x, quick = FALSE, ...) { total <- try(obj_size(x, quick = TRUE), silent = TRUE) # failing due to lobstr issue #72 if (!is(total, "try-error")) { @@ -937,9 +937,12 @@ objSize.simList <- function(x, quick = 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")) + # if (!quick) + attr(total, "objSize") <- list(sim = attr(aa, "objSize"), + other = attr(otherParts, "objSize")) + # browser() + # attr(total, "objSize") <- sum(unlist(attr(aa, "objSize")), unlist(attr(otherParts, "objSize"))) + # class(attr(total, "objSize")) <- "lobstr_bytes" } else { total <- NA From d918a8364e45fe051904ee0140842cdb3fafa1fc Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:01:51 +0000 Subject: [PATCH 028/128] restartSpades mods; saveState --- R/restart.R | 110 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 68 insertions(+), 42 deletions(-) diff --git a/R/restart.R b/R/restart.R index e13d2fc9..93098a7f 100755 --- a/R/restart.R +++ b/R/restart.R @@ -51,7 +51,9 @@ doEvent.restartR <- function(sim, eventTime, eventType, debug = FALSE) { #' *if the `simList` was not modified yet during the event which caused the error*. #' The `simList` will be in the state it was at the time of the error. #' -#' @param sim A `simList.` If not supplied (the default), this will take the `sim` from +#' @param sim A `simList` or a filename that will load a `simList`, e.g., from +#' `saveState` or `saveSimList`. If not supplied (the default), +#' this will take the `sim` from #' `savedSimEnv()$.sim`, i.e., the one that was interrupted #' #' @param module A character string length one naming the module that caused the error and @@ -93,6 +95,10 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = sim <- savedSimEnv()$.sim } + if (is.character(sim)) { + sim <- SpaDES.core::loadSimList(sim) + } + if (is.null(module)) { # Source the file you changed, into the correct location in the simList module <- events(sim)[["moduleName"]][1] @@ -189,43 +195,10 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = invisible() }) - # modules <- if (!is.list(module)) as.list(module) else module - opt <- options("spades.moduleCodeChecks" = FALSE) - - out <- lapply(modules, function(module) { - pp <- list() - moduleFolder <- file.path(modulePath(sim, module = module), module) - if (file.exists(file.path(moduleFolder, paste0(module, ".R")))) { - # pp[[1]] <- .parseConditional(sim, file.path(moduleFolder, paste0(module, ".R"))) - pp[[1]] <- parse(file.path(moduleFolder, paste0(module, ".R"))) - subFiles <- dir(file.path(moduleFolder, "R"), full.names = TRUE) - - doesntUseNamespacing <- !.isNamespaced(sim, module) - - # evaluate the rest of the parsed file - sim <- currentModuleTemporary(sim, module) - pkgs = slot(slot(depends(sim), "dependencies")[[module]], "reqdPkgs") - if (doesntUseNamespacing) { - out1 <- evalWithActiveCode(pp[[1]], sim@.xData, sim = sim, pkgs = pkgs) - } - + # Once reversed, remove the .recoverableObjs + sim$.recoverableObjs <- NULL - if (length(subFiles)) { - pp[seq_len(length(subFiles)) + 1] <- lapply(subFiles, function(ff) parse(ff)) - } - #ee <- new.env() - #ee$sim <- sim - # sim@.xData[[module]]$sim <- sim - lapply(pp, function(pp1) - evalWithActiveCode(pp1, sim@.xData$.mods[[module]], sim = sim, pkgs = pkgs)) - message(cli::col_blue("Reparsing", module, "source code")) - } - #rm(list = "sim", envir = ee) - #list2env(as.list(ee, all.names = TRUE), envir = sim@.xData[[module]]) - invisible() - }) - sim@current <- list() - options(opt) + # modules <- if (!is.list(module)) as.list(module) else module # reset activeBinding mod out <- lapply(modules, function(mod) { @@ -237,17 +210,70 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = # Remove all added events that occurred during the events, i.e., via scheduleEvent sim@events <- setdiff(sim@events, unlist(sim$.addedEvents[seq_len(numMods)], recursive = FALSE)) - + sim@current <- list() assign(".Random.seed", sim@.xData$._randomSeed[[numMods]], envir = .GlobalEnv) - - if (restart) - sim <- spades(sim, ...) } else { - message("There was no interrupted spades call; returning sim as is") + modules <- modules(sim) } + + opt <- options("spades.moduleCodeChecks" = FALSE) + + + out <- lapply(modules, function(module) { + pp <- list() + moduleFolder <- file.path(modulePath(sim, module = module), module) + if (file.exists(file.path(moduleFolder, paste0(module, ".R")))) { + # pp[[1]] <- .parseConditional(sim, file.path(moduleFolder, paste0(module, ".R"))) + pp[[1]] <- parse(file.path(moduleFolder, paste0(module, ".R"))) + subFiles <- dir(file.path(moduleFolder, "R"), full.names = TRUE) + + doesntUseNamespacing <- !.isNamespaced(sim, module) + + # evaluate the rest of the parsed file + sim <- currentModuleTemporary(sim, module) + pkgs = slot(slot(depends(sim), "dependencies")[[module]], "reqdPkgs") + if (doesntUseNamespacing) { + out1 <- evalWithActiveCode(pp[[1]], sim@.xData, sim = sim, pkgs = pkgs) + } + + + if (length(subFiles)) { + pp[seq_len(length(subFiles)) + 1] <- lapply(subFiles, function(ff) parse(ff)) + } + #ee <- new.env() + #ee$sim <- sim + # sim@.xData[[module]]$sim <- sim + lapply(pp, function(pp1) + evalWithActiveCode(pp1, sim@.xData$.mods[[module]], sim = sim, pkgs = pkgs)) + message(cli::col_blue("Reparsing ", module, " source code")) + } + #rm(list = "sim", envir = ee) + #list2env(as.list(ee, all.names = TRUE), envir = sim@.xData[[module]]) + invisible() + }) + options(opt) + + if (restart) + sim <- spades(sim, ...) + # } else { + # message("There was no interrupted spades call; returning sim as is") + # } return(sim) } +#' @export +#' @rdname restartSpades +#' @param filename The filename to save the sim state. +#' +#' `saveState` is a wrapper around `restartSpades` and `saveSimList`. You can +#' pass arguments to the `...` that will be passed to `saveSimList`, such as +#' `modules`, `inputs`, `outputs`. +saveState <- function(filename, ...){ + sim <- restartSpades(restart = FALSE) + saveSimList(sim, filename, ...) + message("Saved! ", filename) +} + #' Restart R programmatically #' #' This will attempt to restart the R session, reloading all packages, and From 73d809a938294a7688a863efc1d54fcbd29f8823 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:08:05 +0000 Subject: [PATCH 029/128] saveSimList add files as explicit param; bugfix inputFNs --- R/saveLoadSimList.R | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/R/saveLoadSimList.R b/R/saveLoadSimList.R index 4ebf44e6..4a7903a9 100644 --- a/R/saveLoadSimList.R +++ b/R/saveLoadSimList.R @@ -54,6 +54,12 @@ #' @param projectPath Should be the "top level" or project path for the `simList`. #' Defaults to `getwd()`. All other paths will be made relative with respect to #' this if nested within this. +#' @param files Logical. Should all the files in the optional `outputs`, `inputs`, +#' `cache` be saved. If this is `TRUE`, then the resulting `filename` will be +#' silently converted to an archive file with the appropriate extension e.g., +#' `.zip` or `.tar.gz`. This will automatically be `TRUE` if any of the `outputs`, +#' `inputs` or `cache` are `TRUE`. Setting this to `FALSE` will turn off the +#' saving of files specified in `inputs(sim)`, `outputs(sim)` or the cache. #' #' @param ... Additional arguments. See Details. #' @@ -73,13 +79,14 @@ #' @rdname saveSimList #' @seealso [loadSimList()] saveSimList <- function(sim, filename, projectPath = getwd(), - outputs = TRUE, inputs = TRUE, cache = FALSE, envir, ...) { + outputs = TRUE, inputs = TRUE, cache = FALSE, envir, + files = TRUE, ...) { checkSimListExts(filename) dots <- list(...) ## user can explicitly override archiving files if FALSE - if (isFALSE(dots$files)) { + if (isFALSE(files)) { files <- cache <- inputs <- outputs <- FALSE } else { files <- TRUE @@ -206,7 +213,7 @@ saveSimList <- function(sim, filename, projectPath = getwd(), if (isTRUE(inputs)) { ins <- inputs(sim) if (NROW(ins)) { - ins[ins$loaded %in% TRUE]$file + inputFNs <- ins[ins$loaded %in% TRUE, ]$file otherFns <- c(otherFns, inputFNs) } } @@ -217,6 +224,7 @@ saveSimList <- function(sim, filename, projectPath = getwd(), allFns <- gsub(origPaths[[p]], symlinks[[p]], allFns) } } + allFns <- na.omit(allFns) relFns <- makeRelative(c(fileToDelete, allFns), projectPath) |> unname() From f4afcc081c23519cf7f7429e1a33d7b9f5642493 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:09:43 +0000 Subject: [PATCH 030/128] protect using box with spades.useBox --- R/simulation-parseModule.R | 48 ++++++++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 18 deletions(-) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index f50f03f4..8f121590 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -555,6 +555,7 @@ setMethod( tmp[["defineModuleItem"]] <- grepl(pattern = "^defineModule", tmp[["parsedFile"]]) tmp[["pf"]] <- tmp[["parsedFile"]][tmp[["defineModuleItem"]]] } + return(tmp) } @@ -566,31 +567,42 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = # Create a temporary environment to source into, adding the sim object so that # code can be evaluated with the sim, e.g., currentModule(sim) #tmpEnvir <- new.env(parent = asNamespace("SpaDES.core")) - tmpEnvir <- new.env(parent = envir) + tmpEnvirForPkgs <- new.env(parent = envir) + # tmpEnvir <- new.env(parent = envir) + tmpEnvir <- new.env(parent = tmpEnvirForPkgs) # This needs to be unconnected to main sim so that object sizes don't blow up simCopy <- Copy(sim, objects = FALSE) simCopy$.mods <- Copy(sim$.mods) tmpEnvir$sim <- simCopy - ll <- lapply(parsedModuleNoDefineModule, - function(x) tryCatch(eval(x, envir = tmpEnvir), - error = function(x) "ERROR")) - cm <- currentModule(tmpEnvir$sim) - if (length(cm)) - if (!cm %in% unlist(.coreModules())) { - pkgs <- Require::extractPkgName(unlist(eval(pkgs))) - lapply(pkgs, function(p) { - allFns <- ls(envir = asNamespace(p)) - val <- paste0("box::use(", p, "[...]", ")") - eval(as.call(parse(text = val))[[1]], envir = tmpEnvir) - if (any("mod" == allFns)) { - rm(list = "mod", envir = parent.env(tmpEnvir)) - messageVerbose("mod will be masked from ", p) - } - }) - } + ll <- local({ + lapply(parsedModuleNoDefineModule, + function(x) tryCatch(eval(x, envir = tmpEnvir), + error = function(x) "ERROR")) + }) + # This tests whether there is a leak -- this should be 1 + # it says, how big is the function, compared to how big is the environment that holds the function + # If it is 1, it means there are only functions in that environment, no objects + # length(serialize(tmpEnvir$prepare_IgnitionFit, NULL))/object.size(mget(ls(tmpEnvir), tmpEnvir)) + + if (getOption("spades.useBox")) { + cm <- currentModule(tmpEnvir$sim) + if (length(cm)) + if (!cm %in% unlist(.coreModules())) { + pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + lapply(pkgs, function(p) { + allFns <- ls(envir = asNamespace(p)) + val <- paste0("box::use(", p, "[...]", ")") + eval(as.call(parse(text = val))[[1]], envir = tmpEnvirForPkgs) + if (any("mod" == allFns)) { + rm(list = "mod", envir = parent.env(tmpEnvirForPkgs)) + messageVerbose("mod will be masked from ", p) + } + }) + } + } activeCode <- unlist(lapply(ll, function(x) identical("ERROR", x))) From 0d029e1e3e22d080c1447797118f2e97591c1a8f Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:10:42 +0000 Subject: [PATCH 031/128] ._startClockTime fixes in simInit; debugToVerbose --- R/simulation-simInit.R | 105 +++++++++++++++++++++++++++++------------ 1 file changed, 75 insertions(+), 30 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index bc2b2375..c6fe6e15 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -368,9 +368,17 @@ setMethod( loadOrder, notOlderThan, ...) { - ._startClockTime <- Sys.time() + dots <- list(...) + if (is.null(dots$._startClockTime)) + ._startClockTime <- Sys.time() + else + ._startClockTime <- dots$._startClockTime + dots$._startClockTime <- NULL + dotNames <- setdiff(...names(), "._startClockTime") # create <- List object for the simulation sim <- new("simList") + sim@.xData[["._startClockTime"]] <- ._startClockTime + sim$._simInitElapsedTime <- 0 # loggingMessage helpers ._simNesting <- simNestingSetup(...) @@ -385,6 +393,7 @@ setMethod( options(opt) sim <- elapsedTimeInSimInit(._startClockTime, sim) ._startClockTime <- Sys.time() + sim@.xData[["._startClockTime"]] <- NULL dt <- difftime(._startClockTime, ._startClockTime - sim$._simInitElapsedTime) message("Elapsed time for simInit: ", format(dt, format = "auto")) }, add = TRUE) @@ -393,11 +402,11 @@ setMethod( checkPath(p, create = TRUE) }) - if (length(...names())) { - objects <- append(objects, list(...)) + if (length(dotNames)) { + objects <- append(objects, dots) # set the options; then set them back on exit - optsFromDots <- dealWithOptions(objects = objects, sim = sim, ...) + optsFromDots <- dealWithOptions(objects = objects, sim = sim, dotNames = dotNames) if (!is.null(optsFromDots$optsPrev)) { # remove from `objects` as these should not be there objects <- objects[optsFromDots$keepObjNames] @@ -793,8 +802,8 @@ setMethod( ## check the parameters supplied by the user checkParams(sim, dotParams, unlist(sim@paths[["modulePath"]])) - sim <- elapsedTimeInSimInit(._startClockTime, sim) - ._startClockTime <- Sys.time() + #sim <- elapsedTimeInSimInit(._startClockTime, sim) + #._startClockTime <- Sys.time() }, message = function(m) { message(loggingMessage(m$message, prefix = prefixSimInit)) @@ -1111,26 +1120,39 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out # because Cache (and possibly others, we have to strip any other call wrapping simInitAndSpades) lsAllNames <- ls(all.names = TRUE) - lsAllNames <- lsAllNames[lsAllNames != "..."] + # lsAllNames <- lsAllNames[lsAllNames != "..."] + formsSimInit <- setdiff(formalArgs(simInit), "...") + formsSpades <- setdiff(formalArgs(spades), "...") + formsOnlySpades <- setdiff(formsSpades, formsSimInit) + + # lsAllNames <- ls() + passedArgs <- as.list(match.call(simInit))[-1] + passedArgsNames <- setdiff(names(passedArgs), formsOnlySpades) + namesMatchCall <- names(match.call()) + defaultArgs <- .fillInSimInit(list(), namesMatchCall) + simInitCall <- as.call(x = append(list(simInit), append(passedArgs[passedArgsNames], defaultArgs))) + sim <- eval(simInitCall, envir = parent.frame()) - objsAll <- mget(lsAllNames, envir = environment()) - objsSimInit <- objsAll[formalArgs(simInit)] + # objsAll <- mget(lsAllNames, envir = environment()) + # objsSimInit <- objsAll[formalArgs(simInit)] - namesMatchCall <- names(match.call()) - objsSimInit <- .fillInSimInit(objsSimInit, namesMatchCall) + # objsSimInit <- .fillInSimInit(objsSimInit, namesMatchCall) + + # namesMatchCall <- names(match.call()) - sim <- simInit(times = objsSimInit$times, params = objsSimInit$params, - modules = objsSimInit$modules, objects = objsSimInit$objects, - paths = objsSimInit$paths, inputs = objsSimInit$inputs, - outputs = objsSimInit$outputs, loadOrder = objsSimInit$loadOrder, - notOlderThan = objsSimInit$notOlderThan, ...) + # sim <- simInit(times = objsSimInit$times, params = objsSimInit$params, + # modules = objsSimInit$modules, objects = objsSimInit$objects, + # paths = objsSimInit$paths, inputs = objsSimInit$inputs, + # outputs = objsSimInit$outputs, loadOrder = objsSimInit$loadOrder, + # notOlderThan = objsSimInit$notOlderThan, ...) opts <- options(spades.loadReqdPkgs = FALSE) on.exit(options(opts), add = TRUE) #sim <- do.call(simInit, objsSimInit) # serializes the objects - spadesFormals <- formalArgs(spades)[formalArgs(spades) %in% names(objsAll)] + passedArgsToSpades <- as.list(match.call(spades))[-1] + spadesFormals <- formalArgs(spades)[formalArgs(spades) %in% names(passedArgsToSpades)] ## quote is so that entire simList is not serialized in do.call - objsSpades <- append(alist(sim = sim), objsAll[spadesFormals]) + objsSpades <- append(alist(sim = sim), passedArgs[spadesFormals]) sim <- do.call(spades, objsSpades) } @@ -1263,9 +1285,15 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out } } - message(cli::col_green("Running .inputObjects for ", mBase, sep = "")) + # message(cli::col_green("Running .inputObjects for ", mBase, sep = "")) debug <- getDebug() # from options first, then override if in a simInitAndSpades + if (is.call(debug)) + debug <- eval(debug) + + cur <- sim@current + curModNam <- cur$moduleName + debugMessage(debug, sim, cur, sim@.xData$.mods[[curModNam]], curModNam) if (!(FALSE %in% debug || any(is.na(debug)))) objsIsNullBefore <- objsAreNull(sim) @@ -1334,6 +1362,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) pkgs <- c(pkgs, "stats") do.call(box::use, lapply(pkgs, as.name)) + debugForCache <- debugToVerbose(debug) sim <- Cache(.inputObjects, sim, .objects = objectsToEvaluateForCaching, notOlderThan = notOlderThan, @@ -1346,7 +1375,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out modules = mBase), showSimilar = showSimilar, userTags = c(paste0("module:", mBase), - "eventType:.inputObjects"), verbose = debug) + "eventType:.inputObjects"), verbose = debugForCache) } if (allowSequentialCaching) { sim <- allowSequentialCachingUpdateTags(sim, cacheIt) @@ -1553,9 +1582,9 @@ loadPkgs <- function(reqdPkgs) { pkgsDontLoad <- getOption("spades.reqdPkgsDontLoad", NULL) allPkgs <- reqdPkgsDontLoad(allPkgs, pkgsDontLoad) - if (getOption("spades.useRequire")) { + if (getOption("spades.useRequire") && !getOption("spades.useBox")) { getCRANrepos(ind = 1) # running this first is neutral if it is set - Require(allPkgs, require = require, standAlone = FALSE, upgrade = FALSE) + Require(allPkgs, require = TRUE, standAlone = FALSE, upgrade = FALSE) if (!is.null(pkgsDontLoad)) { verbose <- getOption("reproducible.verbose") Require::Require(pkgsDontLoad, require = FALSE, standAlone = FALSE, @@ -1599,6 +1628,9 @@ resolveDepsRunInitIfPoss <- function(sim, modules, paths, params, objects, input stripNcharsSpades <- 2 #stripNchars + 2 stripNcharsSimInit <- stripNchars + 5 debug <- getDebug() # from options first, then override if in a simInitAndSpades + if (is.call(debug)) + debug <- eval(debug) + len <- length(sim[["._simNesting"]]) ._simNesting <- sim[["._simNesting"]] val <- "intsDrngSmInt" @@ -1608,7 +1640,8 @@ resolveDepsRunInitIfPoss <- function(sim, modules, paths, params, objects, input simAlt <- simInit(modules = canSafelyRunInit, paths = paths, params = params, objects = objects, inputs = inputs, outputs = outputs, times = list(start = as.numeric(start(sim)), - end = as.numeric(end(sim)), timeunit = timeunit(sim))) + end = as.numeric(end(sim)), timeunit = timeunit(sim)), + ._startClockTime = sim$._startClockTime) simAlt@.xData$._ranInitDuringSimInit <- completed(simAlt)$moduleName messageVerbose(cli::col_yellow("**** Running spades call for:", safeToRunModules, "****")) simAltOut <- spades(simAlt, events = "init", debug = debug) @@ -1790,7 +1823,7 @@ getDebug <- function() { #' @keywords internal #' @importFrom Require messageVerbose -dealWithOptions <- function(objects, ..., sim, +dealWithOptions <- function(objects, dotNames, sim, thePkgs = c("SpaDES.core", "reproducible", "Require")) { finished <- FALSE @@ -1803,10 +1836,10 @@ dealWithOptions <- function(objects, ..., sim, currOptionsLong <- names(unlist(unname(allOptions), recursive = FALSE)) currOptionsShort <- gsub(thePkgsGrep, "", currOptionsLong) - namesPoss <- if (is.null(...names()) && !missing(sim)) { + namesPoss <- if (is.null(dotNames) && !missing(sim)) { names(sim) } else { - ...names() + dotNames } optionsDotsShort <- currOptionsShort %in% namesPoss @@ -1878,11 +1911,13 @@ dealWithOptions <- function(objects, ..., sim, elapsedTimeInSimInit <- function(._startClockTime, sim) { elapsed <- difftime(Sys.time(), ._startClockTime, units = "sec") - if (is.null(sim@.xData[["._simInitElapsedTime"]])) { + #if (is.null(sim@.xData[["._simInitElapsedTime"]])) { + # browser() sim@.xData[["._simInitElapsedTime"]] <- elapsed - } else { - sim@.xData[["._simInitElapsedTime"]] <- sim@.xData[["._simInitElapsedTime"]] + elapsed - } + #} else { + # browser() + # sim@.xData[["._simInitElapsedTime"]] <- sim@.xData[["._simInitElapsedTime"]] + elapsed + #} sim } @@ -1921,3 +1956,13 @@ simNestingOverride <- function(sim, mBase) { isMacOSX <- function() isMac <- tolower(Sys.info()["sysname"]) == "darwin" + + + +debugToVerbose <- function(debug) { + debugOut <- sapply(debug, function(de) + if (is.numeric(de) || is.logical(de)) de else !is.null(de) + ) + debugOut[is.na(debugOut)] <- FALSE + any(as.logical(debugOut)) +} From 086ff8bd6dc73fced5171e2e0bc47576b14b2d94 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 18:11:43 +0000 Subject: [PATCH 032/128] debugToVerbose in spades --- R/simulation-spades.R | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index e3b37451..3f36f155 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -851,7 +851,7 @@ setMethod( ...) { # set the options; then set them back on exit - optsFromDots <- dealWithOptions(sim = sim) + optsFromDots <- dealWithOptions(sim = sim, dotNames = ...names()) if (!is.null(optsFromDots$optsPrev)) { # remove from `sim` as these should not be there rm(list = unique(names(optsFromDots$optionsAsProvided)), envir = envir(sim)) @@ -1239,7 +1239,6 @@ setMethod( } if (useNormalMessaging) { - # if (grepl("projecting", m$message)) browser() if (isTRUE(any(grepl("\b", m$message)))) { m$message <- paste0("\b", gsub("\b *", " ", m$message), "\b") # message(paste0("\b", gsub("\b *", " ", m$message), "\b")) @@ -1359,7 +1358,7 @@ setMethod( modules = cur[["moduleName"]]) } } - verbose <- if (is.numeric(debug)) debug else !debug %in% FALSE + verbose <- debugToVerbose(debug) fnCallAsExpr <- if (cacheIt) { # means that a module or event is to be cached modCall <- get(moduleCall, envir = fnEnv) @@ -1381,7 +1380,7 @@ setMethod( expression(get(moduleCall, envir = fnEnv)(sim, cur[["eventTime"]], cur[["eventType"]])) } - if (!(FALSE %in% debug || any(is.na(debug)))) { + if (debugToVerbose(debug)) { objsIsNullBefore <- objsAreNull(sim) } @@ -1395,13 +1394,13 @@ setMethod( runFnCallAsExpr <- is.null(attr(sim, "runFnCallAsExpr")) } - # if (cur$eventType %in% "prepSpreadFitData") browser() rr <- .Random.seed if (runFnCallAsExpr) { + # if (identical(cur$eventType, "prepIgnitionFitData")) browser() sim <- eval(fnCallAsExpr) ## slower than more direct version just above } if (identical(rr, .Random.seed)) { - message(cli::bg_yellow(cur[["moduleName"]])) # browser() + message(cli::bg_yellow(cur[["moduleName"]])) } if (allowSequentialCaching) { sim <- allowSequentialCachingUpdateTags(sim, cacheIt) @@ -1419,7 +1418,7 @@ setMethod( } } - if (!(FALSE %in% debug || any(is.na(debug)))) { + if (debugToVerbose(debug)) { sim <- objectsCreatedPost(sim, objsIsNullBefore) } @@ -1920,11 +1919,11 @@ debugMessage <- function(debug, sim, cur, fnEnv, curModuleName) { outMess <- paste0("elpsd: ", format(Sys.time() - compareTime, digits = 2), " | ", paste(format(unname(current(sim)), digits = 4), collapse = " ")) } else { - if (is(debug[[i]], "call")) { + if (is.call(debug[[i]])) {# || is(debug[[i]], "if") || is(debug[[i]], "{")) { outMess <- try(eval(debug[[i]])) } else if (identical(debug[[i]], "simList")) { outMess <- try(capture.output(sim)) - } else if (isTRUE(grepl(debug[[i]], pattern = "\\("))) { + } else if (isTRUE(grepl(debug[[i]], pattern = "\\(")) && !cli::ansi_has_any(debug[i])) { outMess <- try(eval(parse(text = debug[[i]]))) } else if (isTRUE(any(debug[[i]] %in% unlist(cur[c("moduleName", "eventType")])))) { outMess <- NULL @@ -2359,7 +2358,6 @@ clearNextEventInCache <- function(cachePath = getOption("reproducible.cachePath" sequentialCacheText <- "SequentialCache_" appendCompleted <- function(sim, cur) { - # if (cur$moduleName == "checkpoint") browser() cur[["._clockTime"]] <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) @@ -2368,7 +2366,6 @@ appendCompleted <- function(sim, cur) { if (isTRUE(isLastWrong)) { last <- attr(sim, "completedCounter") <- NULL } - # if ("Biomass_borealDataPrep" %in% cur$moduleName && "init" %in% cur$eventType) browser() if (is.null(last)) { prevTime <- cur[["._clockTime"]] } else { From bec480fa52948188ee94cb6970b57a20941c8ae8 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 20:18:29 +0000 Subject: [PATCH 033/128] createDESCRIPTIONandDocs updates for missing .RbuildIgnore; add verbose --- R/createDESCRIPTIONandDocs.R | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 0b2596a9..0db395dc 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -120,7 +120,8 @@ #' } createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.modulePath"), importAll = TRUE, - buildDocuments = TRUE) { + buildDocuments = TRUE, + verbose = getOption("Require.verbose")) { stopifnot( requireNamespace("pkgload", quietly = TRUE), requireNamespace("roxygen2", quietly = TRUE) @@ -161,7 +162,7 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod deps <- unlist(eval(md$reqdPkgs)) dFile <- DESCRIPTIONfileFromModule(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, - packageFolderName) + packageFolderName, verbose = verbose) if (isTRUE(buildDocuments)) { message("Building documentation") @@ -176,8 +177,6 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod RBuildIgnoreFile <- filenameFromFunction(packageFolderName, "", fileExt = ".Rbuildignore") - startCat <- readLines(RBuildIgnoreFile) - rbi <- paste("^.*\\.Rproj$ ^\\.Rproj\\.user$ ^_pkgdown\\.yml$ @@ -206,7 +205,12 @@ vignettes/.*\\.log$ modFiles <- c(paste0(module, ".*"), ".*zip") - rbi <- unique(c(startCat, rbi, modFiles)) + if (file.exists(RBuildIgnoreFile)) { + startCat <- readLines(RBuildIgnoreFile) + rbi <- unique(c(startCat, rbi)) + } + + rbi <- unique(c(rbi, modFiles)) cat(rbi, file = RBuildIgnoreFile, fill = TRUE, sep = "\n") return(invisible()) @@ -223,7 +227,7 @@ filenameForMainFunctions <- function(module, modulePath = ".") DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESPACEFile, filePathImportSpadesCore, - packageFolderName) { + packageFolderName, verbose = getOption("Require.verbose")) { d <- list() d$Package <- .moduleNameNoUnderscore(module) d$Type <- "Package" @@ -297,7 +301,7 @@ DESCRIPTIONfileFromModule <- function(module, md, deps, hasNamespaceFile, NAMESP cat(paste0("RoxygenNote: ", as.character(packageVersion("roxygen2"))), sep = "\n", file = dFile, append = TRUE) - message("New/updated DESCRIPTION file is: ", dFile) + messageVerbose("New/updated DESCRIPTION file is: ", dFile, verbose = verbose) return(dFile) } From a6e5c635e476bd8d97c2df46718b2d372d8bbb09 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 14:25:36 -0800 Subject: [PATCH 034/128] muffleWarning for package:stats may not be available --- R/simulation-simInit.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index bc2b2375..fcee421b 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -806,6 +806,11 @@ setMethod( warningSplitOnColon(w) invokeRestart("muffleWarning") } + # This is a box mishap + if (isTRUE(any(grepl("'package:stats' may not be available when loading", + w$message)))) { + invokeRestart("muffleWarning") + } } ) From 549a9854b6e1518b05de36d5302056df01cedad3 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 14:25:48 -0800 Subject: [PATCH 035/128] useBox option --- DESCRIPTION | 4 ++-- R/simulation-simInit.R | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1b1acca2..b085661f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-12-02 -Version: 2.1.5.9005 +Date: 2024-12-20 +Version: 2.1.5.9006 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index fcee421b..949dcc92 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1338,7 +1338,8 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (runFnCallAsExpr) { pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) pkgs <- c(pkgs, "stats") - do.call(box::use, lapply(pkgs, as.name)) + if (getOption("spades.useBox")) + do.call(box::use, lapply(pkgs, as.name)) sim <- Cache(.inputObjects, sim, .objects = objectsToEvaluateForCaching, notOlderThan = notOlderThan, From 577f03403ba992cbea79875efc1e8e3d866228f7 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 20 Dec 2024 15:59:22 -0800 Subject: [PATCH 036/128] clean up recovery mode in simulation-spades.R --- R/simulation-spades.R | 73 +++++++++++++++++++++++++++++++++---------- 1 file changed, 56 insertions(+), 17 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index e73671ac..a4c31e68 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -913,10 +913,13 @@ setMethod( } sim <- withCallingHandlers({ - recoverModeWrong <- getOption("spades.recoverMode") - if (!is.null(recoverModeWrong)) { - warning("Please set options('recoveryMode') with a 'y', not options('recoverMode')") - } + + ## RecoverMode Step 1 -- set up + recoverModeTypo() + # recoverModeWrong <- getOption("spades.recoverMode") + # if (!is.null(recoverModeWrong)) { + # warning("Please set options('recoveryMode') with a 'y', not options('recoverMode')") + # } recoverMode <- getOption("spades.recoveryMode", FALSE) ## If there already is a sim object saved in the package .savdeSimEnv, it may have objects, @@ -926,6 +929,7 @@ setMethod( svdSimEnv <- savedSimEnv() # can't assign to a function svdSimEnv$.sim <- NULL svdSimEnv$.sim <- sim # set up pointer + ## RecoverMode Step 1 -- End ## set the options("spades.xxxPath") to the values in the sim@paths oldGetPaths <- getPaths() @@ -1001,21 +1005,27 @@ setMethod( if (!.pkgEnv[["skipNamespacing"]]) .modifySearchPath(.pkgEnv$searchPath, removeOthers = TRUE) rm(".timeunits", envir = sim@.xData) + + + ## RecoverMode Step 2 -- on exit if (isTRUE(getOption("spades.saveSimOnExit", FALSE))) { - if (!isTRUE(.pkgEnv$.cleanEnd)) { - if (recoverMode > 0) { - sim <- recoverModeOnExit(sim, rmo, recoverMode) - } - messageInterrupt1(recoverMode) - } else { - message(cli::col_magenta("simList saved in"), "\n", - cli::col_blue("SpaDES.core:::savedSimEnv()$.sim"), "\n", - cli::col_magenta("It will be deleted at next spades() call.")) - } - svdSimEnv <- savedSimEnv() # can't assign to a function - svdSimEnv$.sim <- sim # no copy of objects -- essentially 2 pointers throughout - .pkgEnv$.cleanEnd <- NULL + sim <- saveSimOnExit(recoverMode, sim, rmo) + # if (!isTRUE(.pkgEnv$.cleanEnd)) { + # if (recoverMode > 0) { + # sim <- recoverModeOnExit(sim, rmo, recoverMode) + # } + # messageInterrupt1(recoverMode) + # } else { + # message(cli::col_magenta("simList saved in"), "\n", + # cli::col_blue("SpaDES.core:::savedSimEnv()$.sim"), "\n", + # cli::col_magenta("It will be deleted at next spades() call.")) + # } + # svdSimEnv <- savedSimEnv() # can't assign to a function + # svdSimEnv$.sim <- sim # no copy of objects -- essentially 2 pointers throughout + # .pkgEnv$.cleanEnd <- NULL } + ## RecoverMode Step 2 -- End + # For restarting R -- a few extra pieces, including saving the simList as the last thing if (!is.null(sim$._restartRList)) { sim@simtimes[["current"]] <- sim@events[[1]]$eventTime @@ -1119,11 +1129,14 @@ setMethod( } } + ## RecoverMode Step 3 -- Initiate the RMO (recovery mode object) if (recoverMode > 0) { rmo <- NULL # The recovery mode object allObjNames <- outputObjectNames(sim) if (is.null(allObjNames)) recoverMode <- 0 } + ## RecoverMode Step 3 -- End + useFuture <- getOption("spades.futureEvents", FALSE) if (useFuture) { if (!requireNamespace("future", quietly = TRUE)) @@ -1151,6 +1164,7 @@ setMethod( on.exit(setDTthreads(origDTthreads), add = TRUE) while (sim@simtimes[["current"]] <= sim@simtimes[["end"]]) { + ## RecoverMode Step 4 -- Do Pre if (recoverMode > 0) { rmo <- recoverModePre(sim, rmo, allObjNames, recoverMode) } @@ -1158,6 +1172,7 @@ setMethod( sim <- doEvent(sim, debug = debug, notOlderThan = notOlderThan, events = events, ...) # process the next event + ## RecoverMode Step 5 -- Do Post if (recoverMode > 0) { rmo <- recoverModePost(sim, rmo, recoverMode) } @@ -2474,3 +2489,27 @@ defineEventFnMaker <- function(code, eventFnName) { } ") } + + +saveSimOnExit <- function(recoverMode, sim, rmo) { + if (!isTRUE(.pkgEnv$.cleanEnd)) { + if (recoverMode > 0) { + sim <- recoverModeOnExit(sim, rmo, recoverMode) + } + messageInterrupt1(recoverMode) + } else { + message(cli::col_magenta("simList saved in"), "\n", + cli::col_blue("SpaDES.core:::savedSimEnv()$.sim"), "\n", + cli::col_magenta("It will be deleted at next spades() call.")) + } + svdSimEnv <- savedSimEnv() # can't assign to a function + svdSimEnv$.sim <- sim # no copy of objects -- essentially 2 pointers throughout + .pkgEnv$.cleanEnd <- NULL +} + +recoverModeTypo <- function() { + recoverModeWrong <- getOption("spades.recoverMode") + if (!is.null(recoverModeWrong)) { + warning("Please set options('recoveryMode') with a 'y', not options('recoverMode')") + } +} From cf87fcc6ad45a3951b0c864a795113f44eade563 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 10 Jan 2025 10:25:42 -0800 Subject: [PATCH 037/128] Plots for SpatRaster tweak --- R/Plots.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/Plots.R b/R/Plots.R index f58b7ee3..6ce4e804 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -333,7 +333,7 @@ Plots <- function(data, fn, filename, } if (needSaveRaw) { - if (is(data, "Raster")) { + if (is(data, "Raster") || is(data, "SpatRaster")) { rasterFilename <- file.path(path, paste0(filename, "_data.tif")) writeRaster(data, filename = rasterFilename, overwrite = TRUE) if (exists("sim", inherits = FALSE)) @@ -355,7 +355,6 @@ Plots <- function(data, fn, filename, ) } } - if (needSave) { if (is.null(simIsIn)) { if (is.call(path)) From 1dd6d35ccdd480c16e8d25c8edb70ca1b4d11104 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 10 Jan 2025 16:42:38 -0800 Subject: [PATCH 038/128] .wrap.simList missing a cacheId --- R/cache.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cache.R b/R/cache.R index 203e87ed..51c2d151 100644 --- a/R/cache.R +++ b/R/cache.R @@ -971,7 +971,7 @@ objSize.simList <- function(x, quick = FALSE, ...) { .wrap.simList <- function(obj, cachePath, preDigest, drv = getOption("reproducible.drv", NULL), conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose"), - outputObjects = NULL, + outputObjects = NULL, cacheId, ...) { # Copy everything (including . and ._) that is NOT a main object -- objects are the potentially very large things From 1072415cce01a00aed491016403839f154946509 Mon Sep 17 00:00:00 2001 From: eliotmcintire Date: Fri, 10 Jan 2025 22:09:11 -0800 Subject: [PATCH 039/128] suppliedElsewhere: use loadOrder to include known cyclic starting --- R/simulation-simInit.R | 11 ++++++++++- R/suppliedElsewhere.R | 43 +++++++++++++++++++++++++++++++++--------- 2 files changed, 44 insertions(+), 10 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 32b5e9f8..df2eed0a 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1309,6 +1309,10 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out moduleSpecificInputObjects <- na.omit(moduleSpecificInputObjects) moduleSpecificInputObjects <- c(moduleSpecificInputObjects, m) moduleSpecificInputObjects <- c(moduleSpecificInputObjects, paste0(".mods$", m)) + # excludeSuppliedElsewhere <- Map(x = moduleSpecificInputObjects, function(x) suppliedElsewhere(x, sim = sim, where = "init")) + # excludeSuppliedElsewhere <- + # names(excludeSuppliedElsewhere[unlist(excludeSuppliedElsewhere)]) + # moduleSpecificInputObjects <- setdiff(moduleSpecificInputObjects, excludeSuppliedElsewhere) # ensure backwards compatibility with non-namespaced modules if (.isNamespaced(sim, mBase)) { @@ -1332,7 +1336,10 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out ## This next line will make the Caching sensitive to userSuppliedObjs ## (which are already in the simList) or objects supplied by another module - inSimList <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = "sim") + #browser() + #aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + inSimList <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = c("sim", "i", "c")) + # inCyclic <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = "c") if (any(inSimList)) { objectsToEvaluateForCaching <- c(objectsToEvaluateForCaching, moduleSpecificInputObjects[inSimList]) @@ -1612,6 +1619,8 @@ resolveDepsRunInitIfPoss <- function(sim, modules, paths, params, objects, input # THIS FUNCTION PASSES THINGS TO THE OUTER sim OBJECT as side effects. CAREFUL depsGr <- depsGraph(sim, plot = FALSE) depsGrDF <- (depsEdgeList(sim, FALSE) |> .depsPruneEdges()) + #depsGrDF1 <- depsEdgeList(sim, FALSE) + #depsGrDF <- depsGrDF1[from != to] if (getOption("spades.allowInitDuringSimInit", TRUE)) { cannotSafelyRunInit <- unique(depsGrDF[from != "_INPUT_"]$to) hasUnresolvedInputs <- unique(depsGrDF[from == "_INPUT_"]$to) diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index 34520da7..90808927 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -69,9 +69,9 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") # on my windows system -- shows something similar to sys.calls() forms <- formals() forms[names(mc)] <- mc - partialMatching <- c("s", "i", "u") + partialMatching <- c("s", "i", "u", "c") forms$where <- partialMatching[which(!is.na(pmatch(partialMatching, forms$where)))] - if (length(forms$where) == 0) stop("where must be either sim, user or initEvent") + if (length(forms$where) == 0) stop("where must be either sim, user, initEvent, or cyclic") objDeparsed <- substitute(object) if (missing(sim)) { theCall <- as.call(parse(text = deparse(objDeparsed))) @@ -113,17 +113,42 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") inUserSupplied <- if ("u" %in% forms$where) { objDeparsed %in% sim$.userSuppliedObjNames } else { - FALSE + rep(FALSE, length(objDeparsed)) } # If one of the modules that has already been loaded has this object as an output, # then don't create this - inFutureInit <- if ("i" %in% forms$where) { - # The next line is subtle -- it must be provided by another module, previously loaded (thus in the depsEdgeList), - # but that does not need it itself. If it needed it itself, then it would have loaded it already in the simList - # which is checked in a different test of suppliedElsewhere -- i.e., "sim" - isTRUE(depsEdgeList(sim, plot = FALSE)[!(from %in% c("_INPUT_", currentModule(sim))), ][ - objName == objDeparsed][, all(from != to), by = from][V1 == TRUE]$V1) + inFutureInit <- if (any(c("i", "c") %in% forms$where)) { + del <- depsEdgeList(sim, plot = FALSE) + # if ("c" %in% forms$where) { + # The next line is subtle -- it must be provided by another module, previously loaded (thus in the depsEdgeList), + # but that does not need it itself. If it needed it itself, then it would have loaded it already in the simList + # which is checked in a different test of suppliedElsewhere -- i.e., "sim" + dd <- del[objName %in% objDeparsed][from != to][!(from %in% c("_INPUT_")), ] + d <- depends(sim) + otherModsDeps <- d@dependencies[which(!names(d@dependencies) %in% currentModule(sim))] + + for (mod in otherModsDeps) { + lo <- mod@loadOrder + if (!is.null(lo$after)) + del <- dd[from %in% lo$after] + else + del <- dd + } + # } + + # if (any(c("i", "c") %in% forms$where)) { + # The next line is subtle -- it must be provided by another module, previously loaded (thus in the depsEdgeList), + # but that does not need it itself. If it needed it itself, then it would have loaded it already in the simList + # which is checked in a different test of suppliedElsewhere -- i.e., "sim" + # if (exists("aaaa", envir = .GlobalEnv)) browser() + out <- del[!(from %in% c("_INPUT_", currentModule(sim))), ][ + objName %in% objDeparsed] + out <- out[, .(objName, noFeedback = all(from != to)), by = from][noFeedback %in% TRUE] + objDeparsed %in% out$objName + # } else { + # FALSE + # } } else { FALSE } From 953d6c122e5e13ca86f7c51f45122876243adbbe Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sat, 11 Jan 2025 10:40:23 -0800 Subject: [PATCH 040/128] Bump 2.1.5.9007 --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b085661f..e0248c10 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2024-12-20 -Version: 2.1.5.9006 +Date: 2025-01-11 +Version: 2.1.5.9007 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), From 5b1fc29e7a0a30c5180dbddfb89884d3e7554c9e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 11:22:38 -0800 Subject: [PATCH 041/128] dealing with updated reproducible; --- R/cache.R | 3 ++- R/simulation-parseModule.R | 9 +++++--- R/simulation-simInit.R | 5 ++++- tests/testthat/helper-initTests.R | 5 +++++ tests/testthat/test-cache.R | 8 +++---- tests/testthat/test-simulation.R | 35 ++++++++++++++++++------------- 6 files changed, 42 insertions(+), 23 deletions(-) diff --git a/R/cache.R b/R/cache.R index 51c2d151..fc676d97 100644 --- a/R/cache.R +++ b/R/cache.R @@ -424,6 +424,7 @@ setMethod( definition = function(object, preDigest, origArguments, ...) { dots <- list(...) whSimList <- which(unlist(lapply(origArguments, is, "simList")))[1] + whSimList <- names(whSimList) # remove the "newCache" attribute, which is irrelevant for digest if (!is.null(attr(object, ".Cache")$newCache)) { @@ -997,7 +998,7 @@ objSize.simList <- function(x, quick = FALSE, ...) { # 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, + out <- .wrap(obj2, cachePath = cachePath, outputObjects = outputObjects, cacheId = cacheId, drv = drv, conn = conn, verbose = verbose, ...) # for (objName in names(out)) obj[[objName]] <- NULL diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index 8f121590..bec7ffdb 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -268,7 +268,6 @@ setMethod( sim@.xData$.mods[[mBase]]$.objects <- new.env(parent = emptyenv()) sim@.xData$.mods[[mBase]]$.isPackage <- TRUE - browser() activeCode[["main"]] <- evalWithActiveCode(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], asNamespace(.moduleNameNoUnderscore(mBase)), sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) @@ -281,10 +280,11 @@ setMethod( # The simpler line commented below will not allow actual code to be put into module, # e.g., startSim <- start(sim) # The more complex one following will allow that. + reqdPkgsHere <- eval(tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) # eval(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], envir = sim@.xData$.mods[[mBase]]) activeCode[["main"]] <- evalWithActiveCode(tmp[["parsedFile"]][!tmp[["defineModuleItem"]]], sim@.xData$.mods[[mBase]], - sim = sim, pkgs = tmp[["parsedFile"]][tmp[["defineModuleItem"]]][[1]][[3]]$reqdPkgs) + sim = sim, pkgs = reqdPkgsHere) # doesntUseNamespacing <- parseOldStyleFnNames(sim, mBase, ) doesntUseNamespacing <- !.isNamespaced(sim, mBase) @@ -571,6 +571,7 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = # tmpEnvir <- new.env(parent = envir) tmpEnvir <- new.env(parent = tmpEnvirForPkgs) + # This needs to be unconnected to main sim so that object sizes don't blow up simCopy <- Copy(sim, objects = FALSE) simCopy$.mods <- Copy(sim$.mods) @@ -586,12 +587,14 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = # it says, how big is the function, compared to how big is the environment that holds the function # If it is 1, it means there are only functions in that environment, no objects # length(serialize(tmpEnvir$prepare_IgnitionFit, NULL))/object.size(mget(ls(tmpEnvir), tmpEnvir)) + pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + pkgs <- reqdPkgsDontLoad(pkgs) # some are explicitly not to be loaded if (getOption("spades.useBox")) { cm <- currentModule(tmpEnvir$sim) if (length(cm)) if (!cm %in% unlist(.coreModules())) { - pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + # pkgs <- Require::extractPkgName(unlist(eval(pkgs))) lapply(pkgs, function(p) { allFns <- ls(envir = asNamespace(p)) val <- paste0("box::use(", p, "[...]", ")") diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index df2eed0a..ba1cb5a6 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -669,6 +669,10 @@ setMethod( ## load user-defined modules # browser(expr = exists("._simInit_4")) + if (!(all(unlist(lapply(debug, identical, FALSE))))) { + # .pkgEnv[[".spadesDebugFirst"]] <- TRUE + sim[["._spadesDebugWidth"]] <- c(9, 10, 9, 13) + } for (m in loadOrder) { mFullPath <- loadOrderNames[match(m, loadOrder)] @@ -1337,7 +1341,6 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out ## This next line will make the Caching sensitive to userSuppliedObjs ## (which are already in the simList) or objects supplied by another module #browser() - #aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) inSimList <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = c("sim", "i", "c")) # inCyclic <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = "c") if (any(inSimList)) { diff --git a/tests/testthat/helper-initTests.R b/tests/testthat/helper-initTests.R index a6d341a0..29f68613 100644 --- a/tests/testthat/helper-initTests.R +++ b/tests/testthat/helper-initTests.R @@ -262,3 +262,8 @@ runTestsWithTimings <- function(pkgPath = ".", LoadedMgsCheck <- function(msg, event) { sum(grepl(paste0("Loaded! Cached|for ", event," event"), msg)) == 2 } + + +grepDotInputObjectsModule <- function(m) { + paste0(".inputObjects.+", m, ".+.inputObjects") +} diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index d872366e..bcd57f63 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -313,9 +313,9 @@ test_that("test .robustDigest for simLists", { msgGrep11 <- paste("Running .input", "module code", "so not checking minimum package", "ggplot2", "Setting", "Paths", "using dataPath", "Using setDTthreads", "with user supplied tags", - "There is no similar item in the cachePath", + "There is no similar item in the cachePath", "elpsd", "Saving", "Done", "Elapsed time for", sep = "|") - expect_true(all(grepl(msgGrep11, mess1))) + expect_true(all(cli::ansi_grepl(msgGrep11, mess1))) msgGrep <- "Running .input|loaded cached copy|module code|Setting|Paths" #a <- capture.output( @@ -569,8 +569,8 @@ test_that("Cache sim objs via .Cache attr", { objects = list(co4 = 3, co3 = 2, co1 = 4), params = list(test = list(.useCache = c(".inputObjects", "init")))) }) - expect_true(sum(grepl("loaded cached copy of .inputObjects", mess11)) == 0) - expect_true(sum(grepl("Running .inputObjects", mess11)) == 1) + expect_true(sum(cli::ansi_grepl("loaded cached copy of .inputObjects", mess11)) == 0) + expect_true(sum(cli::ansi_grepl(grepDotInputObjectsModule(m[1]), mess11)) == 1) expect_true(!exists("newFun", envir = mySim$.mods$test)) expect_true(sum(grepl("aaa <- 2", format(mySim$.mods$test$.inputObjects))) == 1) }) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index 65fb274f..96f8eca6 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -498,7 +498,8 @@ test_that("conflicting function types", { "defineParameter: 'saveInitialTime' is not of specified type 'numeric'", "defineParameter: 'saveInterval' is not of specified type 'numeric'", "child4: module code: Init: local variable.*qwerqwer.*assigned but may not be used", - "Running .inputObjects for child4", + grepDotInputObjectsModule("child4"), + # "Running .inputObjects for child4", "child4: module code: Init: local variable.*poiuoiu.*assigned but may not be used", "child4: outputObjects: g, g1 are assigned to sim inside Init, but are not declared in metadata outputObjects", "child4: inputObjects: b, d, f, d1, test are used from sim inside Init, but are not declared in metadata inputObjects" @@ -549,8 +550,8 @@ test_that("conflicting function types", { pattern = c(paste0(m, ": module code: b is declared in metadata outputObjects|", "so not checking minimum package|", m, ": module code: a is declared in metadata inputObjects|", - "Running .inputObjects|", - "Setting:|Paths set to:|", + grepDotInputObjectsModule(m), #"Running .inputObjects|", + "|Setting:|Paths set to:|", "Using setDTthreads|", m, ": using dataPath|", "Elapsed"))))) @@ -625,7 +626,8 @@ test_that("conflicting function types", { sep = "\n", fill = FALSE, file = fileName) fullMessage <- c( - "Running .inputObjects for child4", + grepDotInputObjectsModule("child4"), + # "Running .inputObjects for child4", "child4: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", "child4: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", "child4: module code: ei3 is declared in metadata inputObjects, but is not used in the module", @@ -645,7 +647,6 @@ test_that("conflicting function types", { md2 <- moduleMetadata(path = getSampleModules(tmpdir), module = "randomLandscapes") - mm <- capture_messages({ mySim <- simInit(paths = list(modulePath = tmpdir), modules = m) }) @@ -691,9 +692,9 @@ test_that("scheduleEvent with NA logical in a non-standard parameter", { # show that it is logical sim <- simInit(times = list(start = 0, end = 2)) expect_true(is.numeric(eval(xxx3)$default[[1]])) - mm <- capture_messages(simInit(paths = list(modulePath = tmpdir), modules = m)) - expect_true(all(unlist(lapply(c("Running .inputObjects", "module code appears clean"), + expect_true(all(unlist(lapply(c(grepDotInputObjectsModule(m),#"Running .inputObjects", + "module code appears clean"), function(x) any(grepl(mm, pattern = x)))))) }) @@ -801,7 +802,8 @@ test_that("messaging with multiple modules", { fullMessage <- c( # "defineParameter: 'plotInitialTime' is not of specified type 'character'", "defineParameter: 'saveInitialTime' is not of specified type 'character'", - "Running .inputObjects for test", + grepDotInputObjectsModule("test"), + # "Running .inputObjects for test", "test: module code: co2, co3 are declared in metadata outputObjects, but are not assigned in the module", "test: module code: ei2, ei3, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", "test: module code: ei3 is declared in metadata inputObjects, but is not used in the module", @@ -814,7 +816,8 @@ test_that("messaging with multiple modules", { "test: inputObjects: b, aaa are used from sim inside Init, but are not declared in metadata inputObjects", "test: inputObjects: b, co3 are used from sim inside .inputObjects, but are not declared in metadata inputObjects", # "defineParameter: 'plotInitialTime' is not of specified type 'character'", - "Running .inputObjects for test2", + grepDotInputObjectsModule("test2"), + # "Running .inputObjects for test2", "test2: module code: co1, co4 are declared in metadata outputObjects, but are not assigned in the module", "test2: module code: ei1, ei4 are declared in metadata inputObjects, but no default\\(s\\) are provided in .inputObjects", "test2: module code: ei1 is declared in metadata inputObjects, but is not used in the module", @@ -825,9 +828,11 @@ test_that("messaging with multiple modules", { "test2: inputObjects: b is used from sim inside .inputObjects, but is not declared in metadata inputObjects", # "defineParameter: 'plotInitialTime' is not of specified type 'character'", "defineParameter: 'hello' is not of specified type 'character'", - "Running .inputObjects for test3", + grepDotInputObjectsModule("test3"), + # "Running .inputObjects for test3", "test3: module code appears clean", - "Running .inputObjects for test4", + grepDotInputObjectsModule("test4"), + # "Running .inputObjects for test4", "test4: module code appears clean" ) @@ -890,11 +895,13 @@ test_that("Module code checking -- pipe with matrix product with backtick & data mm <- cleanMessage(mm) fullMessage1 <- c( - "Running .inputObjects for child4", + grepDotInputObjectsModule("child4"), + # "Running .inputObjects for child4", "child4: module code: Init: local variable.*result1.*assigned but may not be used ", "child4: outputObjects: bvcx, bvcx2, b, a are assigned to sim inside Init, but are not declared in metadata outputObjects") fullMessageNonInteractive <- c( - "Running .inputObjects for child4", + grepDotInputObjectsModule("child4"), + # "Running .inputObjects for child4", "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx <- matrix.*", #possibly at .*147", "child4: module code: Init", cantCodeCheckMessage, "'sim\\$bvcx2 <- matrix.*", #possibly at .*148", "child4: module code: Init: local variable.*result1.*assigned but may not be used", @@ -1096,7 +1103,7 @@ paste0(" reqdPkgs = list(\'", dontLoad, "\'),"),' ) expect_false(isNamespaceLoaded(dontLoad)) - options(spades.reqdPkgsDontLoad = NULL) + withr::local_options(spades.reqdPkgsDontLoad = NULL) warn <- capture_warnings( sim <- simInit(modules = "test", paths = list(modulePath = tmpdir), times = list(start = 0, end = 1, timeunit = "year")) From cab26c17ac6b38a3bfcc686902cfb2c8785d455b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 11:23:10 -0800 Subject: [PATCH 042/128] objSize updates -- use `.objSizeWithTry` b/c bug in lobstr --- NAMESPACE | 2 ++ R/cache.R | 17 +++++++++-------- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 7db06aff..35b33856 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -188,6 +188,7 @@ export(restartSpades) export(rndstr) export(saveFiles) export(saveSimList) +export(saveState) export(savedSimEnv) export(scheduleConditionalEvent) export(scheduleEvent) @@ -398,6 +399,7 @@ importFrom(reproducible,.cacheMessageObjectToRetrieve) importFrom(reproducible,.checkCacheRepo) importFrom(reproducible,.file.move) importFrom(reproducible,.grepSysCalls) +importFrom(reproducible,.objSizeWithTry) importFrom(reproducible,.orderDotsUnderscoreFirst) importFrom(reproducible,.preDigestByClass) importFrom(reproducible,.prepareOutput) diff --git a/R/cache.R b/R/cache.R index fc676d97..8ad1cfd9 100644 --- a/R/cache.R +++ b/R/cache.R @@ -917,7 +917,7 @@ if (!exists("objSize")) { #' 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 reproducible objSize .objSizeWithTry #' @importFrom lobstr obj_size #' @inheritParams reproducible::objSize #' @@ -928,11 +928,12 @@ if (!exists("objSize")) { #' a <- simInit(objects = list(d = 1:10, b = 2:20)) #' objSize(a) #' utils::object.size(a) -objSize.simList <- function(x, quick = FALSE, ...) { +objSize.simList <- function(x, quick = FALSE, recursive = FALSE, ...) { - total <- try(obj_size(x, quick = TRUE), silent = TRUE) # failing due to lobstr issue #72 - if (!is(total, "try-error")) { - aa <- objSize(x@.xData, quick = quick, ...) + total <- .objSizeWithTry(x) + # total <- try(obj_size(x, quick = TRUE), silent = TRUE) # failing due to lobstr issue #72 + if (!is(total, "try-error") && isTRUE(recursive)) { + aa <- objSize(x@.xData, quick = quick, recursive = recursive, ...) simSlots <- grep("^\\.envir$|^\\.xData$", slotNames(x), value = TRUE, invert = TRUE) names(simSlots) <- simSlots @@ -945,9 +946,9 @@ objSize.simList <- function(x, quick = FALSE, ...) { # attr(total, "objSize") <- sum(unlist(attr(aa, "objSize")), unlist(attr(otherParts, "objSize"))) # class(attr(total, "objSize")) <- "lobstr_bytes" - } else { - total <- NA - } + } # else { + # total <- NA + # } return(total) } From 34af0b7820dfc463774d87ae4a1dbcb39ed74806 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 11:23:45 -0800 Subject: [PATCH 043/128] rename with "_": ._spadesDebugWidth --- R/simulation-spades.R | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 82e9fb52..502e701a 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -271,7 +271,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, # selfObjects <- futureNeeds$thisModOutputs[futureNeeds$thisModOutputs %in% futureNeeds$thisModsInputs] objsNeeded <- na.omit(unique(c(objsNeeded, objsNeededForNextMod)))#, selfObjects))) if (!any(futureNeeds$thisModOutputs %in% objsNeeded)) { - spacing <- paste(rep(" ", sim[[".spadesDebugWidth"]][1] + 1), collapse = "") + spacing <- paste(rep(" ", sim[["._spadesDebugWidth"]][1] + 1), collapse = "") messageVerbose( cli::col_magenta(paste0(spacing, cur[["moduleName"]], " outputs not needed by ", "next module (", nextScheduledEvent, ")")), @@ -1106,7 +1106,7 @@ setMethod( if (!(all(unlist(lapply(debug, identical, FALSE))))) { .pkgEnv[[".spadesDebugFirst"]] <- TRUE - sim[[".spadesDebugWidth"]] <- c(9, 10, 9, 13) + # sim[["._spadesDebugWidth"]] <- c(9, 10, 9, 13) } sim@.xData[["._firstEventClockTime"]] <- Sys.time() @@ -1411,7 +1411,6 @@ setMethod( rr <- .Random.seed if (runFnCallAsExpr) { - # if (identical(cur$eventType, "prepIgnitionFitData")) browser() sim <- eval(fnCallAsExpr) ## slower than more direct version just above } if (identical(rr, .Random.seed)) { @@ -1748,7 +1747,7 @@ resolveFutureNow <- function(sim, cause = "") { futureRunningSimTU <- futureRunning setDT(futureRunningSimTU) setDT(futureRunning) - spacing <- paste(rep(" ", sim[[".spadesDebugWidth"]][1] + 1), collapse = "") + spacing <- paste(rep(" ", sim[["._spadesDebugWidth"]][1] + 1), collapse = "") outMess <- debugMessTRUE(sim, events = futureRunningSimTU) @@ -1826,7 +1825,7 @@ getFutureNeeds <- function(deps, curModName) { .runEventFuture <- function(sim, cacheIt, debug, moduleCall, fnEnv, cur, notOlderThan, showSimilar = showSimilar, .pkgEnv, envir, futureNeeds) { - spacing <- paste(rep(" ", sim[[".spadesDebugWidth"]][1]), collapse = "") + spacing <- paste(rep(" ", sim[["._spadesDebugWidth"]][1]), collapse = "") message(cli::col_magenta(spacing, "-- Spawning in a future")) sim$.futureEventsSkipped <- sim$.futureEventsSkipped + 1 modEnv <- sim$.mods[[cur[["moduleName"]]]] @@ -2191,14 +2190,14 @@ debugMessTRUE <- function(sim, events) { events <- current(sim) evnts1 <- data.frame(events) widths <- unname(unlist(lapply(format(evnts1), nchar))) - sim[[".spadesDebugWidth"]] <- pmax(widths, sim[[".spadesDebugWidth"]]) - evnts1[1L, ] <- sprintf(paste0("%-", sim[[".spadesDebugWidth"]],"s"), evnts1) + sim[["._spadesDebugWidth"]] <- pmax(widths, sim[["._spadesDebugWidth"]], na.rm = TRUE) + evnts1[1L, ] <- sprintf(paste0("%-", sim[["._spadesDebugWidth"]],"s"), evnts1) evnts1[1L, 1L] <- sprintf(paste0("%.4", "g"), as.numeric(evnts1[1L, 1L])) - evnts1[1L, 1L] <- sprintf(paste0("%-", sim[[".spadesDebugWidth"]][1L], "s"), evnts1[1L, 1L]) + evnts1[1L, 1L] <- sprintf(paste0("%-", sim[["._spadesDebugWidth"]][1L], "s"), evnts1[1L, 1L]) if (.pkgEnv[[".spadesDebugFirst"]]) { evnts2 <- evnts1 - evnts2[1L:2L, ] <- rbind(sprintf(paste0("%-",sim[[".spadesDebugWidth"]], "s"), names(evnts2)), - sprintf(paste0("%-",sim[[".spadesDebugWidth"]], "s"), evnts2)) + evnts2[1L:2L, ] <- rbind(sprintf(paste0("%-",sim[["._spadesDebugWidth"]], "s"), names(evnts2)), + sprintf(paste0("%-",sim[["._spadesDebugWidth"]], "s"), evnts2)) outMess <- paste(unname(evnts2[1, ]), collapse = ' ') outMess <- c(outMess, paste(unname(evnts2[2, ]), collapse = ' ')) From f8b1102d2e934edf163b1f508c06c29bb162bb1e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 11:23:59 -0800 Subject: [PATCH 044/128] add "package:stats" warning catch --- R/simulation-spades.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 502e701a..f71b3ac4 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1231,6 +1231,9 @@ setMethod( if (grepl("In .+:", w$message)) { warningSplitOnColon(w) invokeRestart("muffleWarning") + } else if (isTRUE(any(grepl("'package:stats' may not be available when loading", + w$message)))) { + invokeRestart("muffleWarning") } else { warning(w) tryCatch(invokeRestart("muffleWarning"), error = function(e) NULL) From 40cbf87c2d60c5bd95a9ee778c852908476c7ab0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 11:24:11 -0800 Subject: [PATCH 045/128] redoc; bump min reproducible --- DESCRIPTION | 2 +- man/createDESCRIPTIONandDocs.Rd | 3 ++- man/dealWithClass.Rd | 11 ++++++----- man/objSize.simList.Rd | 2 +- man/restartSpades.Rd | 13 ++++++++++++- man/robustDigest.Rd | 6 +----- man/saveSimList.Rd | 8 ++++++++ 7 files changed, 31 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e0248c10..1f3468c6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,7 @@ Authors@R: c( Depends: R (>= 4.2), quickPlot (>= 1.0.2), - reproducible (>= 2.1.1) + reproducible (>= 2.1.2.9006) Imports: box, cli, diff --git a/man/createDESCRIPTIONandDocs.Rd b/man/createDESCRIPTIONandDocs.Rd index 4cf130c5..b517cfd5 100644 --- a/man/createDESCRIPTIONandDocs.Rd +++ b/man/createDESCRIPTIONandDocs.Rd @@ -8,7 +8,8 @@ createDESCRIPTIONandDocs( module = NULL, path = getOption("spades.modulePath"), importAll = TRUE, - buildDocuments = TRUE + buildDocuments = TRUE, + verbose = getOption("Require.verbose") ) } \arguments{ diff --git a/man/dealWithClass.Rd b/man/dealWithClass.Rd index e92e1284..8448bcb9 100644 --- a/man/dealWithClass.Rd +++ b/man/dealWithClass.Rd @@ -17,6 +17,7 @@ conn = getOption("reproducible.conn", NULL), verbose = getOption("reproducible.verbose"), outputObjects = NULL, + cacheId, ... ) @@ -59,6 +60,11 @@ option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} \item{outputObjects}{Optional character vector indicating which objects to return. This is only relevant for list, environment (or similar) objects} +\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. +Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, +this will also be dramatically faster than using \code{userTags}, for a large +cache.} + \item{...}{Other arguments. Can be in the form of \code{tagKey = tagValue}, such as, \code{class = "numeric"} to find all entries that are numerics in the cache. Note: the special cases of \code{cacheId} and \code{fun} have their own @@ -70,11 +76,6 @@ missing, which is the same as \code{TRUE}. If there are errors due to regular expression problem, try \code{FALSE}. For \code{cc}, it is passed to \code{clearCache}, e.g., \code{ask}, \code{userTags}. For \code{showCache}, it can also be \code{sorted = FALSE} to return the object unsorted.} - -\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. -Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, -this will also be dramatically faster than using \code{userTags}, for a large -cache.} } \value{ The same object as passed into the function, but dealt with so that it can be diff --git a/man/objSize.simList.Rd b/man/objSize.simList.Rd index 902b17ad..2916a62f 100644 --- a/man/objSize.simList.Rd +++ b/man/objSize.simList.Rd @@ -4,7 +4,7 @@ \alias{objSize.simList} \title{Object size for \code{simList}} \usage{ -\method{objSize}{simList}(x, quick = TRUE, ...) +\method{objSize}{simList}(x, quick = FALSE, ...) } \arguments{ \item{x}{An object} diff --git a/man/restartSpades.Rd b/man/restartSpades.Rd index 89f86a3d..bd5be2d2 100644 --- a/man/restartSpades.Rd +++ b/man/restartSpades.Rd @@ -2,12 +2,17 @@ % Please edit documentation in R/restart.R \name{restartSpades} \alias{restartSpades} +\alias{saveState} \title{Restart an interrupted simulation} \usage{ restartSpades(sim = NULL, module = NULL, numEvents = Inf, restart = TRUE, ...) + +saveState(filename, ...) } \arguments{ -\item{sim}{A \code{simList.} If not supplied (the default), this will take the \code{sim} from +\item{sim}{A \code{simList} or a filename that will load a \code{simList}, e.g., from +\code{saveState} or \code{saveSimList}. If not supplied (the default), +this will take the \code{sim} from \code{savedSimEnv()$.sim}, i.e., the one that was interrupted} \item{module}{A character string length one naming the module that caused the error and @@ -24,6 +29,12 @@ restarting the simulation. If \code{FALSE}, then it will return a new \code{simL with the module code parsed into the \code{simList}} \item{...}{Passed to \code{spades}, e.g., \code{debug}, \code{.plotInitialTime}} + +\item{filename}{The filename to save the sim state. + +\code{saveState} is a wrapper around \code{restartSpades} and \code{saveSimList}. You can +pass arguments to the \code{...} that will be passed to \code{saveSimList}, such as +\code{modules}, \code{inputs}, \code{outputs}.} } \value{ A \code{simList} as if \code{spades} had been called on a \code{simList}. diff --git a/man/robustDigest.Rd b/man/robustDigest.Rd index 441d66d4..ca4d7af8 100644 --- a/man/robustDigest.Rd +++ b/man/robustDigest.Rd @@ -24,11 +24,7 @@ passed to \code{digest::digest}, essentially limiting the number of bytes to digest (for speed). This will only be used if \code{quick = FALSE}. Default is \code{getOption("reproducible.length")}, which is set to \code{Inf}.} -\item{algo}{The algorithms to be used; currently available choices are - \code{md5}, which is also the default, \code{sha1}, \code{crc32}, - \code{sha256}, \code{sha512}, \code{xxhash32}, \code{xxhash64}, - \code{murmur32}, \code{spookyhash}, \code{blake3}, \code{crc32c}, - \code{xxh3_64}, and \code{xxh3_128}.} +\item{algo}{The digest algorithm to use. Default \code{xxhash64} (see \code{\link[digest:digest]{digest::digest()}} for others).} \item{quick}{Logical or character. If \code{TRUE}, no disk-based information will be assessed, i.e., only diff --git a/man/saveSimList.Rd b/man/saveSimList.Rd index c01e34eb..9199d312 100644 --- a/man/saveSimList.Rd +++ b/man/saveSimList.Rd @@ -13,6 +13,7 @@ saveSimList( inputs = TRUE, cache = FALSE, envir, + files = TRUE, ... ) } @@ -43,6 +44,13 @@ See Details.} \item{envir}{If \code{sim} is a character string, then this must be provided. It is the environment where the object named \code{sim} can be found.} +\item{files}{Logical. Should all the files in the optional \code{outputs}, \code{inputs}, +\code{cache} be saved. If this is \code{TRUE}, then the resulting \code{filename} will be +silently converted to an archive file with the appropriate extension e.g., +\code{.zip} or \code{.tar.gz}. This will automatically be \code{TRUE} if any of the \code{outputs}, +\code{inputs} or \code{cache} are \code{TRUE}. Setting this to \code{FALSE} will turn off the +saving of files specified in \code{inputs(sim)}, \code{outputs(sim)} or the cache.} + \item{...}{Additional arguments. See Details.} } \value{ From e6c38b804dd2867771100a4e44be824e09324770 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 15:57:05 -0800 Subject: [PATCH 046/128] getModuleVersion -- add moduleFiles arg -- no need to check internet 2x --- R/module-repository.R | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/R/module-repository.R b/R/module-repository.R index b9294311..07a0cc66 100644 --- a/R/module-repository.R +++ b/R/module-repository.R @@ -14,6 +14,8 @@ defaultGitRepoToSpaDESModules <- "PredictiveEcology/SpaDES-modules" #' Default is `"PredictiveEcology/SpaDES-modules"`, which is #' specified by the global option `spades.moduleRepo`. #' Only `master`/`main` branches can be used at this point. +#' @param moduleFiles Optional. List of files of the `name` and `repo`. If not +#' supplied, this function will get that information by using `checkModule`. #' #' @return `numeric_version` #' @@ -32,7 +34,7 @@ defaultGitRepoToSpaDESModules <- "PredictiveEcology/SpaDES-modules" #' @rdname getModuleVersion #' @seealso [zipModule()] for creating module \file{.zip} folders. #' -setGeneric("getModuleVersion", function(name, repo, token) { +setGeneric("getModuleVersion", function(name, repo, token, moduleFiles = NULL) { standardGeneric("getModuleVersion") }) @@ -40,12 +42,13 @@ setGeneric("getModuleVersion", function(name, repo, token) { setMethod( "getModuleVersion", signature = c(name = "character", repo = "character", token = "ANY"), - definition = function(name, repo, token) { + definition = function(name, repo, token, moduleFiles = NULL) { if (length(name) > 1) { warning("name contains more than one module. Only the first will be used.") name <- name[1] } - moduleFiles <- checkModule(name, repo, token = token) + if (is.null(moduleFiles)) + moduleFiles <- checkModule(name, repo, token = token) zipFiles <- grep(paste0(name, "_+.+.zip"), moduleFiles, value = TRUE) # moduleName_....zip only zipFiles <- grep(file.path(name, "data"), zipFiles, invert = TRUE, value = TRUE) # remove any zip in data folder # all zip files is not correct behaviour, only @@ -63,9 +66,10 @@ setMethod( #' @rdname getModuleVersion setMethod("getModuleVersion", signature = c(name = "character", repo = "missing", token = "ANY"), - definition = function(name, token) { + definition = function(name, token, moduleFiles = NULL) { v <- getModuleVersion(name, token = token, - getOption("spades.moduleRepo", defaultGitRepoToSpaDESModules)) + getOption("spades.moduleRepo", defaultGitRepoToSpaDESModules), + moduleFiles = moduleFiles) return(v) }) From 03de272d48f09ed4938156978a846917d693b2d2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 15:59:48 -0800 Subject: [PATCH 047/128] rm ::: and redoc --- R/convertToPackage.R | 30 +---- R/createDESCRIPTIONandDocs.R | 2 +- R/module-repository.R | 189 ++++++++++++++++-------------- R/reexports.R | 6 + R/simulation-spades.R | 4 +- man/downloadModule.Rd | 2 +- man/getModuleVersion.Rd | 9 +- man/objSize.simList.Rd | 5 +- man/restartR.Rd | 4 +- tests/testthat/test-Plots.R | 2 +- tests/testthat/test-cache.R | 2 +- tests/testthat/test-environment.R | 6 +- tests/testthat/test-simList.R | 4 +- 13 files changed, 128 insertions(+), 137 deletions(-) diff --git a/R/convertToPackage.R b/R/convertToPackage.R index 38b5755c..3c853a5e 100644 --- a/R/convertToPackage.R +++ b/R/convertToPackage.R @@ -212,28 +212,8 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" # sep = "\n", append = FALSE) # }) -# otherStuffFn <- filenameFromFunction(packageFolderName, "other", "R") -# cat(" -# makeActiveBinding('mod', SpaDES.core:::activeModBindingFunction, ", -# paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") -# -# makeActiveBinding('Par', SpaDES.core:::activeParBindingFunction, ", -# paste0('asNamespace(SpaDES.core:::.moduleNameNoUnderscore(\'', module, '\'))'), ") -# -# ", file = otherStuffFn) - - # if (length(linesWithRoxygen) > 0) { - # message("There was some roxygen2 documentation that was not immediately above ", - # "a function; it is being saved in R/documentation.R ... please confirm that ", - # "the documentation is correct.") - # cat(rlaa[linesWithRoxygen], file = filenameFromFunction(packageFolderName, "documentation", "R") - # , sep = "\n", append = FALSE) - # linesWithRoxygen <- character() - # } - filePathImportSpadesCore <- filenameFromFunction(packageFolderName, "imports", "R")# file.path(dirname(mainModuleFile), "R", "imports.R") - # cat(format(aa[[whDefModule]]), file = mainModuleFile, sep = "\n") md <- aa[[whDefModule]][[3]] deps <- unlist(eval(md$reqdPkgs)) @@ -243,14 +223,6 @@ convertToPackage <- function(module = NULL, path = getOption("spades.modulePath" if (isTRUE(buildDocuments)) { documentModule(packageFolderName, gpd, linesWithDefModule) - # message("Building documentation") - # m <- packageFolderName - # tmpSrcForDoc <- "R/tmp.R" - # cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) - # on.exit(unlink(tmpSrcForDoc)) - # roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... - # pkgload::dev_topic_index_reset(m) - # pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting } RBuildIgnoreFile <- filenameFromFunction(packageFolderName, "", fileExt = ".Rbuildignore") @@ -382,7 +354,7 @@ mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { if (fieldName %in% colnames(origDESCtxt)) fieldVals <- strsplit(origDESCtxt[, fieldName], split = ",+\n")[[1]] if (length(field)) { - field <- Require:::trimRedundancies(unique(c(field, fieldVals))) + field <- trimRedundancies(unique(c(field, fieldVals))) } cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 0db395dc..1a165ee2 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -310,7 +310,7 @@ mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { if (fieldName %in% colnames(origDESCtxt)) fieldVals <- strsplit(origDESCtxt[, fieldName], split = ",+\n")[[1]] if (length(field)) { - field <- Require:::trimRedundancies(unique(c(field, fieldVals))) + field <- trimRedundancies(unique(c(field, fieldVals))) } cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), sep = "\n", file = dFile, append = TRUE) diff --git a/R/module-repository.R b/R/module-repository.R index 07a0cc66..63c7b397 100644 --- a/R/module-repository.R +++ b/R/module-repository.R @@ -114,15 +114,16 @@ setMethod( ua <- httr::user_agent(getOption("spades.useragent")) if (missing(token)) - token <- Require:::.getGitCredsToken() + token <- getGitCredsToken() request <- if (!is.null(token)) { - Require:::.GETWauthThenNonAuth(apiurl, token = token, verbose = verbose) + GETWauthThenNonAuth(apiurl, token = token, verbose = verbose) # httr::GET(apiurl, ua) } else { pat <- Sys.getenv("GITHUB_PAT") message(cli::col_magenta("Using GitHub PAT from envvar GITHUB_PAT", sep = "")) httr::GET(apiurl, ua, config = list(httr::config(token = pat))) } + httr::stop_for_status(request) allFiles <- unlist(lapply(httr::content(request)$tree, "[", "path"), use.names = FALSE) moduleFiles <- grep(paste0("^modules/", name), allFiles, value = TRUE) @@ -279,7 +280,7 @@ setMethod( #' including whether it was downloaded or not, and whether it was renamed #' (because there was a local copy that had the wrong file name). #' -#' @author Alex Chubaty +#' @author Alex Chubaty and Eliot McIntire #' @export #' @rdname downloadModule setGeneric("downloadModule", function(name, path, version, repo, data, quiet, @@ -299,104 +300,109 @@ setMethod( definition = function(name, path, version, repo, data, quiet, quickCheck, overwrite) { if (requireNamespace("httr", quietly = TRUE)) { - path <- checkPath(path, create = TRUE) - checkPath(file.path(path, name), create = TRUE) - - # check locally for module. only download if doesn't exist locally, - # or if overwrite is wanted - if (!checkModuleLocal(name, path, version) | overwrite) { - # check remotely for module - # Authentication - token <- NULL - usesGitCreds <- requireNamespace("gitcreds", quietly = TRUE) && - requireNamespace("httr", quietly = TRUE) - if (usesGitCreds) { - token <- Require:::.getGitCredsToken() - } - - checkModule(name, repo, token = token) - if (is.na(version)) version <- getModuleVersion(name, repo, token = token) - - innerPaths <- c(paste0("/master/modules/", name, "/"), "/master/") - for (tries in 1:2) { - innerPath <- innerPaths[tries] + path <- checkPath(path, create = TRUE) + checkPath(file.path(path, name), create = TRUE) + + # check locally for module. only download if doesn't exist locally, + # or if overwrite is wanted + if (!checkModuleLocal(name, path, version) | overwrite) { + # check remotely for module + # Authentication + token <- NULL + usesGitCreds <- requireNamespace("gitcreds", quietly = TRUE) && + requireNamespace("httr", quietly = TRUE) + if (usesGitCreds) { + token <- getGitCredsToken() + } - zip <- paste0("https://raw.githubusercontent.com/", repo, - innerPath, name, "_", version, ".zip") # nolint - localzip <- file.path(path, basename(zip)) + moduleFiles <- checkModule(name, repo, token = token) + if (is.na(version)) version <- getModuleVersion(name, repo, token = token, moduleFiles = moduleFiles) - ua <- httr::user_agent(getOption("spades.useragent")) - request <- if (!is.null(token)) { - message(cli::col_magenta("Using GitHub token stored with gitcreds", sep = "")) - Require:::.GETWauthThenNonAuth(zip, ua, httr::write_disk(localzip, overwrite = overwrite), - token = token) - } else { - pat <- Sys.getenv("GITHUB_PAT") - message(cli::col_magenta("Using GitHub PAT from envvar GITHUB_PAT", sep = "")) - httr::GET(zip, ua, config = list(httr::config(token = pat)), - httr::write_disk(localzip, overwrite = overwrite)) - } - status1 <- try(httr::stop_for_status(request), silent = TRUE) - if (!is(status1, "try-error")) break - if (is(status1, "try-error") && tries == 2) stop(status1) - } + innerPaths <- c(paste0("/master/modules/", name, "/"), "/master/") + for (tries in 1:2) { + innerPath <- innerPaths[tries] - files <- unzip(localzip, exdir = file.path(path), overwrite = TRUE) - } else { - files <- list.files(file.path(path, name)) - } + zip <- paste0("https://raw.githubusercontent.com/", repo, + innerPath, name, "_", version, ".zip") # nolint + localzip <- file.path(path, basename(zip)) - # after download, check for childModules that also require downloading - files2 <- list() - children <- .parseModulePartial(filename = file.path(path, name, paste0(name, ".R")), - defineModuleElement = "childModules") - childVersions <- .parseModulePartial(filename = file.path(path, name, paste0(name, ".R")), - defineModuleElement = "version") - - dataList2 <- data.frame(result = character(0), expectedFile = character(0), - actualFile = character(0), checksum.x = character(0), - checksum.y = character(0), algorithm.x = character(0), - algorithm.y = character(0), - stringsAsFactors = FALSE) - dataList3 <- dataList2 - if (!is.null(children)) { - if (all(nzchar(children) & !is.na(children)) && length(children)) { - tmp <- lapply(children, function(x) { - f <- if (!is.null(childVersions[[x]])) { - downloadModule(x, path = path, repo = repo, data = data, version = childVersions[[x]], - quickCheck = quickCheck, overwrite = overwrite) + ua <- httr::user_agent(getOption("spades.useragent")) + request <- if (!is.null(token)) { + message(cli::col_magenta("Using GitHub token stored with gitcreds", sep = "")) + GETWauthThenNonAuth(zip, # ua, httr::write_disk(localzip, overwrite = overwrite), + token = token) } else { - downloadModule(x, path = path, repo = repo, data = data, quickCheck = quickCheck, - overwrite = overwrite) + pat <- Sys.getenv("GITHUB_PAT") + message(cli::col_magenta("Using GitHub PAT from envvar GITHUB_PAT", sep = "")) + httr::GET(zip, ua, config = list(httr::config(token = pat)), + httr::write_disk(localzip, overwrite = overwrite)) } - files2 <<- append(files2, f[[1]]) - dataList2 <<- setDF(rbindlist(list(dataList2, f[[2]]), use.names = TRUE, fill = TRUE)) - }) - } - } + status1 <- try(httr::stop_for_status(request), silent = TRUE) + if (!is(status1, "try-error")) break + if (is(status1, "try-error") && tries == 2) stop(status1) + } - if (data) { - moduleFilename <- file.path(path, name, paste0(name, ".R")) - inputs <- .parseModulePartial(filename = moduleFilename, - defineModuleElement = "inputObjects") - urls <- inputs$sourceURL - objNames <- if (is.call(inputs$objectName)) { - unlist(lapply(tail(parse(text = inputs$objectName), length(urls)), function(x) deparse(x))) + dataFromGET <- httr::content(request, "raw") + zipfile <- tempfile(fileext = ".zip") + writeBin(dataFromGET, zipfile) + on.exit(unlink(zipfile)) + linkOrCopy(zipfile, localzip, symlink = FALSE, overwrite = overwrite) + files <- unzip(localzip, exdir = file.path(path), overwrite = overwrite) } else { - inputs$objectName + files <- list.files(file.path(path, name)) } - names(urls) <- objNames - children <- .parseModulePartial(filename = moduleFilename, + # after download, check for childModules that also require downloading + files2 <- list() + children <- .parseModulePartial(filename = file.path(path, name, paste0(name, ".R")), defineModuleElement = "childModules") + childVersions <- .parseModulePartial(filename = file.path(path, name, paste0(name, ".R")), + defineModuleElement = "version") + + dataList2 <- data.frame(result = character(0), expectedFile = character(0), + actualFile = character(0), checksum.x = character(0), + checksum.y = character(0), algorithm.x = character(0), + algorithm.y = character(0), + stringsAsFactors = FALSE) + dataList3 <- dataList2 + if (!is.null(children)) { + if (all(nzchar(children) & !is.na(children)) && length(children)) { + tmp <- lapply(children, function(x) { + f <- if (!is.null(childVersions[[x]])) { + downloadModule(x, path = path, repo = repo, data = data, version = childVersions[[x]], + quickCheck = quickCheck, overwrite = overwrite) + } else { + downloadModule(x, path = path, repo = repo, data = data, quickCheck = quickCheck, + overwrite = overwrite) + } + files2 <<- append(files2, f[[1]]) + dataList2 <<- setDF(rbindlist(list(dataList2, f[[2]]), use.names = TRUE, fill = TRUE)) + }) + } + } - dataList <- downloadData(module = name, path = path, quiet = quiet, - quickCheck = quickCheck, urls = urls, children = children) - } else { - dataList <- checksums(module = name, path = path, quickCheck = quickCheck) - } - message(cli::col_magenta("Download complete for module ", name, - " (v", version, " at '", path,"').", sep = "")) + if (data) { + moduleFilename <- file.path(path, name, paste0(name, ".R")) + inputs <- .parseModulePartial(filename = moduleFilename, + defineModuleElement = "inputObjects") + urls <- inputs$sourceURL + objNames <- if (is.call(inputs$objectName)) { + unlist(lapply(tail(parse(text = inputs$objectName), length(urls)), function(x) deparse(x))) + } else { + inputs$objectName + } + names(urls) <- objNames + + children <- .parseModulePartial(filename = moduleFilename, + defineModuleElement = "childModules") + + dataList <- downloadData(module = name, path = path, quiet = quiet, + quickCheck = quickCheck, urls = urls, children = children) + } else { + dataList <- checksums(module = name, path = path, quickCheck = quickCheck) + } + message(cli::col_magenta("Download complete for module ", name, + " (v", version, " at '", path,"').", sep = "")) } else{ stop("downloadModule does not work without httr package: ", "install.package('httr')") @@ -404,7 +410,7 @@ setMethod( return(list(c(files, files2), setDF(rbindlist(list(dataList, dataList2), use.names = TRUE, fill = TRUE)))) -}) + }) #' @rdname downloadModule setMethod( @@ -421,7 +427,7 @@ setMethod( data = FALSE, quiet = FALSE, quickCheck = quickCheck, overwrite = overwrite) return(invisible(files)) -}) + }) #' @rdname downloadModule setMethod( @@ -443,3 +449,4 @@ setMethod( files <- downloadModule(name, path, version, repo, data, quiet, quickCheck, overwrite) return(invisible(files)) }) + diff --git a/R/reexports.R b/R/reexports.R index 8d9990ff..e8cba1fd 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -8,6 +8,9 @@ ## and compareVersion2 <- getFromNamespace("compareVersion2", "Require") extractInequality <- getFromNamespace("extractInequality", "Require") +GETWauthThenNonAuth <- getFromNamespace("GETWauthThenNonAuth", "Require") +getGitCredsToken <- getFromNamespace("getGitCredsToken", "Require") +trimRedundancies <- getFromNamespace("trimRedundancies", "Require") getDrv <- getFromNamespace("getDrv", "reproducible") isWindows <- getFromNamespace("isWindows", "reproducible") @@ -15,6 +18,9 @@ isAbsolutePath <- getFromNamespace("isAbsolutePath", "reproducible") isRaster <- getFromNamespace("isRaster", "reproducible") isSpat <- getFromNamespace("isSpat", "reproducible") layerNamesDelimiter <- getFromNamespace("layerNamesDelimiter", "reproducible") +.updateTagsRepo <- getFromNamespace(".updateTagsRepo", "reproducible") +.addTagsRepo <- getFromNamespace(".addTagsRepo", "reproducible") + makeAbsolute <- getFromNamespace("makeAbsolute", "reproducible") diff --git a/R/simulation-spades.R b/R/simulation-spades.R index f71b3ac4..85195e89 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -2342,10 +2342,10 @@ allowSequentialCachingFinal <- function(sim) { tagValue = c(thisCacheId, cur[["moduleName"]], cur[["eventType"]]), cachePath = cp) if (all(c(cur[["moduleName"]], cur[["eventType"]]) %in% seqCache$tagValue) || NROW(seqCache) == 0) { - fn <- reproducible:::.updateTagsRepo + fn <- .updateTagsRepo args$add = TRUE } else { - fn <- reproducible:::.addTagsRepo + fn <- .addTagsRepo } # put all tags in diff --git a/man/downloadModule.Rd b/man/downloadModule.Rd index 25c06870..e9426dff 100644 --- a/man/downloadModule.Rd +++ b/man/downloadModule.Rd @@ -97,5 +97,5 @@ The default is to overwrite any existing files in the case of a conflict. \code{\link[=zipModule]{zipModule()}} for creating module .zip folders. } \author{ -Alex Chubaty +Alex Chubaty and Eliot McIntire } diff --git a/man/getModuleVersion.Rd b/man/getModuleVersion.Rd index fcccb927..399b9fc9 100644 --- a/man/getModuleVersion.Rd +++ b/man/getModuleVersion.Rd @@ -6,11 +6,11 @@ \alias{getModuleVersion,character,missing-method} \title{Find the latest module version from a SpaDES module repository} \usage{ -getModuleVersion(name, repo, token) +getModuleVersion(name, repo, token, moduleFiles = NULL) -\S4method{getModuleVersion}{character,character}(name, repo, token) +\S4method{getModuleVersion}{character,character}(name, repo, token, moduleFiles = NULL) -\S4method{getModuleVersion}{character,missing}(name, token) +\S4method{getModuleVersion}{character,missing}(name, token, moduleFiles = NULL) } \arguments{ \item{name}{Character string giving the module name.} @@ -19,6 +19,9 @@ getModuleVersion(name, repo, token) Default is \code{"PredictiveEcology/SpaDES-modules"}, which is specified by the global option \code{spades.moduleRepo}. Only \code{master}/\code{main} branches can be used at this point.} + +\item{moduleFiles}{Optional. List of files of the \code{name} and \code{repo}. If not +supplied, this function will get that information by using \code{checkModule}.} } \value{ \code{numeric_version} diff --git a/man/objSize.simList.Rd b/man/objSize.simList.Rd index 2916a62f..bcb91864 100644 --- a/man/objSize.simList.Rd +++ b/man/objSize.simList.Rd @@ -4,7 +4,7 @@ \alias{objSize.simList} \title{Object size for \code{simList}} \usage{ -\method{objSize}{simList}(x, quick = FALSE, ...) +\method{objSize}{simList}(x, quick = FALSE, recursive = FALSE, ...) } \arguments{ \item{x}{An object} @@ -12,6 +12,9 @@ \item{quick}{Logical. If \code{FALSE}, then an attribute, "objSize" will be added to the returned value, with each of the elements' object size returned also.} +\item{recursive}{Logical. If \code{TRUE}, then, in addition to evaluating the whole object, +it will also return the recursive sizes of the elements of a list or environment.} + \item{...}{Additional arguments (currently unused), enables backwards compatible use.} } \value{ diff --git a/man/restartR.Rd b/man/restartR.Rd index 0d795b5e..c94f96c5 100644 --- a/man/restartR.Rd +++ b/man/restartR.Rd @@ -38,7 +38,7 @@ If \code{NULL}, then it will try, in order, \code{outputPath(sim)}, taking the first one that is not inside the \code{tempdir()}, which will disappear during restart of R. The actual directory for a given \code{spades} call that is restarting will be: -\code{file.path(restartDir, "restartR", paste0(sim$._startClockTime, "_", .rndString))}. +\code{file.path(restartDir, "restartR", paste0(sim[[._startClockTimeTxt]], "_", .rndString))}. The random string is to prevent parallel processes that started at the same clock time from colliding.} } @@ -72,7 +72,7 @@ the default behaviour should suffice. These are of 3 types: \code{restartRInterv the arguments to \code{restartR} and the arguments to \code{saveSimList}, these latter two using a dot to separate the function name and its argument. The defaults for two key options are: \verb{options("spades.restartR.restartDir" = NULL}, meaning -use \code{file.path(restartDir, "restartR", paste0(sim$._startClockTime, "_", .rndString))} +use \code{file.path(restartDir, "restartR", paste0(sim[[._startClockTimeTxt]], "_", .rndString))} and \code{options("spades.saveSimList.fileBackend" = 0)}, which means don't do anything with raster-backed files. See specific functions for defaults and argument meanings. diff --git a/tests/testthat/test-Plots.R b/tests/testthat/test-Plots.R index b20de3b9..bee51238 100644 --- a/tests/testthat/test-Plots.R +++ b/tests/testthat/test-Plots.R @@ -251,7 +251,7 @@ test_that("Plots function 3 - use as Plot", { test_that("Plots test .guessPkgFun", { testInit("raster") - pkgFun <- sapply(baseClassesCanHandle, SpaDES.core:::.guessPkgFun) + pkgFun <- sapply(baseClassesCanHandle, .guessPkgFun) test <- sapply(pkgFun, function(x) { exists(sub(".*:", "", x), where = paste0("package:", sub(":.*", "", x)), mode = "function") }) diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index bcd57f63..bbb0137f 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -65,7 +65,7 @@ test_that("test event-level cache & memory leaks", { # Noting that there was a bug in `objSize` in reproducible that would # get this part wrong # Take a function from the package -- shouldn't trigger memory leak stuff - sims$crazyFunction2 <- SpaDES.core:::bindrows + sims$crazyFunction2 <- bindrows end(sims) <- end(sims) + 0.1 mess <- capture.output({ diff --git a/tests/testthat/test-environment.R b/tests/testthat/test-environment.R index cfd69e68..658aa6d5 100644 --- a/tests/testthat/test-environment.R +++ b/tests/testthat/test-environment.R @@ -1,7 +1,7 @@ test_that(".pkgEnv functions work", { test1 <- 1L:10L - assign("test1", test1, envir = SpaDES.core:::.pkgEnv) - expect_true(exists("test1", envir = SpaDES.core:::.pkgEnv)) - expect_equal(test1, get("test1", envir = SpaDES.core:::.pkgEnv)) + assign("test1", test1, envir = .pkgEnv) + expect_true(exists("test1", envir = .pkgEnv)) + expect_equal(test1, get("test1", envir = .pkgEnv)) }) diff --git a/tests/testthat/test-simList.R b/tests/testthat/test-simList.R index 7f39d68e..82aa343c 100644 --- a/tests/testthat/test-simList.R +++ b/tests/testthat/test-simList.R @@ -182,7 +182,7 @@ test_that("simList object initializes correctly (1)", { }) |> unlist() |> sort() |> - SpaDES.core:::.cleanPkgs() |> + .cleanPkgs() |> unique() expect_equal(sort(reqdPkgs), sort(pkgs)) @@ -192,7 +192,7 @@ test_that("simList object initializes correctly (1)", { reqdPkgs <- lapply(modules, function(m) packages(module = m)) |> unlist() |> sort() |> - SpaDES.core:::.cleanPkgs() |> + .cleanPkgs() |> unique() expect_equal(sort(reqdPkgs), sort(pkgs)) From a417bf2e052b3a1ef6387cf82bb39d86b2125b6e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 16:01:51 -0800 Subject: [PATCH 048/128] use objects instead of txt for hidden sim objects --- R/helpers.R | 12 +++--- R/restart.R | 14 +++---- R/simList-accessors.R | 4 +- R/simulation-simInit.R | 57 +++++++++++++++------------- R/simulation-spades.R | 12 +++--- tests/testthat/test-downloadModule.R | 1 + 6 files changed, 52 insertions(+), 48 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index c10ac1eb..3eb09f3a 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -329,12 +329,6 @@ all.equal.simList <- function(target, 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))) target1 <- .wrap(target, cachePath = getwd()) # deals with SpatVector/SpatRaster etc. current1 <- .wrap(current, cachePath = getwd()) # deals with SpatVector/SpatRaster etc. @@ -407,3 +401,9 @@ noEventWarning <- function(sim) { sep = "" ) } + + +._txtClockTime <- "._clockTime" +._txtStartClockTime <- "._startClockTime" +._txtPrevEventTimeFinish <- "._prevEventTimeFinish" +._txtSimNesting <- "._simNesting" diff --git a/R/restart.R b/R/restart.R index 93098a7f..456c5f53 100755 --- a/R/restart.R +++ b/R/restart.R @@ -1,5 +1,5 @@ utils::globalVariables(c( - ".", "._clockTime", "._prevEventTimeFinish", ".attachedPkgsFilename", "et", ".First", ".oldWd", + ".", ".attachedPkgsFilename", "et", ".First", ".oldWd", ".spadesCall", ".spades.restartRInterval", ".spades.simFilename" )) @@ -108,13 +108,13 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = numMods <- min(length(sim$.recoverableObjs), numEvents) if (numMods > 0) { com <- completed(sim) - etSecs <- sum(com[, et := difftime(clockTime, ._prevEventTimeFinish, units = "secs"), + etSecs <- sum(com[, et := difftime(get(._txtClockTime), get(._txtPrevEventTimeFinish), units = "secs"), by = seq_len(NROW(com))]$et) # remove the times of the completed events - 1 because the restartSpaDES includes the incompleted event # et <- difftime(tail(com$._clockTime, numMods - 1)[1], com$._clockTime[1]) st <- Sys.time() - sim$._startClockTime <- st - etSecs + sim[[._txtStartClockTime]] <- st - etSecs simCompletedList <- as.list(sim@completed) simCompletedList <- simCompletedList[order(as.integer(names(simCompletedList)))] @@ -124,7 +124,7 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = rm(list = names(eventsToReverse), envir = sim@completed) last <- as.character(length(sim@completed)) - sim@completed[[last]]$._clockTime <- st + sim@completed[[last]][[._txtClockTime]] <- st eventsToReplayDT <- events(sim)[seq_len(numMods)] if (numMods > length(sim$.recoverableObjs)) @@ -302,7 +302,7 @@ saveState <- function(filename, ...){ #' the arguments to `restartR` and the arguments to `saveSimList`, these latter two #' using a dot to separate the function name and its argument. The defaults for #' two key options are: `options("spades.restartR.restartDir" = NULL`, meaning -#' use `file.path(restartDir, "restartR", paste0(sim$._startClockTime, "_", .rndString))` +#' use `file.path(restartDir, "restartR", paste0(sim[[._txtStartClockTime]], "_", .rndString))` #' and `options("spades.saveSimList.fileBackend" = 0)`, which means don't do anything #' with raster-backed files. #' See specific functions for defaults and argument meanings. @@ -349,7 +349,7 @@ saveState <- function(filename, ...){ #' taking the first one that is not inside the `tempdir()`, which will #' disappear during restart of R. #' The actual directory for a given `spades` call that is restarting will be: -#' `file.path(restartDir, "restartR", paste0(sim$._startClockTime, "_", .rndString))`. +#' `file.path(restartDir, "restartR", paste0(sim[[._txtStartClockTime]], "_", .rndString))`. #' The random string is to prevent parallel processes that started at the same clock #' time from colliding. #' @@ -373,7 +373,7 @@ restartR <- function(sim, reloadPkgs = TRUE, .First = NULL, attached <- srch attached <- grep("package:", attached, value = TRUE) attached <- unlist(lapply(attached, function(x) gsub(x, pattern = "package:", replacement = ""))) - .newDir <- file.path(restartDir, "restartR", gsub(":| ", "_", paste0(sim$._startClockTime, "_", + .newDir <- file.path(restartDir, "restartR", gsub(":| ", "_", paste0(sim[[._txtStartClockTime]], "_", .rndString))) |> checkPath(create = TRUE) .attachedPkgsFilename <- file.path(.newDir, '.attachedPkgs.RData') diff --git a/R/simList-accessors.R b/R/simList-accessors.R index fa65fb82..bf7bef0f 100644 --- a/R/simList-accessors.R +++ b/R/simList-accessors.R @@ -2758,9 +2758,9 @@ setMethod( # note the above line captures empty eventTime, whereas `is.na` does not if (any(!is.na(obj$eventTime))) { if (!is.null(obj$eventTime)) { - if (!is.null(obj$._clockTime)) + if (!is.null(obj[[._txtClockTime]])) obj[, `:=`(eventTime = convertTimeunit(eventTime, unit, sim@.xData), - clockTime = obj$._clockTime, + clockTime = obj[[._txtClockTime]], ._clockTime = NULL)] } } diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index ba1cb5a6..9ce492ff 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -369,20 +369,23 @@ setMethod( notOlderThan, ...) { dots <- list(...) - if (is.null(dots$._startClockTime)) - ._startClockTime <- Sys.time() + if (is.null(dots[[._txtStartClockTime]])) + assign(._txtStartClockTime, Sys.time()) + # ._startClockTime <- Sys.time() else - ._startClockTime <- dots$._startClockTime - dots$._startClockTime <- NULL - dotNames <- setdiff(...names(), "._startClockTime") + assign(._txtStartClockTime, dots[[._txtStartClockTime]]) + # ._startClockTime <- dots[[._txtStartClockTime]] + dots[[._txtStartClockTime]] <- NULL + dotNames <- setdiff(...names(), ._txtStartClockTime) # create <- List object for the simulation sim <- new("simList") - sim@.xData[["._startClockTime"]] <- ._startClockTime + sim@.xData[[._txtStartClockTime]] <- get(._txtStartClockTime, inherits = FALSE) sim$._simInitElapsedTime <- 0 # loggingMessage helpers - ._simNesting <- simNestingSetup(...) - sim[["._simNesting"]] <- ._simNesting + # assign(._txtSimNesting, simNestingSetup(...)) + ._simNestingLocal <- simNestingSetup(...) + sim[[._txtSimNesting]] <- ._simNestingLocal opt <- options("encoding" = "UTF-8") if (isTRUE(getOption("spades.allowSequentialCaching"))) { @@ -391,10 +394,10 @@ setMethod( on.exit({ options(opt) - sim <- elapsedTimeInSimInit(._startClockTime, sim) - ._startClockTime <- Sys.time() - sim@.xData[["._startClockTime"]] <- NULL - dt <- difftime(._startClockTime, ._startClockTime - sim$._simInitElapsedTime) + sim <- elapsedTimeInSimInit(get(._txtStartClockTime, inherits = FALSE), sim) + ._startClockTimeLocal <- Sys.time() + sim@.xData[[._txtStartClockTime]] <- NULL + dt <- difftime(._startClockTimeLocal, ._startClockTimeLocal - sim$._simInitElapsedTime) message("Elapsed time for simInit: ", format(dt, format = "auto")) }, add = TRUE) @@ -1268,10 +1271,10 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out ) # loggingMessage helpers - simNestingRevert <- sim[["._simNesting"]] - on.exit(sim[["._simNesting"]] <- simNestingRevert, add = TRUE) - sim[["._simNesting"]] <- simNestingOverride(sim, mBase) - ._simNesting <- sim[["._simNesting"]] + simNestingRevert <- sim[[._txtSimNesting]] + on.exit(sim[[._txtSimNesting]] <- simNestingRevert, add = TRUE) + sim[[._txtSimNesting]] <- simNestingOverride(sim, mBase) + ._simNestingLocal <- sim[[._txtSimNesting]] allObjsProvided <- sim@depends@dependencies[[i]]@inputObjects[["objectName"]] %in% sim$.userSuppliedObjNames @@ -1649,17 +1652,17 @@ resolveDepsRunInitIfPoss <- function(sim, modules, paths, params, objects, input if (is.call(debug)) debug <- eval(debug) - len <- length(sim[["._simNesting"]]) - ._simNesting <- sim[["._simNesting"]] + len <- length(sim[[._txtSimNesting]]) + ._simNestingLocal <- sim[[._txtSimNesting]] val <- "intsDrngSmInt" - ._simNesting[len] <- val + ._simNestingLocal[len] <- val squash <- withCallingHandlers({ simAlt <- simInit(modules = canSafelyRunInit, paths = paths, params = params, objects = objects, inputs = inputs, outputs = outputs, times = list(start = as.numeric(start(sim)), end = as.numeric(end(sim)), timeunit = timeunit(sim)), - ._startClockTime = sim$._startClockTime) + ._startClockTime = sim[[._txtStartClockTime]]) simAlt@.xData$._ranInitDuringSimInit <- completed(simAlt)$moduleName messageVerbose(cli::col_yellow("**** Running spades call for:", safeToRunModules, "****")) simAltOut <- spades(simAlt, events = "init", debug = debug) @@ -1953,23 +1956,23 @@ prefixSimInit <- " simInit:" spaceDashDashSpace <- " -- " simNestingSetup <- function(...) { - prevSimEnv <- tryCatch(whereInStack("._simNesting"), error = function(x) character()) + prevSimEnv <- tryCatch(whereInStack(._txtSimNesting), error = function(x) character()) if (is.environment(prevSimEnv)) { - prevSimEnv <- get0("._simNesting", envir = prevSimEnv, inherits = FALSE) + prevSimEnv <- get0(._txtSimNesting, envir = prevSimEnv, inherits = FALSE) } - simNestingArg <- list(...)$._simNesting + simNestingArg <- list(...)[[._txtSimNesting]] messageTxt <- if (is.null(simNestingArg)) "simInit" else simNestingArg c(prevSimEnv, messageTxt) } #' @importFrom cli col_green simNestingOverride <- function(sim, mBase) { - len <- length(sim[["._simNesting"]]) - ._simNestingTail <- sim[["._simNesting"]][len] + len <- length(sim[[._txtSimNesting]]) + ._simNestingTail <- sim[[._txtSimNesting]][len] numCharsMax <- max(0, getOption("spades.messagingNumCharsModule", 21) - loggingMessagePrefixLength) modName8Chars <- moduleNameStripped(mBase, numCharsMax) - sim[["._simNesting"]][len] <- paste0(modName8Chars, ":", cli::col_green(sim@current$eventType)) - sim[["._simNesting"]] + sim[[._txtSimNesting]][len] <- paste0(modName8Chars, ":", cli::col_green(sim@current$eventType)) + sim[[._txtSimNesting]] } isMacOSX <- function() diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 85195e89..92f236e5 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -328,7 +328,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, # add to list of completed events if (.pkgEnv[["spades.keepCompleted"]]) { # can skip it with option - # cur$._clockTime <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) + # cur[[._txtClockTime]] <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) sim <- appendCompleted(sim, cur) } @@ -1931,7 +1931,7 @@ debugMessage <- function(debug, sim, cur, fnEnv, curModuleName) { attr(sim, "completedCounter") == 1) { sim@.xData$._startClockTime } else { - .POSIXct(sim@completed[[as.character(attr(sim, "completedCounter") - 1)]]$._clockTime) + .POSIXct(sim@completed[[as.character(attr(sim, "completedCounter") - 1)]][[._txtClockTime]]) } outMess <- paste0("elpsd: ", format(Sys.time() - compareTime, digits = 2), " | ", paste(format(unname(current(sim)), digits = 4), collapse = " ")) @@ -2376,7 +2376,7 @@ sequentialCacheText <- "SequentialCache_" appendCompleted <- function(sim, cur) { - cur[["._clockTime"]] <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) + cur[[._txtClockTime]] <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) last <- attr(sim, "completedCounter") isLastWrong <- length(sim@completed) != last @@ -2384,11 +2384,11 @@ appendCompleted <- function(sim, cur) { last <- attr(sim, "completedCounter") <- NULL } if (is.null(last)) { - prevTime <- cur[["._clockTime"]] + prevTime <- cur[[._txtClockTime]] } else { - prevTime <- sim@completed[[as.character(last)]]$._clockTime + prevTime <- sim@completed[[as.character(last)]][[._txtClockTime]] } - cur[["._prevEventTimeFinish"]] <- prevTime + cur[[._txtPrevEventTimeFinish]] <- prevTime if (!is.null(attr(sim, "completedCounter"))) { # use attr(sim, "completedCounter") #instead of sim@.xData because collisions with parallel sims from same sim object diff --git a/tests/testthat/test-downloadModule.R b/tests/testthat/test-downloadModule.R index 2da8d9f9..b699823c 100644 --- a/tests/testthat/test-downloadModule.R +++ b/tests/testthat/test-downloadModule.R @@ -29,6 +29,7 @@ test_that("downloadModule downloads and unzips a single module", { expect_true(all(f %in% f_expected)) }) + test_that("downloadModule downloads and unzips a parent module", { skip_on_cran() From af7dddaecb8a8fe10db1f3aab121ef633b694074 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 16:19:24 -0800 Subject: [PATCH 049/128] R CMD check --- R/createDESCRIPTIONandDocs.R | 1 + R/module-repository.R | 3 +++ R/reexports.R | 4 ++++ man/checkModule.Rd | 2 ++ man/createDESCRIPTIONandDocs.Rd | 6 ++++++ man/getModuleVersion.Rd | 2 ++ man/restartR.Rd | 4 ++-- tests/testthat/test-downloadModule.R | 5 ++++- tests/testthat/test-timeunits.R | 6 ++++-- tests/testthat/test-userSuppliedObjs.R | 3 ++- 10 files changed, 30 insertions(+), 6 deletions(-) diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 1a165ee2..6b215e9b 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -107,6 +107,7 @@ #' have an `@importFrom `, meaning **every** function from every package will #' be imported. If `FALSE`, then only functions explicitly imported using #' `@importFrom ` will be imported. +#' @inheritParams reproducible::Cache #' #' @return invoked for the side effect of creating DESCRIPTION file, a `.Rbuildingore` #' file and possibly building documentatation from roxygen tags. diff --git a/R/module-repository.R b/R/module-repository.R index 63c7b397..8df66103 100644 --- a/R/module-repository.R +++ b/R/module-repository.R @@ -31,6 +31,7 @@ defaultGitRepoToSpaDESModules <- "PredictiveEcology/SpaDES-modules" #' #' @author Alex Chubaty #' @export +#' @inheritParams checkModule #' @rdname getModuleVersion #' @seealso [zipModule()] for creating module \file{.zip} folders. #' @@ -83,6 +84,8 @@ setMethod("getModuleVersion", #' Default is `"PredictiveEcology/SpaDES-modules"`, which is #' specified by the global option `spades.moduleRepo`. #' +#' @param token A github repository token as from `gitcreds::gitcreds_get()` +#' #' @return a character vector of module file paths (invisibly). #' #' @author Eliot McIntire and Alex Chubaty diff --git a/R/reexports.R b/R/reexports.R index e8cba1fd..480b998a 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -1,3 +1,7 @@ +utils::globalVariables(c( + ".", "keepBasedOnRedundantInequalities", "inequality", "verbose", "inequality" +)) + ## non-exported imports from other packages ------------------------------------- .message <- getFromNamespace(".message", "reproducible") ## envir for messages + message-funs diff --git a/man/checkModule.Rd b/man/checkModule.Rd index 9b765e76..a26da29f 100644 --- a/man/checkModule.Rd +++ b/man/checkModule.Rd @@ -18,6 +18,8 @@ checkModule(name, repo, token) \item{repo}{GitHub repository name. Default is \code{"PredictiveEcology/SpaDES-modules"}, which is specified by the global option \code{spades.moduleRepo}.} + +\item{token}{A github repository token as from \code{gitcreds::gitcreds_get()}} } \value{ a character vector of module file paths (invisibly). diff --git a/man/createDESCRIPTIONandDocs.Rd b/man/createDESCRIPTIONandDocs.Rd index b517cfd5..8b81e0b7 100644 --- a/man/createDESCRIPTIONandDocs.Rd +++ b/man/createDESCRIPTIONandDocs.Rd @@ -24,6 +24,12 @@ be imported. If \code{FALSE}, then only functions explicitly imported using \item{buildDocuments}{A logical. If \code{TRUE}, the default, then the documentation will be built, if any exists, using \code{roxygen2::roxygenise}.} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} } \value{ Invoked for its side effects. There will be a new or modified diff --git a/man/getModuleVersion.Rd b/man/getModuleVersion.Rd index 399b9fc9..14cf3b81 100644 --- a/man/getModuleVersion.Rd +++ b/man/getModuleVersion.Rd @@ -20,6 +20,8 @@ Default is \code{"PredictiveEcology/SpaDES-modules"}, which is specified by the global option \code{spades.moduleRepo}. Only \code{master}/\code{main} branches can be used at this point.} +\item{token}{A github repository token as from \code{gitcreds::gitcreds_get()}} + \item{moduleFiles}{Optional. List of files of the \code{name} and \code{repo}. If not supplied, this function will get that information by using \code{checkModule}.} } diff --git a/man/restartR.Rd b/man/restartR.Rd index c94f96c5..982ca787 100644 --- a/man/restartR.Rd +++ b/man/restartR.Rd @@ -38,7 +38,7 @@ If \code{NULL}, then it will try, in order, \code{outputPath(sim)}, taking the first one that is not inside the \code{tempdir()}, which will disappear during restart of R. The actual directory for a given \code{spades} call that is restarting will be: -\code{file.path(restartDir, "restartR", paste0(sim[[._startClockTimeTxt]], "_", .rndString))}. +\code{file.path(restartDir, "restartR", paste0(sim[[._txtStartClockTime]], "_", .rndString))}. The random string is to prevent parallel processes that started at the same clock time from colliding.} } @@ -72,7 +72,7 @@ the default behaviour should suffice. These are of 3 types: \code{restartRInterv the arguments to \code{restartR} and the arguments to \code{saveSimList}, these latter two using a dot to separate the function name and its argument. The defaults for two key options are: \verb{options("spades.restartR.restartDir" = NULL}, meaning -use \code{file.path(restartDir, "restartR", paste0(sim[[._startClockTimeTxt]], "_", .rndString))} +use \code{file.path(restartDir, "restartR", paste0(sim[[._txtStartClockTime]], "_", .rndString))} and \code{options("spades.saveSimList.fileBackend" = 0)}, which means don't do anything with raster-backed files. See specific functions for defaults and argument meanings. diff --git a/tests/testthat/test-downloadModule.R b/tests/testthat/test-downloadModule.R index b699823c..5e0312ed 100644 --- a/tests/testthat/test-downloadModule.R +++ b/tests/testthat/test-downloadModule.R @@ -86,7 +86,10 @@ test_that("downloadModule can overwrite existing modules", { list.files(full.names = TRUE, pattern = "[.]R$") |> file.info() - expect_error(downloadModule(m, tmpdir, quiet = TRUE, data = FALSE, overwrite = FALSE)) + warns <- capture_warnings( + downloadModule(m, tmpdir, quiet = TRUE, data = FALSE, overwrite = FALSE)) + expect_match(paste(warns, collapse = "_"), all = FALSE, fixed = FALSE, regexp = "not overwriting") + f <- .tryCatch(downloadModule(m, tmpdir, quiet = TRUE, data = FALSE, overwrite = TRUE)) diff --git a/tests/testthat/test-timeunits.R b/tests/testthat/test-timeunits.R index 470ba3db..47c9651b 100644 --- a/tests/testthat/test-timeunits.R +++ b/tests/testthat/test-timeunits.R @@ -241,7 +241,8 @@ test_that("timeunits with child and parent modules work correctly", { }) mm1 <- cleanMessage(mm1) fullMessage <- c( - "Running .inputObjects for child6", + grepDotInputObjectsModule("child6"), + # "Running .inputObjects for child6", "child6: module code: b is declared in metadata inputObjects, but is not used in the module", "child6: outputObjects: dp, cm are assigned to sim inside doEventchild6, but are not declared in metadata outputObjects" ) @@ -272,5 +273,6 @@ test_that("timeunits with child and parent modules work correctly", { }) mm1 <- cleanMessage(mm1) expect_true(all(unlist(lapply(fullMessage, function(x) any(grepl(mm1, pattern = x)))))) - expect_true(any(grepl("Running .inputObjects", mm1))) + expect_true(any(grepl(grepDotInputObjectsModule("child6"), mm1))) + # expect_true(any(grepl("Running .inputObjects", mm1))) }) diff --git a/tests/testthat/test-userSuppliedObjs.R b/tests/testthat/test-userSuppliedObjs.R index ce2978db..a44c224e 100644 --- a/tests/testthat/test-userSuppliedObjs.R +++ b/tests/testthat/test-userSuppliedObjs.R @@ -22,7 +22,8 @@ test_that("test userSuppliedObj", { sep = "\n", fill = FALSE, file = fileName) fullMessage <- c( - "Running .inputObjects for test", + grepDotInputObjectsModule("test"), + # "Running .inputObjects for test", "test: module code: ei2 is declared in metadata inputObjects, but no default\\(s\\) is provided in .inputObjects", "test: module code: ei1, ei2 are declared in metadata inputObjects, but are not used in the module", "test: inputObjects: ei3 is used from sim inside .inputObjects, but is not declared in metadata inputObjects" From f2145e06e809d87e6ac77b84b464f61cc9525f7b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 17 Jan 2025 16:22:35 -0800 Subject: [PATCH 050/128] Bump --- DESCRIPTION | 4 ++-- tests/test-all.R | 20 +++++++++++++------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1f3468c6..ebe8a17e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-01-11 -Version: 2.1.5.9007 +Date: 2025-01-17 +Version: 2.1.5.9008 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/tests/test-all.R b/tests/test-all.R index ba7edede..126975bd 100644 --- a/tests/test-all.R +++ b/tests/test-all.R @@ -1,9 +1,15 @@ library(testthat) -aa <- options(spades.debug = FALSE) -options("spades.temp.debug" = aa) -if (FALSE) { - ff <- list() - runTestsWithTimings("ff") +withr::local_options(spades.debug = FALSE) + +## run all tests using different combinations of env vars +if (nzchar(Sys.getenv("NOT_CRAN")) && as.logical(Sys.getenv("NOT_CRAN"))) { + withr::local_options(spades.useBox = TRUE) + # Sys.setenv(R_REPRODUCIBLE_USE_DBI = "false") + test_check("SpaDES.core") + + withr::local_options(spades.useBox = FALSE) + test_check("SpaDES.core") +} else { + test_check("SpaDES.core") } -test_check("SpaDES.core") -options(aa) + From bee4ed2babeabed786d2de028754d55eaeb0db7f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 19 Jan 2025 13:35:30 -0800 Subject: [PATCH 051/128] ._txtClockTime needs --- R/memory.R | 8 ++++---- R/simList-accessors.R | 11 ++++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/R/memory.R b/R/memory.R index 59911109..4f1202cd 100755 --- a/R/memory.R +++ b/R/memory.R @@ -115,10 +115,10 @@ memoryUse <- function(sim, max = TRUE) { } else { # make sure same tz if (any(grepl("^time$", names(mem)))) - setnames(mem, old = "time", new = "clockTime") - mem[, clockTime := as.POSIXct(as.character(clockTime))] # In case these two objects are in different tz - compl[, clockTime := as.POSIXct(as.character(clockTime))] - a <- mem[compl, on = c("clockTime"), roll = TRUE, allow.cartesian = TRUE] + setnames(mem, old = "time", new = ._txtClockTime) + mem[, eval(._txtClockTime) := as.POSIXct(as.character(get(._txtClockTime)))] # In case these two objects are in different tz + compl[, eval(._txtClockTime) := as.POSIXct(as.character(get(._txtClockTime)))] + a <- mem[compl, on = c(._txtClockTime), roll = TRUE, allow.cartesian = TRUE] if (isTRUE(max)) { a <- a[, list(maxMemory = max(memory, na.rm = TRUE)), by = c("moduleName", "eventType")] } else { diff --git a/R/simList-accessors.R b/R/simList-accessors.R index bf7bef0f..7177707c 100644 --- a/R/simList-accessors.R +++ b/R/simList-accessors.R @@ -2758,10 +2758,11 @@ setMethod( # note the above line captures empty eventTime, whereas `is.na` does not if (any(!is.na(obj$eventTime))) { if (!is.null(obj$eventTime)) { - if (!is.null(obj[[._txtClockTime]])) - obj[, `:=`(eventTime = convertTimeunit(eventTime, unit, sim@.xData), - clockTime = obj[[._txtClockTime]], - ._clockTime = NULL)] + if (!is.null(obj[[._txtClockTime]])) { + obj[, `:=`(eventTime = convertTimeunit(eventTime, unit, sim@.xData))] + #clockTime = obj[[._txtClockTime]], + #._clockTime = NULL)] + } } } } @@ -3338,7 +3339,7 @@ elapsedTime.simList <- function(x, byEvent = TRUE, units = "auto", ...) { if (!is.null(comp)) { comp <- comp[, list(moduleName, eventType, - diffTime = diff(c(x@.xData[["._firstEventClockTime"]], clockTime)))] + diffTime = diff(c(x@.xData[["._firstEventClockTime"]], get(._txtClockTime))))] theBy <- if (isTRUE(byEvent)) { c("moduleName", "eventType") } else { From bdf42daf98cbe2a2b5587355bc676a9fd853b3c3 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 19 Jan 2025 13:35:43 -0800 Subject: [PATCH 052/128] test elapsedTime.simList --- tests/testthat/test-simList.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/testthat/test-simList.R b/tests/testthat/test-simList.R index 82aa343c..ea7ed448 100644 --- a/tests/testthat/test-simList.R +++ b/tests/testthat/test-simList.R @@ -427,6 +427,12 @@ test_that("test sped-up Caching of sequentially cached events", { mess <- capture_messages({ mySimOut <- spades(mySim, debug = 1, .plotInitialTime = NA) }) + et <- elapsedTime(mySimOut) + mins <- "mins" + et2 <- elapsedTime(mySimOut, units = mins) + expect_is(et, "data.table") + expect_identical(units(et2$elapsedTime), mins) + expect_identical(colnames(et), c("moduleName", "eventType", "elapsedTime")) expect_false(any(grepl("Skipped digest", mess))) ## Rerun with Cached copies being recovered From b21667c9f12c56f7434ade14d0249c29f517b4da Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 19 Jan 2025 21:15:37 -0800 Subject: [PATCH 053/128] R CMD checking --- DESCRIPTION | 2 ++ R/Plots.R | 1 + R/suppliedElsewhere.R | 2 +- man/Plots.Rd | 1 + tests/testthat/test-downloadModule.R | 13 ++++++++++--- 5 files changed, 15 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ebe8a17e..6a4d5b22 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,11 +52,13 @@ Suggests: CircStats, codetools, covr, + DBI, DiagrammeR (>= 0.8.2), future, future.callr, ggplot2, ggplotify, + gitcreds, httr, knitr, lattice, diff --git a/R/Plots.R b/R/Plots.R index 6ce4e804..984ac7c3 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -147,6 +147,7 @@ ggplotClassesCanHandle <- c("eps", "ps", "tex", "pdf", "jpeg", "tiff", "png", "b #' .plotInitialTime = 1) #' } #' } # end ggplot +#' unlink("figures") # clean up #' } # end of dontrun Plots <- function(data, fn, filename, types = quote(params(sim)[[currentModule(sim)]]$.plots), diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index 90808927..0d4d2940 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -1,4 +1,4 @@ -utils::globalVariables(c("objName", "V1")) +utils::globalVariables(c("objName", "V1", "noFeedback")) #' Assess whether an object has or will be supplied from elsewhere diff --git a/man/Plots.Rd b/man/Plots.Rd index d760909c..8164b27f 100644 --- a/man/Plots.Rd +++ b/man/Plots.Rd @@ -165,5 +165,6 @@ the file(s) that is/are saved will be appended to the \code{outputs} slot of the .plotInitialTime = 1) } } # end ggplot + unlink("figures") # clean up } # end of dontrun } diff --git a/tests/testthat/test-downloadModule.R b/tests/testthat/test-downloadModule.R index 5e0312ed..de237c2a 100644 --- a/tests/testthat/test-downloadModule.R +++ b/tests/testthat/test-downloadModule.R @@ -86,9 +86,16 @@ test_that("downloadModule can overwrite existing modules", { list.files(full.names = TRUE, pattern = "[.]R$") |> file.info() - warns <- capture_warnings( - downloadModule(m, tmpdir, quiet = TRUE, data = FALSE, overwrite = FALSE)) - expect_match(paste(warns, collapse = "_"), all = FALSE, fixed = FALSE, regexp = "not overwriting") + errs <- capture_error( + warns <- capture_warnings( + downloadModule(m, tmpdir, quiet = TRUE, data = FALSE, overwrite = FALSE)) + ) + if (!is.null(getGitCredsToken())) { + expect_match(paste(warns, collapse = "_"), all = FALSE, fixed = FALSE, regexp = "not overwriting") + } else { + expect_match(paste(errs, collapse = "_"), all = FALSE, fixed = FALSE, regexp = "overwrite is FALSE") + } + From 5b3e68d222555afb5f45d95d805ef418ae259635 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 22 Jan 2025 09:12:00 -0800 Subject: [PATCH 054/128] rm .modifySearchPath --- R/options.R | 6 +---- R/simulation-simInit.R | 2 +- R/simulation-spades.R | 18 +++++++-------- tests/testthat/test-misc.R | 46 +++++++++++++++++++------------------- 4 files changed, 34 insertions(+), 38 deletions(-) diff --git a/R/options.R b/R/options.R index c49b2b16..6ca80e09 100644 --- a/R/options.R +++ b/R/options.R @@ -162,11 +162,7 @@ #' undesirable for some situations where speed is critical. If `FALSE`, then #' this is not assigned to the `simList`.\cr #' -#' `spades.switchPkgNamespaces` \tab `FALSE` to keep computational -#' overhead down. \tab Should the search path be modified -#' to ensure a module's required packages are listed first? -#' If `TRUE`, there should be no name conflicts among package objects, -#' but it is much slower, especially if the events are themselves fast. \cr +#' `spades.switchPkgNamespaces` \tab Defunct. \tab Use `spades.useBox` option \cr #' #' `spades.testMemoryLeaks` \tab `TRUE`. #' \tab There is a very easy way to create a memory leak with R and SpaDES, diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 9ce492ff..b1b079f7 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1409,7 +1409,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out } } else { - .modifySearchPath(pkgs = sim@depends@dependencies[[i]]@reqdPkgs) + # .modifySearchPath(pkgs = sim@depends@dependencies[[i]]@reqdPkgs) .inputObjects <- .getModuleInputObjects(sim, mBase) if (!is.null(.inputObjects)) { sim <- .inputObjects(sim) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 92f236e5..8ecbdbc5 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -235,9 +235,9 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, } # This is to create a namespaced module call - if (!.pkgEnv[["skipNamespacing"]]) - .modifySearchPath(sim@depends@dependencies[[curModuleName]]@reqdPkgs, - removeOthers = FALSE) + # if (!.pkgEnv[["skipNamespacing"]]) + # .modifySearchPath(sim@depends@dependencies[[curModuleName]]@reqdPkgs, + # removeOthers = FALSE) skipEvent <- FALSE if (!is.null(eventSeed)) { @@ -274,7 +274,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, spacing <- paste(rep(" ", sim[["._spadesDebugWidth"]][1] + 1), collapse = "") messageVerbose( cli::col_magenta(paste0(spacing, cur[["moduleName"]], " outputs not needed by ", - "next module (", nextScheduledEvent, ")")), + "next module (", nextScheduledEvent, ")")), verbose = 1 - (debug %in% FALSE)) simFuture <- sim$.simFuture sim$.simFuture <- list() @@ -326,7 +326,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, } } - # add to list of completed events + # add to list of completed events if (.pkgEnv[["spades.keepCompleted"]]) { # can skip it with option # cur[[._txtClockTime]] <- Sys.time() # adds between 1 and 3 microseconds, per event b/c R won't let us use .Internal(Sys.time()) sim <- appendCompleted(sim, cur) @@ -833,7 +833,7 @@ setGeneric( .plotInitialTime = NULL, .saveInitialTime = NULL, notOlderThan = NULL, events = NULL, .plots = getOption("spades.plots", NULL), ...) { standardGeneric("spades") -}) + }) #' @rdname spades setMethod( @@ -981,7 +981,7 @@ setMethod( .pkgEnv[["spades.browserOnError"]] <- (interactive() & !identical(debug, FALSE) & getOption("spades.browserOnError")) .pkgEnv[["spades.nCompleted"]] <- getOption("spades.nCompleted") - .pkgEnv[["skipNamespacing"]] <- !getOption("spades.switchPkgNamespaces") + # .pkgEnv[["skipNamespacing"]] <- !getOption("spades.switchPkgNamespaces") .pkgEnv[["spades.keepCompleted"]] <- getOption("spades.keepCompleted", TRUE) # Memory Use @@ -1002,8 +1002,8 @@ setMethod( # timeunits gets accessed every event -- this should only be needed once per simList sim@.xData$.timeunits <- timeunits(sim) on.exit({ - if (!.pkgEnv[["skipNamespacing"]]) - .modifySearchPath(.pkgEnv$searchPath, removeOthers = TRUE) + # if (!.pkgEnv[["skipNamespacing"]]) + # .modifySearchPath(.pkgEnv$searchPath, removeOthers = TRUE) rm(".timeunits", envir = sim@.xData) diff --git a/tests/testthat/test-misc.R b/tests/testthat/test-misc.R index 089e9287..34831673 100644 --- a/tests/testthat/test-misc.R +++ b/tests/testthat/test-misc.R @@ -20,29 +20,29 @@ test_that(".emptyEventList tests", { expect_true(identical(unname(as.matrix(b)), unname(as.matrix(b1)))) }) -test_that("modify search path", { - testInit(smcc = FALSE) - - pkgToAttach <- "cli" - spPre <- search() - a <- .modifySearchPath(pkgs = pkgToAttach, skipNamespacing = FALSE) - spPost <- search() - expect_true(identical(grep(pkgToAttach, spPost), 2L)) - detach("package:cli") - spPost2 <- search() - expect_false(identical(grep(pkgToAttach, spPost2), 2L)) - - # use removeOthers - pkgToAttach <- c("cli", "reproducible", "quickPlot") - spPre <- search() - a <- .modifySearchPath(pkgs = pkgToAttach, removeOthers = TRUE, skipNamespacing = FALSE) - spPost <- search() - expect_true(any(grep(pkgToAttach[1], spPost) == 2L)) - expect_true(identical(grep("digest", spPost), integer())) - detach("package:cli") - spPost2 <- search() - expect_false(any(grep(pkgToAttach[1], spPost2) == 2L)) -}) +# test_that("modify search path", { +# testInit(smcc = FALSE) +# +# pkgToAttach <- "cli" +# spPre <- search() +# a <- .modifySearchPath(pkgs = pkgToAttach, skipNamespacing = FALSE) +# spPost <- search() +# expect_true(identical(grep(pkgToAttach, spPost), 2L)) +# detach("package:cli") +# spPost2 <- search() +# expect_false(identical(grep(pkgToAttach, spPost2), 2L)) +# +# # use removeOthers +# pkgToAttach <- c("cli", "reproducible", "quickPlot") +# spPre <- search() +# a <- .modifySearchPath(pkgs = pkgToAttach, removeOthers = TRUE, skipNamespacing = FALSE) +# spPost <- search() +# expect_true(any(grep(pkgToAttach[1], spPost) == 2L)) +# expect_true(identical(grep("digest", spPost), integer())) +# detach("package:cli") +# spPost2 <- search() +# expect_false(any(grep(pkgToAttach[1], spPost2) == 2L)) +# }) test_that("test all.equal.simList", { testInit(smcc = FALSE, "digest") From 078a71fe3cc11b9043385135aed29e0ec4a757b7 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:07:15 -0800 Subject: [PATCH 055/128] fix for caching with `@inputs` ... only this module's `@inputs` --- R/cache.R | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/R/cache.R b/R/cache.R index 8ad1cfd9..46c724b5 100644 --- a/R/cache.R +++ b/R/cache.R @@ -129,9 +129,6 @@ setMethod( 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]])) { @@ -153,6 +150,16 @@ setMethod( object@depends@dependencies <- object@depends@dependencies[classOptions$modules] } + if (NROW(object@inputs)) { + # Only include objects that are in the `inputs` slot that this module uses + if (length(curMod)) { # If it is a simInitAndSpades call, it doesn't have a curMod + expectsInputs <- deps[[curMod]]@inputObjects$objectName + # if (is(expectsInputs, "try-error")) browser() + object@inputs <- object@inputs[object@inputs$objectName %in% expectsInputs,] + } + object@inputs$file <- unlist(.robustDigest(object@inputs$file, quick = quick, length = length)) #nolint + } + # if this call is within a single module, only keep module-specific params if (length(curMod) > 0) { omitParams <- c(".showSimilar", ".useCache") @@ -685,7 +692,6 @@ setMethod( } # Now changed objects if (length(unlist(changedModEnvObjs))) { - # if (identical(currentModule(object), "canClimateData")) browser() Map(nam = names(changedModEnvObjs), objs = changedModEnvObjs, function(nam, objs) { objNames <- names(objs$.objects) # used to be "names(...)" -- but don't want `._` objs objNames <- grep("^._.+", objNames, value = TRUE, invert = TRUE) @@ -942,7 +948,6 @@ objSize.simList <- function(x, quick = FALSE, recursive = FALSE, ...) { # if (!quick) attr(total, "objSize") <- list(sim = attr(aa, "objSize"), other = attr(otherParts, "objSize")) - # browser() # attr(total, "objSize") <- sum(unlist(attr(aa, "objSize")), unlist(attr(otherParts, "objSize"))) # class(attr(total, "objSize")) <- "lobstr_bytes" From 8ed85ec0beea5485e46d3ca2d80338e45e7694a2 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:08:04 -0800 Subject: [PATCH 056/128] Plots -- allow directly `Plots(ggObj)` --- R/Plots.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/Plots.R b/R/Plots.R index 984ac7c3..2c922e5e 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -243,6 +243,10 @@ Plots <- function(data, fn, filename, if (missing(data)) { gg <- fn(...) } else { + if (is(data, "ggplot")) { + gg <- data + } + else gg <- fn(data, ...) } @@ -310,7 +314,8 @@ Plots <- function(data, fn, filename, names(ggListToScreen) <- gsub(names(ggListToScreen), pattern = " |(\\\n)|[[:punct:]]", replacement = "_") Plot(ggListToScreen, addTo = gg$labels$title) } else { - if (!(identical(fn, plot) || identical(fn, terra::plot))) + if ((!(identical(fn, plot) || identical(fn, terra::plot)) || is(gg, "gg")) && + !is(gg, ".quickPlot")) print(gg) } } From 3fd97a7252b15d9f530240a4832cf98821ae9f7c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:08:31 -0800 Subject: [PATCH 057/128] return the `gg` object invisibly for layering later --- R/Plots.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/Plots.R b/R/Plots.R index 2c922e5e..fea60d47 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -422,6 +422,9 @@ Plots <- function(data, fn, filename, if (exists("sim", inherits = FALSE)) assign("sim", sim, envir = simIsIn) + if (exists("gg", inherits = FALSE)) + return(invisible(gg)) + else return(invisible(NULL)) } From 122a0dbf1a9f5a58b343191cbb16999e4ce7c939 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:08:57 -0800 Subject: [PATCH 058/128] Plots -- if `filename` is absolute, accept it --- R/Plots.R | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/R/Plots.R b/R/Plots.R index fea60d47..9b2ec892 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -323,10 +323,22 @@ Plots <- function(data, fn, filename, needSaveRaw <- any(grepl("raw", types)) if (needSave || needSaveRaw) { if (missing(filename)) { - filename <- tempfile(fileext = "") ## TODO: can we use e.g. the object name + sim time?? + dataObjName <- deparse(substitute(data)) + filename <- paste0(dataObjName, "_", basename(gsub("file", "", tempfile(fileext = "")))) ## TODO: can we use e.g. the object name + sim time?? + if (exists("sim", inherits = FALSE)) { + simTime <- round(as.numeric(time(sim)), 3) + filename <- paste0("sim", "_", filename) + } } else { - filename <- basename(filename) |> tools::file_path_sans_ext() + filename <- filename |> tools::file_path_sans_ext() + } + + if (isAbsolutePath(filename)) { + path <- dirname(filename) } + + filename <- basename(filename) + isDefaultPath <- identical(eval(formals(Plots)$path), path) if (!is.null(simIsIn)) { if (is(path, "call")) From a4cafaa6a7c5da6e0663d9c1af35274aa4b5dc62 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:10:50 -0800 Subject: [PATCH 059/128] rm "Work around for bug in qs that recovers data.tables as lists"; fails now; qs OK now --- R/Plots.R | 4 ++-- R/saveLoadSimList.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/Plots.R b/R/Plots.R index 9b2ec892..47125af1 100644 --- a/R/Plots.R +++ b/R/Plots.R @@ -247,7 +247,7 @@ Plots <- function(data, fn, filename, gg <- data } else - gg <- fn(data, ...) + gg <- fn(data, ...) } if (!is(gg, ".quickPlot")) { @@ -437,7 +437,7 @@ Plots <- function(data, fn, filename, if (exists("gg", inherits = FALSE)) return(invisible(gg)) else - return(invisible(NULL)) + return(invisible(NULL)) } #' Test whether there should be any plotting from `.plots` module parameter diff --git a/R/saveLoadSimList.R b/R/saveLoadSimList.R index 4a7903a9..d5844265 100644 --- a/R/saveLoadSimList.R +++ b/R/saveLoadSimList.R @@ -353,7 +353,7 @@ loadSimList <- function(filename, projectPath = getwd(), tempPath = tempdir(), tmpsim <- .unwrap(tmpsim, cachePath = NULL, paths = paths(tmpsim)) # convert e.g., PackedSpatRaster ## Work around for bug in qs that recovers data.tables as lists - tmpsim <- recoverDataTableFromQs(tmpsim) + # tmpsim <- recoverDataTableFromQs(tmpsim) ## Deal with all the RasterBacked Files that will be wrong if (any(nchar(otherFiles) > 0)) { From 644b5abff759d4194cf8cb2a1c8284025ee5a195 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 7 Feb 2025 15:12:05 -0800 Subject: [PATCH 060/128] recoverModePre -- use `try(Copy` b/c files can become corrupted --- R/simulation-spades.R | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 92f236e5..dcbe6abb 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1547,13 +1547,18 @@ recoverModePre <- function(sim, rmo = NULL, allObjNames = NULL, recoverMode) { curMod <- sim@events[[1]][["moduleName"]] objsInSimListAndModule <- ls(sim) %in% allObjNames[[curMod ]] # This makes a copy of the objects that are needed, and adds them to the list of rmo$recoverableObjs + mess <- capture.output(type = "message", { newList <- list(if (any(objsInSimListAndModule)) { - Copy(mget(ls(sim)[objsInSimListAndModule], envir = sim@.xData), - filebackedDir = file.path(getOption("spades.scratchPath"), "._rmo")) + # files may disappear for one reason or another; this will fail, silently + try(Copy(mget(ls(sim)[objsInSimListAndModule], envir = sim@.xData), + filebackedDir = file.path(getOption("spades.scratchPath"), "._rmo"))) } else { list() }) + if (is(newList, "try-error")) + stop(newList) + names(newList) <- curMod rmo$recoverableObjs <- append(newList, rmo$recoverableObjs) }) From 256aa79fda2f7dea8339a066c8333ea04ef630de Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 14 Feb 2025 15:59:01 -0800 Subject: [PATCH 061/128] spades.useBox implementation memory explodes; rm --- R/options.R | 2 +- R/simulation-parseModule.R | 2 +- R/simulation-simInit.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/options.R b/R/options.R index 6ca80e09..ca65daf7 100644 --- a/R/options.R +++ b/R/options.R @@ -242,7 +242,7 @@ spadesOptions <- function() { spades.testMemoryLeaks = TRUE, spades.tolerance = .Machine$double.eps ^ 0.5, spades.useragent = "https://github.com/PredictiveEcology/SpaDES", - spades.useBox = TRUE, + spades.useBox = FALSE, spades.useRequire = !tolower(Sys.getenv("SPADES_USE_REQUIRE")) %in% "false", spades.keepCompleted = TRUE ) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index bec7ffdb..2b819bc8 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -590,7 +590,7 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = pkgs <- Require::extractPkgName(unlist(eval(pkgs))) pkgs <- reqdPkgsDontLoad(pkgs) # some are explicitly not to be loaded - if (getOption("spades.useBox")) { + if (getOption("spades.useBox") && FALSE) { # TURN THIS OFF AS THERE ARE MEMORY HOGGING ISSUES WITH BOX cm <- currentModule(tmpEnvir$sim) if (length(cm)) if (!cm %in% unlist(.coreModules())) { diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index b1b079f7..d821e13e 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1379,7 +1379,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (runFnCallAsExpr) { pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) pkgs <- c(pkgs, "stats") - if (getOption("spades.useBox")) + if (getOption("spades.useBox") && FALSE) do.call(box::use, lapply(pkgs, as.name)) debugForCache <- debugToVerbose(debug) sim <- Cache(.inputObjects, sim, From 7275d297699105b27039414d2e8b4845f5793cb1 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 14 Feb 2025 15:59:35 -0800 Subject: [PATCH 062/128] restartSpades catch missing sim with meaningful stop --- R/restart.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/restart.R b/R/restart.R index 456c5f53..8d44a86c 100755 --- a/R/restart.R +++ b/R/restart.R @@ -94,6 +94,8 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = if (is.null(sim)) { sim <- savedSimEnv()$.sim } + if (!is(sim, "simList")) + stop("The simList does not exist or is corrupt; please pass a simList") if (is.character(sim)) { sim <- SpaDES.core::loadSimList(sim) From 87573bac06c6f63e1457267bfcc27cf2db444a28 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 14 Feb 2025 16:00:04 -0800 Subject: [PATCH 063/128] Bump --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6a4d5b22..0a11dab9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-01-17 -Version: 2.1.5.9008 +Date: 2025-02-14 +Version: 2.1.5.9009 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), From 4ee880573a4118a22c5960999c6a789a0b2bdc48 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 19 Feb 2025 21:53:01 -0800 Subject: [PATCH 064/128] move restartSpades chunk --- DESCRIPTION | 4 ++-- R/restart.R | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0a11dab9..c9e6d294 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-02-14 -Version: 2.1.5.9009 +Date: 2025-02-19 +Version: 2.1.5.9010 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/restart.R b/R/restart.R index 8d44a86c..2e861a7e 100755 --- a/R/restart.R +++ b/R/restart.R @@ -94,13 +94,13 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = if (is.null(sim)) { sim <- savedSimEnv()$.sim } - if (!is(sim, "simList")) - stop("The simList does not exist or is corrupt; please pass a simList") - if (is.character(sim)) { sim <- SpaDES.core::loadSimList(sim) } + if (!is(sim, "simList")) + stop("The simList does not exist or is corrupt; please pass a simList") + if (is.null(module)) { # Source the file you changed, into the correct location in the simList module <- events(sim)[["moduleName"]][1] From eb0c783ab40237538a787915df0bbbc40e0abf29 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 24 Feb 2025 10:03:49 -0800 Subject: [PATCH 065/128] restart -- stop for missing sim, shift --- R/restart.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/restart.R b/R/restart.R index 8d44a86c..06c08b30 100755 --- a/R/restart.R +++ b/R/restart.R @@ -94,13 +94,14 @@ restartSpades <- function(sim = NULL, module = NULL, numEvents = Inf, restart = if (is.null(sim)) { sim <- savedSimEnv()$.sim } - if (!is(sim, "simList")) - stop("The simList does not exist or is corrupt; please pass a simList") if (is.character(sim)) { sim <- SpaDES.core::loadSimList(sim) } + if (!is(sim, "simList")) + stop("The simList does not exist or is corrupt; please pass a simList") + if (is.null(module)) { # Source the file you changed, into the correct location in the simList module <- events(sim)[["moduleName"]][1] From e915d7547c960420e48b5f1ca831fb5de52bbddd Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 24 Feb 2025 10:04:55 -0800 Subject: [PATCH 066/128] bump --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0a11dab9..071878da 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-02-14 -Version: 2.1.5.9009 +Date: 2025-02-24 +Version: 2.1.5.9010 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), From 88047207b174e2ee351ebb386692bf187173c07f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 24 Feb 2025 10:07:25 -0800 Subject: [PATCH 067/128] merge part 2 --- cran-comments.md | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index 1b6b8e66..33521e0a 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -10,18 +10,18 @@ This release fixes a problem with an occasionally failing test. * Windows (win-builder), R 4.3.3 ### Current R versions -* macOS 14.5 (GitHub), R 4.4.0 -* macOS 13.3.1 (mac-builder), R 4.4.0 -* macOS 14.4.1 (local), R 4.4.0 -* Ubuntu 20.04 (GitHub), R 4.4.0 -* Ubuntu 20.04 (local), R 4.4.0 -* Windows (GitHub), R 4.4.0 -* Windows (local), R 4.4.0 -* Windows (win-builder), R 4.4.0 +* macOS 13.3.1 (mac-builder), R 4.4.2 +* macOS 14.7.2 (GitHub), R 4.4.2 +* macOS 14.4.1 (local), R 4.4.2 +* Ubuntu 22.04 (GitHub), R 4.4.2 +* Ubuntu 24.04 (local), R 4.4.2 +* Windows (GitHub), R 4.4.2 +* Windows (local), R 4.4.2 +* Windows (win-builder), R 4.4.2 ### Development R version * Ubuntu 20.04 (GitHub), R-devel (2024-05-28 r86639) -* Ubuntu 20.04 (local), R-devel (2024-05-28 r86640) +* Ubuntu 24.04 (local), R-devel (2024-05-28 r86640) * Windows (GitHub), R-devel (2024-05-28 r86639 ucrt) * Windows (win-builder), R-devel (2024-05-28 r86639 ucrt) From 1c74209702e819d36b670ee662e6b85cde82b5e5 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 26 Feb 2025 15:56:07 -0800 Subject: [PATCH 068/128] when updating params from .globals, it missed params whose defaults are NULL; fix --- DESCRIPTION | 4 ++-- R/simulation-simInit.R | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 071878da..093615c7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-02-24 -Version: 2.1.5.9010 +Date: 2025-02-25 +Version: 2.1.5.9011 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index d821e13e..92c314b9 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1707,11 +1707,15 @@ resolveDepsRunInitIfPoss <- function(sim, modules, paths, params, objects, input } updateParamsFromGlobals <- function(sim, dontUseGlobals = list()) { - sim@params <- updateParamsSlotFromGlobals(sim@params, dontUseGlobals = dontUseGlobals) + modDefaultParams <- Map(mod = sim@depends@dependencies, function(mod) mod@parameters$paramName) + sim@params <- updateParamsSlotFromGlobals(sim@params, dontUseGlobals = dontUseGlobals, + modDefaultParams = modDefaultParams) sim } -updateParamsSlotFromGlobals <- function(paramsOrig, paramsWithUpdates, dontUseGlobals = list()) { +updateParamsSlotFromGlobals <- function(paramsOrig, paramsWithUpdates, + dontUseGlobals = list(), + modDefaultParams) { if (missing(paramsWithUpdates)) { paramsWithUpdates <- paramsOrig } @@ -1719,7 +1723,7 @@ updateParamsSlotFromGlobals <- function(paramsOrig, paramsWithUpdates, dontUseGl globalsDF <- list() knownParamsWOdotPlotInitialTime <- setdiff(.knownDotParams, ".plotInitialTime") for (mod in setdiff(ls(paramsWithUpdates), unlist(.coreModules()))) { # don't include the dot paramsWithUpdates; just non hidden modules - modParams <- names(paramsOrig[[mod]]) + modParams <- modDefaultParams[[mod]] modParams <- union(modParams, knownParamsWOdotPlotInitialTime) userOverrides <- if (is.null(dontUseGlobals[[mod]])) NULL else dontUseGlobals[[mod]] common <- intersect(modParams, names(paramsWithUpdates$.globals)) @@ -1933,10 +1937,8 @@ dealWithOptions <- function(objects, dotNames, sim, elapsedTimeInSimInit <- function(._startClockTime, sim) { elapsed <- difftime(Sys.time(), ._startClockTime, units = "sec") #if (is.null(sim@.xData[["._simInitElapsedTime"]])) { - # browser() sim@.xData[["._simInitElapsedTime"]] <- elapsed #} else { - # browser() # sim@.xData[["._simInitElapsedTime"]] <- sim@.xData[["._simInitElapsedTime"]] + elapsed #} sim From a2ba42a02fa42aa1d854b8f55d3d12d51a3b285c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 28 Feb 2025 16:41:43 -0800 Subject: [PATCH 069/128] edge case for .robustDigest and .prepareOutputs -- was incorrect for @outputs (now only assesses outputs from this module; recovers data.table correctly) --- R/cache.R | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/R/cache.R b/R/cache.R index 46c724b5..abca51c8 100644 --- a/R/cache.R +++ b/R/cache.R @@ -126,8 +126,10 @@ setMethod( 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@outputs)) { + 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 + } deps <- object@depends@dependencies for (i in seq_along(deps)) { @@ -157,7 +159,9 @@ setMethod( # if (is(expectsInputs, "try-error")) browser() object@inputs <- object@inputs[object@inputs$objectName %in% expectsInputs,] } - object@inputs$file <- unlist(.robustDigest(object@inputs$file, quick = quick, length = length)) #nolint + if (NROW(object@inputs)) { # previous line may have removed row(s) from object@inputs, leaving potentially zero + object@inputs$file <- unlist(.robustDigest(object@inputs$file, quick = quick, length = length)) #nolint + } } # if this call is within a single module, only keep module-specific params @@ -221,6 +225,12 @@ setMethod( obj[["depends"]] <- invertList(dependsFirst) } + # outputs -- we only care if it was an output from this module + if (length(curMod) > 0) { + outputsFromThisMod <- object@depends@dependencies[[curMod]]$outputObjects$objectName + object@outputs <- object@outputs[object@outputs$objectName %in% outputsFromThisMod,] + } + otherDependsToDig <- c("childModules", "loadOrder", "reqdPkgs", "spatialExtent", "timeframe", "timeunit", "version") dependsSecond <- @@ -743,6 +753,16 @@ setMethod( } simPost@current <- simFromCache@current + # Outputs -- there may have been outputs added by another module that should be recovered + if (exists("aaaa", envir = .GlobalEnv)) browser() + if (length(currModules) > 0) { + outputsFromThisMod <- object@depends@dependencies[[currModules]]@outputObjects$objectName + simPost@outputs <- rbindlist(list( + simPost@outputs, object@outputs[!object@outputs$objectName %in% outputsFromThisMod,]), + use.names = TRUE, fill = TRUE) + } + + # 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) From 2209f4611d743e005d19e1eb92b16225b8d65aea Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 28 Feb 2025 16:42:30 -0800 Subject: [PATCH 070/128] restartOrSimInitAndSpades --- DESCRIPTION | 4 ++-- NAMESPACE | 1 + NEWS.md | 1 + R/restart.R | 47 ++++++++++++++++++++++++++++++++++++++++++++ man/restartSpades.Rd | 14 +++++++++++++ man/spadesOptions.Rd | 6 +----- 6 files changed, 66 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 093615c7..b130bc10 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-02-25 -Version: 2.1.5.9011 +Date: 2025-02-28 +Version: 2.1.5.9012 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/NAMESPACE b/NAMESPACE index 35b33856..fb605d3c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -183,6 +183,7 @@ export(rasterToMemory) export(registerOutputs) export(remoteFileSize) export(reqdPkgs) +export(restartOrSimInitAndSpades) export(restartR) export(restartSpades) export(rndstr) diff --git a/NEWS.md b/NEWS.md index 3adc13e8..c56b813e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # SpaDES.core (development version) +* fix edge case with caching of events; `outputs` would create false positives (i.e., a change, when there wasn't one); this meant that caching would only be successful after the 2nd time running the event, if another module had put objects in the `outputs` list, especially by using `Plots` * fix issue with `Plots()` where plots were discarded if no filename was specified; * minor documentation improvements; * new option: `spades.reqdPkgsDontLoad`, a character vector. If anything is specified, diff --git a/R/restart.R b/R/restart.R index 2e861a7e..3887e31d 100755 --- a/R/restart.R +++ b/R/restart.R @@ -475,6 +475,53 @@ restartR <- function(sim, reloadPkgs = TRUE, .First = NULL, } } + +#' `restartOrSimInitAndSpades` is a wrapper that runs either `restartSpades` or +#' `simInitAndSpades`. It determines which one should run by, first, assessing whether +#' an identical `ll` has already been passed in a previous call to this function. +#' If an identical `ll` has never been passed, then this will run +#' `simInitAndSpades`. If a previous `ll` as been run, then this will 2) +#' assess whether there is a copy of an `simList` at `SpaDES.core:::savedSimEnv()$.sim` +#' (i.e., like `restartSpades`). If there is, then it will run `restartSpades()`. +#' If there is no `simList` at `SpaDES.core:::savedSimEnv()$.sim`, then it will +#' pass the `file` argument to `restartSpades(file)`. +#' +#' @return A `simList`, that has been "executed" until `end(sim)`, if it does not +#' hit an error. +#' +#' @rdname restartSpades +#' @export +#' @param ll A list of elements that would be passed to `simInit`, such as `modules`. +#' @param file An optional file that has a saved `simList`, e.g., from `saveSimList` +#' or `saveState`. +#' @param reset Logical. If `TRUE`, then it will force `simInitAndSpades` to be called +#' even if there is saved `sim` available. +restartOrSimInitAndSpades <- function(out, file, + reset = getOption("spades.resetRestart")) { + # there are tempdir paths + pathsOrig <- out$paths + out$paths <- sapply(out$paths, grep, invert = TRUE, value = TRUE, pattern = tempdir(), simplify = TRUE) + fn <- function(out) out + cached <- attr(reproducible::Cache(fn(out), .functionName = "restartOrSimInitAndSpades"), ".Cache")$newCache %in% FALSE + if (isTRUE(reset)) + cached <- FALSE + out$paths <- pathsOrig + hasSavedToRAMState <- !is.null(SpaDES.core:::savedSimEnv()$.sim) + hasSavedToFileState <- file.exists(file) + if (!cached || !(hasSavedToFileState || hasSavedToRAMState)) { + message("out has changed; rerunning simInitAndSpades") + sim <- do.call(SpaDES.core::simInitAndSpades, out) + } else { + message("out has not changed; trying restartSpades") + if (isFALSE(hasSavedToRAMState)) { + sim <- SpaDES.core::restartSpades(file) + } else { + sim <- SpaDES.core::restartSpades() + } + } +} + + #' @keywords internal FirstFromR <- function(...) { ca <- commandArgs() diff --git a/man/restartSpades.Rd b/man/restartSpades.Rd index bd5be2d2..b51f9fa5 100644 --- a/man/restartSpades.Rd +++ b/man/restartSpades.Rd @@ -3,11 +3,14 @@ \name{restartSpades} \alias{restartSpades} \alias{saveState} +\alias{restartOrSimInitAndSpades} \title{Restart an interrupted simulation} \usage{ restartSpades(sim = NULL, module = NULL, numEvents = Inf, restart = TRUE, ...) saveState(filename, ...) + +restartOrSimInitAndSpades(out, file, reset = getOption("spades.resetRestart")) } \arguments{ \item{sim}{A \code{simList} or a filename that will load a \code{simList}, e.g., from @@ -35,9 +38,20 @@ with the module code parsed into the \code{simList}} \code{saveState} is a wrapper around \code{restartSpades} and \code{saveSimList}. You can pass arguments to the \code{...} that will be passed to \code{saveSimList}, such as \code{modules}, \code{inputs}, \code{outputs}.} + +\item{file}{An optional file that has a saved \code{simList}, e.g., from \code{saveSimList} +or \code{saveState}.} + +\item{reset}{Logical. If \code{TRUE}, then it will force \code{simInitAndSpades} to be called +even if there is saved \code{sim} available.} + +\item{ll}{A list of elements that would be passed to \code{simInit}, such as \code{modules}.} } \value{ A \code{simList} as if \code{spades} had been called on a \code{simList}. + +A \code{simList}, that has been "executed" until \code{end(sim)}, if it does not +hit an error. } \description{ This is very experimental and has not been thoroughly tested. Use with caution. diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index a8740daf..4323c674 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -164,11 +164,7 @@ the name \code{sim$._sessionInfo}. This takes about 75 milliseconds, which may b undesirable for some situations where speed is critical. If \code{FALSE}, then this is not assigned to the \code{simList}.\cr -\code{spades.switchPkgNamespaces} \tab \code{FALSE} to keep computational -overhead down. \tab Should the search path be modified -to ensure a module's required packages are listed first? -If \code{TRUE}, there should be no name conflicts among package objects, -but it is much slower, especially if the events are themselves fast. \cr +\code{spades.switchPkgNamespaces} \tab Defunct. \tab Use \code{spades.useBox} option \cr \code{spades.testMemoryLeaks} \tab \code{TRUE}. \tab There is a very easy way to create a memory leak with R and SpaDES, From 1950d0326b15a0d2d7403920083eb024fba0da91 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 27 Mar 2025 11:57:12 -0700 Subject: [PATCH 071/128] supplied Elsewhere attempts to fix circular dependencies between modules --- R/suppliedElsewhere.R | 54 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 10 deletions(-) diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index 0d4d2940..cbde855a 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -118,31 +118,65 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") # If one of the modules that has already been loaded has this object as an output, # then don't create this + curMod <- currentModule(sim) + inFutureInit <- if (any(c("i", "c") %in% forms$where)) { del <- depsEdgeList(sim, plot = FALSE) # if ("c" %in% forms$where) { - # The next line is subtle -- it must be provided by another module, previously loaded (thus in the depsEdgeList), - # but that does not need it itself. If it needed it itself, then it would have loaded it already in the simList - # which is checked in a different test of suppliedElsewhere -- i.e., "sim" + + # THIS IS THE PREVIOUS APPROACH THAT MISSED SEVERAL CASES ESPECIALLY WITH loadOrder + # outPrev <- isTRUE(depsEdgeList(sim, plot = FALSE)[!(from %in% c("_INPUT_", curMod)), ][ + # objName %in% objDeparsed][, all(from != to), by = from][V1 == TRUE]$V1) + + # This next line: + # 1. only evaluate the objects that are named in `object` + # 2. Remove within-module circular references (from != to) + # 3. Remove cases where it is coming from INPUT data dd <- del[objName %in% objDeparsed][from != to][!(from %in% c("_INPUT_")), ] d <- depends(sim) - otherModsDeps <- d@dependencies[which(!names(d@dependencies) %in% currentModule(sim))] + allModsDeps <- d@dependencies + otherModsDeps <- allModsDeps[which(!names(d@dependencies) %in% curMod)] - for (mod in otherModsDeps) { + for (mod in allModsDeps) { lo <- mod@loadOrder - if (!is.null(lo$after)) - del <- dd[from %in% lo$after] - else - del <- dd + modNam <- mod@name + #if (any(curMod %in% modNam)) { # if this module is named + if (any(dd[["from"]] %in% lo[["after"]])) { + toRm <- dd[, to %in% modNam & from %in% lo$after] + if (any(toRm)) + dd <- dd[which(toRm)] + } + + if (any(dd[["to"]] %in% lo[["before"]])) { + toRm <- dd[, from %in% modNam & to %in% lo$before] + if (any(toRm)) + dd <- dd[which(toRm)] + } + + #} + # curcularity dd[, any(from %in% to) && any(to %in% from), by = objName] + #if (!is.null(lo$after) && curMod == modNam) + # dd <- dd[from %in% lo$after] + # else + # del <- dd } # } + # test for circularity + circular <- dd[, any(from %in% to) && any(to %in% from), by = objName] + rmObjs <- circular[V1 %in% TRUE]$objName + if (length(rmObjs)) + dd <- dd[!objName %in% rmObjs] + rmSelf <- which(dd[["from"]] == curMod) + if (length(rmSelf)) + dd <- dd[-rmSelf] + del <- dd # if (any(c("i", "c") %in% forms$where)) { # The next line is subtle -- it must be provided by another module, previously loaded (thus in the depsEdgeList), # but that does not need it itself. If it needed it itself, then it would have loaded it already in the simList # which is checked in a different test of suppliedElsewhere -- i.e., "sim" # if (exists("aaaa", envir = .GlobalEnv)) browser() - out <- del[!(from %in% c("_INPUT_", currentModule(sim))), ][ + out <- del[!(from %in% c("_INPUT_", curMod)), ][ objName %in% objDeparsed] out <- out[, .(objName, noFeedback = all(from != to)), by = from][noFeedback %in% TRUE] objDeparsed %in% out$objName From f53d1645bf95beb614b0c6d1f40ae8035b873c5e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 27 Mar 2025 21:47:49 -0700 Subject: [PATCH 072/128] sim@outputs -- in .prepareOutputs -- need vectorized --- R/cache.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/cache.R b/R/cache.R index abca51c8..c32da7c7 100644 --- a/R/cache.R +++ b/R/cache.R @@ -754,12 +754,14 @@ setMethod( simPost@current <- simFromCache@current # Outputs -- there may have been outputs added by another module that should be recovered - if (exists("aaaa", envir = .GlobalEnv)) browser() if (length(currModules) > 0) { - outputsFromThisMod <- object@depends@dependencies[[currModules]]@outputObjects$objectName + outputsFromTheseMods <- lapply(currModules, function(cmod) { + object@depends@dependencies[[cmod]]@outputObjects$objectName + }) + outputsFromTheseMods <- unlist(outputsFromTheseMods) simPost@outputs <- rbindlist(list( - simPost@outputs, object@outputs[!object@outputs$objectName %in% outputsFromThisMod,]), - use.names = TRUE, fill = TRUE) + simPost@outputs, object@outputs[!object@outputs$objectName %in% outputsFromTheseMods,]), + use.names = TRUE, fill = TRUE) |> unique() } From 571bd95cd8395ab7ced5dce22f6ecc96de54dd7b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 27 Mar 2025 21:48:55 -0700 Subject: [PATCH 073/128] .robustDigest -- add algo everywhere --- R/cache.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/R/cache.R b/R/cache.R index c32da7c7..f4b35d9b 100644 --- a/R/cache.R +++ b/R/cache.R @@ -31,7 +31,7 @@ if (!isGeneric(".robustDigest")) { setMethod( ".robustDigest", signature = "simList", - definition = function(object, .objects, length, algo, quick, classOptions) { + definition = function(object, .objects, length, algo = "xxhash64", quick, classOptions) { # browser(expr = exists("._robustDigest_1")) curMod <- currentModule(object) @@ -96,7 +96,7 @@ setMethod( out <- if (length(objs) > 0) { a <- mget(objs, envir = allEnvsInSimList[[name]]) nonZero <- unlist(lapply(a, function(x) length(x) > 0)) - .robustDigest(a[nonZero], + .robustDigest(a[nonZero], algo = algo, quick = !isFALSE(quick), # can be character or TRUE --> TRUE length = length, classOptions = classOptions) # need classOptions } else { @@ -160,7 +160,7 @@ setMethod( object@inputs <- object@inputs[object@inputs$objectName %in% expectsInputs,] } if (NROW(object@inputs)) { # previous line may have removed row(s) from object@inputs, leaving potentially zero - object@inputs$file <- unlist(.robustDigest(object@inputs$file, quick = quick, length = length)) #nolint + object@inputs$file <- unlist(.robustDigest(object@inputs$file, algo = algo, quick = quick, length = length)) #nolint } } @@ -219,7 +219,7 @@ setMethod( .robustDigest(lapply(object@depends@dependencies, function(mo) { mo[[ii]][, grep("desc$", colnames(mo[[ii]]), value = TRUE, invert = TRUE)] - })) + }), algo = algo) } obj[["depends"]] <- invertList(dependsFirst) @@ -237,12 +237,13 @@ setMethod( .robustDigest(lapply(object@depends@dependencies, function(mo) { mo[otherDependsToDig] - } )) + } ), algo = algo) 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) + obj["outputs"] <- .robustDigest(object@outputs[, c("objectName", "saveTime", "file", "arguments")], + quick = TRUE, algo = algo) if (!is.null(classOptions$events)) { if (FALSE %in% classOptions$events) obj$events <- NULL } From 160d763ae0e8f2cc48c955ce034b41d5c6995450 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 27 Mar 2025 21:50:58 -0700 Subject: [PATCH 074/128] bump; redoc --- DESCRIPTION | 4 ++-- man/robustDigest.Rd | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b130bc10..5c47c56f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-02-28 -Version: 2.1.5.9012 +Date: 2025-03-27 +Version: 2.1.5.9013 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/man/robustDigest.Rd b/man/robustDigest.Rd index ca4d7af8..d1075263 100644 --- a/man/robustDigest.Rd +++ b/man/robustDigest.Rd @@ -5,7 +5,7 @@ \alias{Cache} \title{\code{.robustDigest} for \code{simList} objects} \usage{ -\S4method{.robustDigest}{simList}(object, .objects, length, algo, quick, classOptions) +\S4method{.robustDigest}{simList}(object, .objects, length, algo = "xxhash64", quick, classOptions) } \arguments{ \item{object}{an object to digest.} From f34a2fe03eb4e05c7ee597f9a82f512558c8a1b0 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 27 Mar 2025 22:05:55 -0700 Subject: [PATCH 075/128] update tests for R CMD check --- DESCRIPTION | 2 +- tests/testthat/test-simList.R | 2 +- tests/testthat/test-timeunits.R | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5c47c56f..4dd11497 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core Date: 2025-03-27 -Version: 2.1.5.9013 +Version: 2.1.5.9014 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/tests/testthat/test-simList.R b/tests/testthat/test-simList.R index ea7ed448..4482e230 100644 --- a/tests/testthat/test-simList.R +++ b/tests/testthat/test-simList.R @@ -503,7 +503,7 @@ test_that("test sped-up Caching of sequentially cached events", { ".inputObjects <- function(sim) {", " a = asPath(file.path(inputPath(sim), \"test\")) ", paste0(" if (!suppliedElsewhere(", params$.globals$stackName, "))"), - paste0(" sim[[", params$.globals$stackName, "]] <- sim[[", params$.globals$stackName, "]]"), + paste0(" sim[['", params$.globals$stackName, "']] <- sim[['", params$.globals$stackName, "']]"), "sim", "}") diff --git a/tests/testthat/test-timeunits.R b/tests/testthat/test-timeunits.R index 47c9651b..38f8f33c 100644 --- a/tests/testthat/test-timeunits.R +++ b/tests/testthat/test-timeunits.R @@ -16,8 +16,8 @@ test_that("timeunit works correctly", { expect_equal(maxTimeunit(sim = mySim), "year") # Test for numerics, or character strings that are not recognized - expect_message(timeunit(mySim) <- 1, "^unknown timeunit provided:") - expect_message(timeunit(mySim) <- "LeapYear", "^unknown timeunit provided:") + expect_warning(timeunit(mySim) <- 1, "^unknown timeunit provided:") + expect_warning(timeunit(mySim) <- "LeapYear", "^unknown timeunit provided:") # check for new unit being put into simList @@ -28,8 +28,8 @@ test_that("timeunit works correctly", { expect_equivalent(as.numeric(mySim$dfortnight(1)), 1209600) rm(dfortnight, envir = envir(mySim)) - # test that NA_real_ gets coerced to NA_character_ - timeunit(mySim) <- NA_real_ + # test that NA_real_ gets coerced to NA_character_; with a warning + expect_warning(timeunit(mySim) <- NA_real_) expect_identical(timeunit(mySim), NA_character_) # check that the minTimeunit captures one of the timestepUnits in the loaded modules From 90c17745c45b1cf2fed5faae8fca1170c328f603 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 14:27:17 -0700 Subject: [PATCH 076/128] restartSpades arg misnamed --- R/restart.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/restart.R b/R/restart.R index 3887e31d..8f61c378 100755 --- a/R/restart.R +++ b/R/restart.R @@ -496,23 +496,23 @@ restartR <- function(sim, reloadPkgs = TRUE, .First = NULL, #' or `saveState`. #' @param reset Logical. If `TRUE`, then it will force `simInitAndSpades` to be called #' even if there is saved `sim` available. -restartOrSimInitAndSpades <- function(out, file, +restartOrSimInitAndSpades <- function(ll, file, reset = getOption("spades.resetRestart")) { # there are tempdir paths - pathsOrig <- out$paths - out$paths <- sapply(out$paths, grep, invert = TRUE, value = TRUE, pattern = tempdir(), simplify = TRUE) - fn <- function(out) out - cached <- attr(reproducible::Cache(fn(out), .functionName = "restartOrSimInitAndSpades"), ".Cache")$newCache %in% FALSE + pathsOrig <- ll$paths + ll$paths <- sapply(ll$paths, grep, invert = TRUE, value = TRUE, pattern = tempdir(), simplify = TRUE) + fn <- function(ll) ll + cached <- attr(reproducible::Cache(fn(ll), .functionName = "restartOrSimInitAndSpades"), ".Cache")$newCache %in% FALSE if (isTRUE(reset)) cached <- FALSE - out$paths <- pathsOrig - hasSavedToRAMState <- !is.null(SpaDES.core:::savedSimEnv()$.sim) + ll$paths <- pathsOrig + hasSavedToRAMState <- !is.null(savedSimEnv()$.sim) hasSavedToFileState <- file.exists(file) if (!cached || !(hasSavedToFileState || hasSavedToRAMState)) { - message("out has changed; rerunning simInitAndSpades") - sim <- do.call(SpaDES.core::simInitAndSpades, out) + message("ll has changed; rerunning simInitAndSpades") + sim <- do.call(SpaDES.core::simInitAndSpades, ll) } else { - message("out has not changed; trying restartSpades") + message("ll has not changed; trying restartSpades") if (isFALSE(hasSavedToRAMState)) { sim <- SpaDES.core::restartSpades(file) } else { From 3d9d725eee13d41bf8df2d748b20b78107a43b38 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 14:44:36 -0700 Subject: [PATCH 077/128] createDESCRIPTIONandDocs updates with R CMD check --- DESCRIPTION | 4 ++-- R/createDESCRIPTIONandDocs.R | 9 ++++++--- R/suppliedElsewhere.R | 5 +++++ man/restartSpades.Rd | 6 +++--- 4 files changed, 16 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4dd11497..0e08fb47 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-03-27 -Version: 2.1.5.9014 +Date: 2025-03-31 +Version: 2.1.5.9015 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 6b215e9b..ac560f04 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -138,7 +138,8 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod whDefModule <- which(defModule) whNotDefModule <- which(!defModule) - linesWithDefModule <- gpd[grep("defineModule", gpd$text) - 1, ][, c("line1", "line2")] + defModLine <- which(grepl("defineModule", gpd$text) & gpd$token == "SYMBOL_FUNCTION_CALL") + linesWithDefModule <- gpd[defModLine - 1, ][, c("line1", "line2")] doEvent <- grepl(paste0("^doEvent.", module), aa) whDoEvent <- which(doEvent) @@ -169,6 +170,7 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod message("Building documentation") m <- packageFolderName tmpSrcForDoc <- "R/tmp.R" + checkPath(dirname(tmpSrcForDoc), create = TRUE) cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) on.exit(unlink(tmpSrcForDoc)) roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... @@ -312,7 +314,8 @@ mergeField <- function(origDESCtxt, field, dFile, fieldName = "Imports") { fieldVals <- strsplit(origDESCtxt[, fieldName], split = ",+\n")[[1]] if (length(field)) { field <- trimRedundancies(unique(c(field, fieldVals))) + cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), + sep = "\n", file = dFile, append = file.exists(dFile)) } - cat(c(paste0(fieldName, ":"), paste(" ", sort(field$packageFullName), collapse = ",\n")), - sep = "\n", file = dFile, append = TRUE) + field } diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index cbde855a..e0213ad3 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -122,6 +122,7 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") inFutureInit <- if (any(c("i", "c") %in% forms$where)) { del <- depsEdgeList(sim, plot = FALSE) + if (NROW(del)) { # if ("c" %in% forms$where) { # THIS IS THE PREVIOUS APPROACH THAT MISSED SEVERAL CASES ESPECIALLY WITH loadOrder @@ -138,6 +139,7 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") otherModsDeps <- allModsDeps[which(!names(d@dependencies) %in% curMod)] for (mod in allModsDeps) { + browser() lo <- mod@loadOrder modNam <- mod@name #if (any(curMod %in% modNam)) { # if this module is named @@ -183,6 +185,9 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") # } else { # FALSE # } + } else { + FALSE + } } else { FALSE } diff --git a/man/restartSpades.Rd b/man/restartSpades.Rd index b51f9fa5..c58e47c7 100644 --- a/man/restartSpades.Rd +++ b/man/restartSpades.Rd @@ -10,7 +10,7 @@ restartSpades(sim = NULL, module = NULL, numEvents = Inf, restart = TRUE, ...) saveState(filename, ...) -restartOrSimInitAndSpades(out, file, reset = getOption("spades.resetRestart")) +restartOrSimInitAndSpades(ll, file, reset = getOption("spades.resetRestart")) } \arguments{ \item{sim}{A \code{simList} or a filename that will load a \code{simList}, e.g., from @@ -39,13 +39,13 @@ with the module code parsed into the \code{simList}} pass arguments to the \code{...} that will be passed to \code{saveSimList}, such as \code{modules}, \code{inputs}, \code{outputs}.} +\item{ll}{A list of elements that would be passed to \code{simInit}, such as \code{modules}.} + \item{file}{An optional file that has a saved \code{simList}, e.g., from \code{saveSimList} or \code{saveState}.} \item{reset}{Logical. If \code{TRUE}, then it will force \code{simInitAndSpades} to be called even if there is saved \code{sim} available.} - -\item{ll}{A list of elements that would be passed to \code{simInit}, such as \code{modules}.} } \value{ A \code{simList} as if \code{spades} had been called on a \code{simList}. From 6f2b138125d972c72a6a47ca8d19ad4fa8d62407 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 16:58:14 -0700 Subject: [PATCH 078/128] R CMD checking; rm box from checks --- DESCRIPTION | 5 +++-- R/options.R | 2 +- R/reexports.R | 2 +- R/simulation-parseModule.R | 6 +++--- R/simulation-simInit.R | 2 +- R/suppliedElsewhere.R | 1 - man/spadesOptions.Rd | 2 +- tests/test-all.R | 6 +++--- tests/testthat/test-simulation.R | 2 +- 9 files changed, 14 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0e08fb47..fb103ca3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,7 @@ Authors@R: c( Depends: R (>= 4.2), quickPlot (>= 1.0.2), - reproducible (>= 2.1.2.9006) + reproducible (>= 2.1.2.9027) Imports: box, cli, @@ -59,6 +59,7 @@ Suggests: ggplot2, ggplotify, gitcreds, + googledrive, httr, knitr, lattice, @@ -81,7 +82,7 @@ Suggests: withr Remotes: ropensci/NLMR, - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI Additional_repositories: https://predictiveecology.r-universe.dev/ Encoding: UTF-8 Language: en-CA diff --git a/R/options.R b/R/options.R index ca65daf7..cd56b0ac 100644 --- a/R/options.R +++ b/R/options.R @@ -178,7 +178,7 @@ #' `spades.useragent` \tab `"https://github.com/PredictiveEcology/SpaDES"`. #' \tab The default user agent to use for downloading modules from GitHub. \cr #' -#' `spades.useBox` \tab TRUE +#' `spades.useBox` \tab FALSE #' \tab Whether to manage which packages are loaded using the package `box`. #' This will have as an effect that `reqdPkgs` will be strict; if a given #' module is missing a `reqdPkgs`, then the module will fail to run, with diff --git a/R/reexports.R b/R/reexports.R index 480b998a..6ff765f1 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -24,7 +24,7 @@ isSpat <- getFromNamespace("isSpat", "reproducible") layerNamesDelimiter <- getFromNamespace("layerNamesDelimiter", "reproducible") .updateTagsRepo <- getFromNamespace(".updateTagsRepo", "reproducible") .addTagsRepo <- getFromNamespace(".addTagsRepo", "reproducible") - +._prepInputsMetadata <- getFromNamespace("._prepInputsMetadata", "reproducible") makeAbsolute <- getFromNamespace("makeAbsolute", "reproducible") diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index 2b819bc8..61c7891a 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -587,10 +587,10 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = # it says, how big is the function, compared to how big is the environment that holds the function # If it is 1, it means there are only functions in that environment, no objects # length(serialize(tmpEnvir$prepare_IgnitionFit, NULL))/object.size(mget(ls(tmpEnvir), tmpEnvir)) - pkgs <- Require::extractPkgName(unlist(eval(pkgs))) - pkgs <- reqdPkgsDontLoad(pkgs) # some are explicitly not to be loaded - if (getOption("spades.useBox") && FALSE) { # TURN THIS OFF AS THERE ARE MEMORY HOGGING ISSUES WITH BOX + if (getOption("spades.useBox", FALSE) && FALSE) { # TURN THIS OFF AS THERE ARE MEMORY HOGGING ISSUES WITH BOX + pkgs <- Require::extractPkgName(unlist(eval(pkgs))) + pkgs <- reqdPkgsDontLoad(pkgs) # some are explicitly not to be loaded cm <- currentModule(tmpEnvir$sim) if (length(cm)) if (!cm %in% unlist(.coreModules())) { diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 92c314b9..ebc20329 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1379,7 +1379,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (runFnCallAsExpr) { pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) pkgs <- c(pkgs, "stats") - if (getOption("spades.useBox") && FALSE) + if (getOption("spades.useBox", FALSE) && FALSE) do.call(box::use, lapply(pkgs, as.name)) debugForCache <- debugToVerbose(debug) sim <- Cache(.inputObjects, sim, diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index e0213ad3..4417dc6f 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -139,7 +139,6 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") otherModsDeps <- allModsDeps[which(!names(d@dependencies) %in% curMod)] for (mod in allModsDeps) { - browser() lo <- mod@loadOrder modNam <- mod@name #if (any(curMod %in% modNam)) { # if this module is named diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index 4323c674..37b51070 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -180,7 +180,7 @@ point number comparisons. \cr \code{spades.useragent} \tab \code{"https://github.com/PredictiveEcology/SpaDES"}. \tab The default user agent to use for downloading modules from GitHub. \cr -\code{spades.useBox} \tab TRUE +\code{spades.useBox} \tab FALSE \tab Whether to manage which packages are loaded using the package \code{box}. This will have as an effect that \code{reqdPkgs} will be strict; if a given module is missing a \code{reqdPkgs}, then the module will fail to run, with diff --git a/tests/test-all.R b/tests/test-all.R index 126975bd..b4a10dd2 100644 --- a/tests/test-all.R +++ b/tests/test-all.R @@ -3,12 +3,12 @@ withr::local_options(spades.debug = FALSE) ## run all tests using different combinations of env vars if (nzchar(Sys.getenv("NOT_CRAN")) && as.logical(Sys.getenv("NOT_CRAN"))) { - withr::local_options(spades.useBox = TRUE) + withr::local_options(spades.useBox = FALSE) # Sys.setenv(R_REPRODUCIBLE_USE_DBI = "false") test_check("SpaDES.core") - withr::local_options(spades.useBox = FALSE) - test_check("SpaDES.core") + # withr::local_options(spades.useBox = FALSE) # box is not appropriate if Caching is a thing + # test_check("SpaDES.core") } else { test_check("SpaDES.core") } diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index 96f8eca6..4f51fb78 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -1054,7 +1054,7 @@ test_that("debug using logging", { }) test_that("options('reproducible.reqdPkgsDontLoad", { - dontLoad <- "ggplot2" # can't be sp, raster because already loaded + dontLoad <- "logging" # ggplot2 has many rev deps; can't be sp, raster because already loaded skip_if_not_installed(dontLoad) unloadNamespace(dontLoad) From e745cd4ea5e372d3e77e06d14b9c1be81ec7181a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 17:01:35 -0700 Subject: [PATCH 079/128] other useBox --> FALSE --- R/simulation-simInit.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index ebc20329..12d3427a 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1601,7 +1601,7 @@ loadPkgs <- function(reqdPkgs) { pkgsDontLoad <- getOption("spades.reqdPkgsDontLoad", NULL) allPkgs <- reqdPkgsDontLoad(allPkgs, pkgsDontLoad) - if (getOption("spades.useRequire") && !getOption("spades.useBox")) { + if (getOption("spades.useRequire") && !getOption("spades.useBox", FALSE)) { getCRANrepos(ind = 1) # running this first is neutral if it is set Require(allPkgs, require = TRUE, standAlone = FALSE, upgrade = FALSE) if (!is.null(pkgsDontLoad)) { @@ -1611,7 +1611,7 @@ loadPkgs <- function(reqdPkgs) { } # RequireWithHandling(allPkgs, standAlone = FALSE, upgrade = FALSE) } else { - if (!getOption("spades.useBox")) { + if (!getOption("spades.useBox", FALSE)) { allPkgs <- unique(Require::extractPkgName(allPkgs)) loadedPkgs <- lapply(allPkgs, base::require, character.only = TRUE) } From 3fab6201b6760c6f3019c3cd34b02fbdf17a5b28 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 17:04:26 -0700 Subject: [PATCH 080/128] rm temp dir --- DESCRIPTION | 2 +- R/createDESCRIPTIONandDocs.R | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fb103ca3..248c87c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core Date: 2025-03-31 -Version: 2.1.5.9015 +Version: 2.1.5.9016 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index ac560f04..6a1e123b 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -170,7 +170,9 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod message("Building documentation") m <- packageFolderName tmpSrcForDoc <- "R/tmp.R" - checkPath(dirname(tmpSrcForDoc), create = TRUE) + theDir <- dirname(tmpSrcForDoc) + checkPath(theDir, create = TRUE) + on.exit(unlink(theDir, recursive = TRUE)) cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) on.exit(unlink(tmpSrcForDoc)) roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... From 81674a5182557aba9a846e8f5e2606bcb547042a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 17:48:59 -0700 Subject: [PATCH 081/128] use reproducible@AI & fix on.exit with createDESCRIPTIONandDocs --- .github/workflows/R-CMD-check.yaml | 2 +- .github/workflows/pkgdown.yaml | 2 +- .github/workflows/revdeps.yaml | 2 +- .github/workflows/test-coverage.yaml | 2 +- .github/workflows/update-citation-cff.yaml | 2 +- DESCRIPTION | 2 +- R/createDESCRIPTIONandDocs.R | 4 ++-- 7 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 80a82b3d..02db889a 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -57,7 +57,7 @@ jobs: with: extra-packages: | any::rcmdcheck - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI fastshp=?ignore NLMR=?ignore needs: check diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 3460799f..a6bdc026 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -36,7 +36,7 @@ jobs: extra-packages: | any::pkgdown local::. - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI fastshp=?ignore NLMR=?ignore needs: website diff --git a/.github/workflows/revdeps.yaml b/.github/workflows/revdeps.yaml index 8eeeb4f3..50df0b3b 100644 --- a/.github/workflows/revdeps.yaml +++ b/.github/workflows/revdeps.yaml @@ -48,7 +48,7 @@ jobs: with: extra-packages: | any::rcmdcheck - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI fastshp=?ignore NLMR=?ignore needs: check diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index a918aad3..060935d5 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -34,7 +34,7 @@ jobs: with: extra-packages: | any::covr - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI fastshp=?ignore NLMR=?ignore diff --git a/.github/workflows/update-citation-cff.yaml b/.github/workflows/update-citation-cff.yaml index 15c4b209..72da6f92 100644 --- a/.github/workflows/update-citation-cff.yaml +++ b/.github/workflows/update-citation-cff.yaml @@ -39,7 +39,7 @@ jobs: extra-packages: | any::cffr any::V8 - PredictiveEcology/reproducible@development + PredictiveEcology/reproducible@AI fastshp=?ignore NLMR=?ignore diff --git a/DESCRIPTION b/DESCRIPTION index 248c87c5..6ca2b6e7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,7 +15,7 @@ URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core Date: 2025-03-31 -Version: 2.1.5.9016 +Version: 2.1.5.9017 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/createDESCRIPTIONandDocs.R b/R/createDESCRIPTIONandDocs.R index 6a1e123b..a4fb5458 100644 --- a/R/createDESCRIPTIONandDocs.R +++ b/R/createDESCRIPTIONandDocs.R @@ -172,9 +172,9 @@ createDESCRIPTIONandDocs <- function(module = NULL, path = getOption("spades.mod tmpSrcForDoc <- "R/tmp.R" theDir <- dirname(tmpSrcForDoc) checkPath(theDir, create = TRUE) - on.exit(unlink(theDir, recursive = TRUE)) + on.exit(unlink(theDir, recursive = TRUE), add = TRUE) cat(rlaa[-(linesWithDefModule[[1]]:linesWithDefModule[[2]])], sep = "\n", file = tmpSrcForDoc) - on.exit(unlink(tmpSrcForDoc)) + on.exit(unlink(tmpSrcForDoc), add = TRUE) roxygen2::roxygenise(m, roclets = NULL) # This builds documentation, but also exports all functions ... pkgload::dev_topic_index_reset(m) pkgload::unload(.moduleNameNoUnderscore(basename2(m))) # so, unload here before reloading without exporting From ae95eaf0baccb5e7ee0952b843d50054fca3e36d Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 18:02:28 -0700 Subject: [PATCH 082/128] minor --- R/simulation-simInit.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 12d3427a..e601f471 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1343,7 +1343,6 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out ## This next line will make the Caching sensitive to userSuppliedObjs ## (which are already in the simList) or objects supplied by another module - #browser() inSimList <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = c("sim", "i", "c")) # inCyclic <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = "c") if (any(inSimList)) { @@ -1382,6 +1381,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (getOption("spades.useBox", FALSE) && FALSE) do.call(box::use, lapply(pkgs, as.name)) debugForCache <- debugToVerbose(debug) + # if (identical(mBase, "mpbRedTopSpread")) browser() sim <- Cache(.inputObjects, sim, .objects = objectsToEvaluateForCaching, notOlderThan = notOlderThan, From 7c7e63529648c401e30d5967678e507848eab60e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 31 Mar 2025 18:06:55 -0700 Subject: [PATCH 083/128] minor --- R/simulation-spades.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 17b0b336..5fb9dcc5 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -226,6 +226,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, } } + # browser(expr = exists("._doEvent_2")) showSimilar <- if (is.null(sim@params[[curModuleName]][[".showSimilar"]]) || isTRUE(is.na(sim@params[[curModuleName]][[".showSimilar"]]))) { @@ -1380,6 +1381,10 @@ setMethod( fnCallAsExpr <- if (cacheIt) { # means that a module or event is to be cached modCall <- get(moduleCall, envir = fnEnv) + if (any(cur[["moduleName"]] %in% getOption("spades.debugModule"))) { + browser() + } + # if (isTRUE(cur$moduleName %in% "randomLandscapes")) browser() expression(Cache(FUN = modCall, sim = sim, eventTime = cur[["eventTime"]], eventType = cur[["eventType"]], From abc78d5ed859add3f316d7ac2cd8a9bb9bacf60f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 1 Apr 2025 08:51:27 -0700 Subject: [PATCH 084/128] rm imports on box --- DESCRIPTION | 1 - R/options.R | 8 +++++--- R/simulation-simInit.R | 4 ++-- man/spadesOptions.Rd | 6 ++++-- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6ca2b6e7..366dc313 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,7 +33,6 @@ Depends: quickPlot (>= 1.0.2), reproducible (>= 2.1.2.9027) Imports: - box, cli, data.table (>= 1.11.0), fs, diff --git a/R/options.R b/R/options.R index cd56b0ac..187af75e 100644 --- a/R/options.R +++ b/R/options.R @@ -162,7 +162,7 @@ #' undesirable for some situations where speed is critical. If `FALSE`, then #' this is not assigned to the `simList`.\cr #' -#' `spades.switchPkgNamespaces` \tab Defunct. \tab Use `spades.useBox` option \cr +#' `spades.switchPkgNamespaces` \tab Defunct. #' #' `spades.testMemoryLeaks` \tab `TRUE`. #' \tab There is a very easy way to create a memory leak with R and SpaDES, @@ -179,7 +179,9 @@ #' \tab The default user agent to use for downloading modules from GitHub. \cr #' #' `spades.useBox` \tab FALSE -#' \tab Whether to manage which packages are loaded using the package `box`. +#' \tab Unimplemented while memory problems with `box` are resolved. +#' When it is turned on, this option determines +#' whether to manage which packages are loaded using the package `box`. #' This will have as an effect that `reqdPkgs` will be strict; if a given #' module is missing a `reqdPkgs`, then the module will fail to run, with #' an error saying the package/function doesn't exist. Without `box`, @@ -242,7 +244,7 @@ spadesOptions <- function() { spades.testMemoryLeaks = TRUE, spades.tolerance = .Machine$double.eps ^ 0.5, spades.useragent = "https://github.com/PredictiveEcology/SpaDES", - spades.useBox = FALSE, + # spades.useBox = FALSE, spades.useRequire = !tolower(Sys.getenv("SPADES_USE_REQUIRE")) %in% "false", spades.keepCompleted = TRUE ) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index e601f471..9959cbd4 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1378,8 +1378,8 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (runFnCallAsExpr) { pkgs <- Require::extractPkgName(unlist(moduleMetadata(sim, currentModule(sim))$reqdPkgs)) pkgs <- c(pkgs, "stats") - if (getOption("spades.useBox", FALSE) && FALSE) - do.call(box::use, lapply(pkgs, as.name)) + # if (getOption("spades.useBox", FALSE) && FALSE) + # do.call(box::use, lapply(pkgs, as.name)) debugForCache <- debugToVerbose(debug) # if (identical(mBase, "mpbRedTopSpread")) browser() sim <- Cache(.inputObjects, sim, diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index 37b51070..f9004063 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -164,7 +164,7 @@ the name \code{sim$._sessionInfo}. This takes about 75 milliseconds, which may b undesirable for some situations where speed is critical. If \code{FALSE}, then this is not assigned to the \code{simList}.\cr -\code{spades.switchPkgNamespaces} \tab Defunct. \tab Use \code{spades.useBox} option \cr +\code{spades.switchPkgNamespaces} \tab Defunct. \code{spades.testMemoryLeaks} \tab \code{TRUE}. \tab There is a very easy way to create a memory leak with R and SpaDES, @@ -181,7 +181,9 @@ point number comparisons. \cr \tab The default user agent to use for downloading modules from GitHub. \cr \code{spades.useBox} \tab FALSE -\tab Whether to manage which packages are loaded using the package \code{box}. +\tab Unimplemented while memory problems with \code{box} are resolved. +When it is turned on, this option determines +whether to manage which packages are loaded using the package \code{box}. This will have as an effect that \code{reqdPkgs} will be strict; if a given module is missing a \code{reqdPkgs}, then the module will fail to run, with an error saying the package/function doesn't exist. Without \code{box}, From 5759cdc46a738054b5caed52cdac72849e42f9d6 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 1 Apr 2025 08:52:00 -0700 Subject: [PATCH 085/128] redoc --- DESCRIPTION | 4 +- vignettes/i-introduction.R | 102 +++++----- vignettes/ii-modules.R | 176 +++++++++--------- .../figure-html/module-object-diagrams-2.png | Bin 17188 -> 18468 bytes .../figure-html/module-object-diagrams-3.png | Bin 22176 -> 304 bytes .../header-attrs-2.29/header-attrs.js | 12 ++ vignettes/iii-cache.R | 16 +- vignettes/iv-advanced.R | 22 +-- 8 files changed, 172 insertions(+), 160 deletions(-) create mode 100644 vignettes/ii-modules_files/header-attrs-2.29/header-attrs.js diff --git a/DESCRIPTION b/DESCRIPTION index 366dc313..eb86376f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-03-31 -Version: 2.1.5.9017 +Date: 2025-04-01 +Version: 2.1.5.9018 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/vignettes/i-introduction.R b/vignettes/i-introduction.R index fba00b4d..8b4d8ed4 100644 --- a/vignettes/i-introduction.R +++ b/vignettes/i-introduction.R @@ -9,63 +9,63 @@ options(spades.moduleCodeChecks = FALSE, spades.useRequire = FALSE) ## ----SpaDES-demo, eval=FALSE, echo=TRUE--------------------------------------- -# ## NOTE: Suggested packages SpaDES.tools and NLMR packages must be installed -# #install.packages("SpaDES.taols") -# #install.packages("NLMR", repos = "https://predictiveecology.r-universe.dev/") -# -# knitr::opts_chunk$set(eval = requireNamespace("SpaDES.tools") && !requireNamespace("NLMR")) -# -# library(SpaDES.core) -# -# demoSim <- suppressMessages(simInit( -# times = list(start = 0, end = 100), -# modules = "SpaDES_sampleModules", -# params = list( -# .globals = list(burnStats = "nPixelsBurned"), -# randomLandscapes = list( -# nx = 1e2, ny = 1e2, .saveObjects = "landscape", -# .plotInitialTime = NA, .plotInterval = NA, inRAM = TRUE -# ), -# caribouMovement = list( -# N = 1e2, .saveObjects = "caribou", -# .plotInitialTime = 1, .plotInterval = 1, moveInterval = 1 -# ), -# fireSpread = list( -# nFires = 1e1, spreadprob = 0.235, persistprob = 0, its = 1e6, -# returnInterval = 10, startTime = 0, -# .plotInitialTime = 0, .plotInterval = 10 -# ) -# ), -# path = list(modulePath = getSampleModules(tempdir())) -# )) -# spades(demoSim) +# ## NOTE: Suggested packages SpaDES.tools and NLMR packages must be installed +# #install.packages("SpaDES.taols") +# #install.packages("NLMR", repos = "https://predictiveecology.r-universe.dev/") +# +# knitr::opts_chunk$set(eval = requireNamespace("SpaDES.tools") && !requireNamespace("NLMR")) +# +# library(SpaDES.core) +# +# demoSim <- suppressMessages(simInit( +# times = list(start = 0, end = 100), +# modules = "SpaDES_sampleModules", +# params = list( +# .globals = list(burnStats = "nPixelsBurned"), +# randomLandscapes = list( +# nx = 1e2, ny = 1e2, .saveObjects = "landscape", +# .plotInitialTime = NA, .plotInterval = NA, inRAM = TRUE +# ), +# caribouMovement = list( +# N = 1e2, .saveObjects = "caribou", +# .plotInitialTime = 1, .plotInterval = 1, moveInterval = 1 +# ), +# fireSpread = list( +# nFires = 1e1, spreadprob = 0.235, persistprob = 0, its = 1e6, +# returnInterval = 10, startTime = 0, +# .plotInitialTime = 0, .plotInterval = 10 +# ) +# ), +# path = list(modulePath = getSampleModules(tempdir())) +# )) +# spades(demoSim) ## ----SpaDES-modules, eval=FALSE, echo=TRUE------------------------------------ -# downloadModule(name = "moduleName") +# downloadModule(name = "moduleName") ## ----view-sim, eval=FALSE, echo=TRUE------------------------------------------ -# # full simulation details: -# # simList object info + simulation data -# mySim -# -# # less detail: -# # simList object isn't shown; object details are -# ls.str(mySim) -# -# # least detail: -# # simList object isn't shown; object names only -# ls(mySim) +# # full simulation details: +# # simList object info + simulation data +# mySim +# +# # less detail: +# # simList object isn't shown; object details are +# ls.str(mySim) +# +# # least detail: +# # simList object isn't shown; object names only +# ls(mySim) ## ----view-dependencies, eval=FALSE, echo=TRUE--------------------------------- -# library(igraph) -# library(DiagrammeR) -# depsEdgeList(mySim, FALSE) # data.frame of all object dependencies -# moduleDiagram(mySim) # plots simplified module (object) dependency graph -# objectDiagram(mySim) # plots object dependency diagram +# library(igraph) +# library(DiagrammeR) +# depsEdgeList(mySim, FALSE) # data.frame of all object dependencies +# moduleDiagram(mySim) # plots simplified module (object) dependency graph +# objectDiagram(mySim) # plots object dependency diagram ## ----view-event-sequences, eval=FALSE, echo=TRUE------------------------------ -# options(spades.nCompleted = 50) # default: store 1000 events in the completed event list -# mySim <- simInit(...) # initialize a simulation using valid parameters -# mySim <- spades(mySim) # run the simulation, returning the completed sim object -# eventDiagram(mySim) # visualize the sequence of events for all modules +# options(spades.nCompleted = 50) # default: store 1000 events in the completed event list +# mySim <- simInit(...) # initialize a simulation using valid parameters +# mySim <- spades(mySim) # run the simulation, returning the completed sim object +# eventDiagram(mySim) # visualize the sequence of events for all modules diff --git a/vignettes/ii-modules.R b/vignettes/ii-modules.R index 66115183..f5165d5a 100644 --- a/vignettes/ii-modules.R +++ b/vignettes/ii-modules.R @@ -45,16 +45,16 @@ mySim <- simInit(times = times, params = parameters, modules = modules, objects = objects, paths = paths) ## ----accessing-params, eval=FALSE, echo=TRUE---------------------------------- -# ## Access parameters -# P(mySim) # shows all parameters -# P(mySim, module = "caribouMovement") # only parameters in caribouMovement module -# P(mySim)$caribouMovement # same -# P(mySim)$caribouMovement$N # Only one parameter -# -# ## If used within the module source code, then module name can be omitted: -# ## This will return NULL here, but will return the actual value if used -# ## in a module -# P(mySim)$N # Only one parameter if used within a module +# ## Access parameters +# P(mySim) # shows all parameters +# P(mySim, module = "caribouMovement") # only parameters in caribouMovement module +# P(mySim)$caribouMovement # same +# P(mySim)$caribouMovement$N # Only one parameter +# +# ## If used within the module source code, then module name can be omitted: +# ## This will return NULL here, but will return the actual value if used +# ## in a module +# P(mySim)$N # Only one parameter if used within a module ## ----event-types, echo=FALSE, results="asis"---------------------------------- cat(c( @@ -107,25 +107,25 @@ unlink(normalizePath(ftmp)) eventDiagram(mySim, "0000-06-01", n = 200, width = 720) ## ----checksums, eval=FALSE---------------------------------------------------- -# ## 1. specify your module here -# moduleName <- "my_module" -# -# ## 2. use a temp dir to ensure all modules get fresh copies of the data -# tmpdir <- file.path(tempdir(), "SpaDES_modules") -# -# ## 3. download your module's data to the temp dir -# downloadData(moduleName, tmpdir) -# -# ## 4. initialize a dummy simulation to ensure any 'data prep' steps in the .inputObjects section are run -# simInit(modules = moduleName) -# -# ## 5. recalculate your checksums and overwrite the file -# checksums(moduleName, tmpdir, write = TRUE) -# -# ## 6. copy the new checksums file to your working module directory (the one not in the temp dir) -# file.copy(from = file.path(tmpdir, moduleName, 'data', 'CHECKSUMS.txt'), -# to = file.path('path/to/my/moduleDir', moduleName, 'data', 'CHECKSUMS.txt'), -# overwrite = TRUE) +# ## 1. specify your module here +# moduleName <- "my_module" +# +# ## 2. use a temp dir to ensure all modules get fresh copies of the data +# tmpdir <- file.path(tempdir(), "SpaDES_modules") +# +# ## 3. download your module's data to the temp dir +# downloadData(moduleName, tmpdir) +# +# ## 4. initialize a dummy simulation to ensure any 'data prep' steps in the .inputObjects section are run +# simInit(modules = moduleName) +# +# ## 5. recalculate your checksums and overwrite the file +# checksums(moduleName, tmpdir, write = TRUE) +# +# ## 6. copy the new checksums file to your working module directory (the one not in the temp dir) +# file.copy(from = file.path(tmpdir, moduleName, 'data', 'CHECKSUMS.txt'), +# to = file.path('path/to/my/moduleDir', moduleName, 'data', 'CHECKSUMS.txt'), +# overwrite = TRUE) ## ----module-object-diagrams, echo=TRUE, message=FALSE, fig.width=7------------ ## NOTE: Suggested packages SpaDES.tools and NLMR packages must be installed @@ -225,79 +225,79 @@ dev.off() unlink(normalizePath(ftmp)) ## ----save-events, echo=TRUE, eval=FALSE, message=FALSE------------------------ -# ### WITHIN A MODULE: -# -# # schedule a recurring save event -# nextSave <- time(mySim) + params(mySim)$randomLandscapes$.saveInterval -# sim <- scheduleEvent(mySim, nextSave, "randomLandscapes", "save") +# ### WITHIN A MODULE: +# +# # schedule a recurring save event +# nextSave <- time(mySim) + params(mySim)$randomLandscapes$.saveInterval +# sim <- scheduleEvent(mySim, nextSave, "randomLandscapes", "save") ## ----plotting, echo=TRUE, eval=FALSE, message=FALSE--------------------------- -# # initialize a new simulation, setting the load and save parameters -# mySim <- simInit(times = list(start = 0, end = 5), -# params = list( -# .globals = list(stackName = "landscape"), -# randomLandscapes = list(.plotInitialTime = 0, .plotInterval = 1) -# ), -# modules = list("randomLandscapes"), -# paths = list(modulePath = getSampleModules(tempdir())) -# ) -# -# # retrieve the plotting params from the simulation object -# params(mySim)$randomLandscapes$.plotInitialTime -# params(mySim)$randomLandscapes$.plotInterval +# # initialize a new simulation, setting the load and save parameters +# mySim <- simInit(times = list(start = 0, end = 5), +# params = list( +# .globals = list(stackName = "landscape"), +# randomLandscapes = list(.plotInitialTime = 0, .plotInterval = 1) +# ), +# modules = list("randomLandscapes"), +# paths = list(modulePath = getSampleModules(tempdir())) +# ) +# +# # retrieve the plotting params from the simulation object +# params(mySim)$randomLandscapes$.plotInitialTime +# params(mySim)$randomLandscapes$.plotInterval ## ----plot-events, echo=TRUE, eval=FALSE, message=FALSE------------------------ -# ### WITHIN A MODULE: -# -# # schedule a recurring plot event -# nextPlot <- time(mySim) + params(mySim)$randomLandscapes$.plotInterval -# mySim <- scheduleEvent(mySim, nextPlot, "randomLandscapes", "save") +# ### WITHIN A MODULE: +# +# # schedule a recurring plot event +# nextPlot <- time(mySim) + params(mySim)$randomLandscapes$.plotInterval +# mySim <- scheduleEvent(mySim, nextPlot, "randomLandscapes", "save") ## ----caribouMovement, echo=TRUE, eval=FALSE----------------------------------- -# openModules(getSampleModules(tempdir()), "moduleName") +# openModules(getSampleModules(tempdir()), "moduleName") ## ----download-module, echo=TRUE, eval=FALSE----------------------------------- -# downloadModule("moduleName") +# downloadModule("moduleName") ## ----create-new-module, eval=FALSE, echo=TRUE, message=FALSE------------------ -# # create a new module called "randomLandscape" in the "custom-modules" subdirectory -# # and open the resulting file immediately for editing. -# newModule(name = "randomLandscapes", path = "custom-modules", open = TRUE) +# # create a new module called "randomLandscape" in the "custom-modules" subdirectory +# # and open the resulting file immediately for editing. +# newModule(name = "randomLandscapes", path = "custom-modules", open = TRUE) ## ----module-group-init, eval=FALSE-------------------------------------------- -# library(DiagrammeR) -# library(SpaDES.core) -# -# outputDir <- file.path(tempdir(), "simOutputs") -# times <- list(start = 0.0, end = 20.0) -# parameters <- list( -# .globals = list(stackName = "landscape", burnStats = "nPixelsBurned"), -# .progress = list(NA), -# randomLandscapes = list(nx = 100L, ny = 100L, inRAM = TRUE), -# fireSpread = list( -# nFires = 10L, spreadprob = 0.225, its = 1e6, persistprob = 0, -# returnInterval = 10, startTime = 0, -# .plotInitialTime = 0, .plotInterval = 10 -# ), -# caribouMovement = list( -# N = 100L, moveInterval = 1, torus = TRUE, -# .plotInitialTime = 1, .plotInterval = 1 -# ) -# ) -# modules <- list("SpaDES_sampleModules") -# objects <- list() -# paths <- list( -# modulePath = getSampleModules(tempdir()), -# outputPath = outputDir -# ) -# -# mySim <- simInit(times = times, params = parameters, modules = modules, -# objects = objects, paths = paths) -# -# modules(mySim) # note the child modules are initialized +# library(DiagrammeR) +# library(SpaDES.core) +# +# outputDir <- file.path(tempdir(), "simOutputs") +# times <- list(start = 0.0, end = 20.0) +# parameters <- list( +# .globals = list(stackName = "landscape", burnStats = "nPixelsBurned"), +# .progress = list(NA), +# randomLandscapes = list(nx = 100L, ny = 100L, inRAM = TRUE), +# fireSpread = list( +# nFires = 10L, spreadprob = 0.225, its = 1e6, persistprob = 0, +# returnInterval = 10, startTime = 0, +# .plotInitialTime = 0, .plotInterval = 10 +# ), +# caribouMovement = list( +# N = 100L, moveInterval = 1, torus = TRUE, +# .plotInitialTime = 1, .plotInterval = 1 +# ) +# ) +# modules <- list("SpaDES_sampleModules") +# objects <- list() +# paths <- list( +# modulePath = getSampleModules(tempdir()), +# outputPath = outputDir +# ) +# +# mySim <- simInit(times = times, params = parameters, modules = modules, +# objects = objects, paths = paths) +# +# modules(mySim) # note the child modules are initialized ## ----module-group-dl, eval=FALSE---------------------------------------------- -# downloadModule("SpaDES_sampleModules") +# downloadModule("SpaDES_sampleModules") ## ----cleanup, echo=FALSE------------------------------------------------------ unlink(outputDir, recursive = TRUE) diff --git a/vignettes/ii-modules_files/figure-html/module-object-diagrams-2.png b/vignettes/ii-modules_files/figure-html/module-object-diagrams-2.png index c067018e0c5a7093c7b38c56c759094ee0510169..c371485002f2a272a79e8bc8ad2b4af6376b6f94 100644 GIT binary patch literal 18468 zcmeEu^;aBC(Cz@igA*WVfZ!0^77c{p?j9t#yGziZ!2`h^7I$|^aCcZFxVtXg&HJ72 z{&fF@+vn_=b7rP{x~prdo_eZgzbh$7VxSSD0RVs@E%iwS0N}F$0PYxjVFz_$t|rZ$(wae$kHgNxbE|#EvF;R{>-Q(-8mE6-dV!FzmJYmITJ>o z&BoH5L#cuRF%-&RL3H10rT}a)l$=W}1ait?>G!I1As~5e*R2!wzs+NvIJcwDfO7ScAJOKt+ZRLZjZ#F<3|BpajeZ47WF&z(E(Ay z;f4=rzqVX^T#uV+C@RY;&ESAfHKv0QwSL)fg`$K%rd-jsfhhV;XXCgzc$*+=KZupc z`Jv6)MJed!6g*x~SXbxL8;W6TYis_jv71TbKbF;bl5^VnVQVXFA|wPZ_5A@$B8b z%<{d_&N-X$o|u_&Ia~i2*}wU4UItH2>C$b~l^4k%BJxu7b$HOwl?*86e+S^_=%%+t zzD;1>Li=F;j$}sc%Io9DH-@;959N}siD-4Nf|biw#NYr*m)Zp0iPSEU-U!7t!zKqK z505+PxoRzDL`1~s=;#x4_H~>VE|__6&p))do+{wx@As;YK1aQL%k4bTmfF!F_rkq6 z*H#MAoZn3%UUFroeiJf)9F_UT|5_`=o7btL#KU}+xmZ15ZffLLqEhWwjDXa_a`djuUt;$}v ze7kl<#ySAaFhk~<*w$DdBdUlfT5bgnJN;_fG6_9;2fu$rd^6kuX0oQGDo}cxOUgm* z)+5CV2UI0Tbe6gwA6Tgi(5EIUeV5lDVq4=c_gby&?|jnMowQhI_}Rr~v_m9ax48hW z2%sz9#)7CgBodxql$MRmwO~OQ^_n5;*yxEJHNjEE_l*PQuUf2rA3u(l_8;2XN-zVK z`VC)Ya(t2{FDLwIs?X~rYFwBhRJeo`{c?(* zZ|r26!)s#QnIFqi^y*R?NaJ-b*;}4Evw7mV9vCm>^C|;mAwioQUbo+kwl-gP?~*67$xYGJ#4_C`n&LR=W(_OvbVQQp2tcQ-6O6r%sI$S*7#YY~Gp!{JC_kLlfKMad7u3^@T{MvH}x z)f2DTsfCU_oSzONwlB1}!4u8h0g?b9I%0hSwSArkA)n%yvKpJ@m+P7c9i50j~Usy^`0<5{gsfzMnzLn&6#U4sGcbk#wvJ4D?QH-t&Mka-q+JB$vCO}v z;AY~eG!#~UJvH#2Q@cI1uJBS77m)ok7)l#y1OWywUBGlh5kqH{iwjo5RXJO8Q9#Ed zkJX`5j8iZ{zCKw+E*wzz>!$Ne%e56R*eGx@0h&kkD#lEIG3Fs?dmxD7#A6n;ku><^ zUGJ<#;_sETo!F6J7b8vf-fgbY=D9Stc+}wee5^==UnlK8s8TV5P3Gk5)Gk!3?YdY# z%kbi=aq-t_$}~U_Sx{bHzBixo;?>ZefoK#!?;Om=_`}TwG=!ytMx2f~3^HhZ?Bp|~ zFZ^&h)&2=J5?mL#F#%}#fi_UV6y8o5w#t({~u(NLekDHaw z$ICCe7t+G#8Kie($BYGH>#F*5+q=8R$G&!*?7`7D5y^gZxc0-aBygUBwxG@;?l116-=>k0VQAFaK}1H2ibjtG?Ni_ zDBirUbcGP1&o`zOh01y*3$)(YvRBu!+3IBfAYNa(d|gU+K_R5waxaB^Uickso1i9)R=00ZL=A_xWe;EjkXwmfHe}QW2KFY5}lyKU~ zxmjCpXnkPwn#4*?g{ugm)GleG+a;V8U||`p`9mSsZ2fKFx+nbmkkF!TSsACh_+-UK zT}S(>aW!_r_EsZkiT~`+nZZ+lro}kxBj{$`{aBUuKJ>bcGIVHc4AW>iWnwve zRRgl`{gQUL_KR`90{Qm$pntxwQjvWF7b6EDrYnnEmF%#{AMZSs$BqeY{r33j2CF)dd0LnqOX$Sbdf{bTfQTL_-@AfbJ|-_q|}@Zq{*p}jBVE1<{ZY3J6uL)l>9?~y3G?F z#Ik;kByl?AmwA((#Jn++x_<(%N#Bsd;qiAv8`zr zQHGozTZaMg7PtIrn*k2<(TwryB%p8po7}oGMFtSj+6Lavh`uW`*>(Gsrzs-9_&537 zo>b8t$j+-EOJo7wxn(S~3pVhKs+OqX;NX;$luQ>Xjt>nnGBeLua3PSX2T!E_Gk(d* zqx_igay!@OlfESNh_xc^c?H)U2bIS9ELSe3E3y>w_kVk%O43|86CT={88 zIcfH|Bs-K#e>iRh`zj(5-QR(sp7;*xWZT4mhOW!R=YWe0QvOd#wt>_rAP=@;`F@P@4A)Y3{J1QNpgd7tpHZIv~{9{bqq-cwbKd%jV8j|6}`ieoiT z3F(JE!UZVNYSIUbQObXGtzK0S73SC+qJ)V7=i|qZPM){#d*DCnaEQZMfR8iMb-Si} zzB`LO%0VTi?~BqI0G}EnQj&5WOyEnv@>&!Z^IsQ5npApq6#szjnpa5_t5YL7 zGa016Su$)%0Wwl1l59O0Y+|NDH6qX;^U`ZLE?@zxk=ZLd z$wa$?L_!%zEQm$`a!p)cfdmA8g)hK-#Du0@gAO8>{G~_Rv+Baqv0L(2GR(+s1)wX( zlAdqDjGd^ZrR6=Yw3gOFo#phaZ~iA=#DhOj!c1@Yq8$~0Z^*GOTGwH{jOEj|Kej7_ zWsL%t?cvkOCZVRccddy`yFZi(Ei?&eREpAaX>o2>hWF|!^pP3CQvreoh|5W{!}U>ho|Qi{KLK5HWgo1B9lw^BK?PkU%`J*%Vdtju zN9{r9UJ5x0W@Q@Iwt4*{aM-%jIT<9bq=SyI7-)+R0Dd*cA->y*upNF@LnjK|xJ>mT zgL~I!l=R1^Cn!jradv;CItUx&3tK*Yh?F#(!<+)Q`%o)SxkzQ!y^<$#xQhMg)2)yr z-gIKANs4a%dEUcrN1*cvp@QwKQ}&Vj>K|8~I#PgIt(gAHD-H%kjoi~Zob_8Q<@Tik zI5v)r65Y__vP-q`2BY{Mjvg7!x%!jUuN2&onyn?(Aq9U;dXVk1koh7HCgV2pLP;w= zaP8V2G;uTi7zQsxKGRG5?kic{)x$SrE&z(dL+}V$e`KAd^qrX^)cdDn$h=EY2GoXB zFXse{LCOLs{b%aWKEDiD=QSAibk_5$^UMw6=32iMP8GP9k8Zzr#H(nx8mU%rOB)}C z3-1#7z+=}%O9I1HJ>F+17XF=y*l6Lt{tA+vyE$Y0eEBVUIuH~9W1V|>bvj8; zLm|&CUh0ZJ2h#2UkSv5X9pPMW+iwe1#BDlA*APN>32?6yL5$+yh{+8AkK0aP8_t(7 zfGp@l|7@xW`wFi^H5$|oL5kYeneKD=tf327mGLEML}dJOgS=$hVS& zhGQk;D#|emcy{AlqlsfwJ@uyw94+0i+q3=KmQj0& zFOGCh|87*C=M=m0N5_kFzlO6lxTF`2DoukisptbX<<)HulgFzrtR}05rywksH;`@U z^F%sH&}s$0?ZK%?Idi$`Hp7qwQb27T7!~g9yUG>W@X18E?)(Pn8Tr#6rSh;FAAaHnm&t~iKMQ8(=nz!Z9-avm{r0?+zZ7>81UQo4oubdHO#=?0 zvxmX~=YovAlR8zVH}iUz^kQ$D+XOOO3wMu#jO$GpQ06Q3Z@x^@CKcauE|9Xbs4to& z;~|%$-SEHxd`P_fVF)w!zQ!6kzkO4Z($cg6rQ6lcOr1mFerDUcks~M=N1=&B?_9FL z>+9NM2u@_!b<4;Oam-p;wPShc+uOBcU5cZ523$%P)GnB_>LR(c*qO=Vh0f~ujgLgn zjSn*a{(%CdAF~*;=)C9%%M$fJdFQq>0H2e&q(ljIz$xT+&vTY9GES=>c9(9+eDA-f zk2~9t0$*!Lnx@A*mmbfzmv>9G0F@`BlVeDlb~fpfWz9aSB4mTGGCRQJ@Rq0J(##fP zc#<)zAJWcF_X8d<-t%(q-q@CBY=7r&e#+{I0()Aw%vRbG4^p=RqUk>5*NI`-f)N`EiLZMg6<$_yChyxD4s*7|NU3 z*duQm$)T!*jPxYJtcyh~%|4f`9WGwpMjo!`n>0(=+N=iO=O5ZDKi_ZmBfQHlFW@c9 z25V<0&0M2bN?{`a*cj0JWhL3ay=H4?dx`n$>nAbp>HEWoo>|GN=e%wA+wj%P+V~8< zBDZs=qbHrDFV>tC9<4X^J%zjG6%#CP8!hYtIiQ!}iPOBdmfxd%wxFC9v*2@6nG~Mm3m_MbD?nf88vZYU;K* z+~D;}mMyn;cGzr8q^02cQmH5ARD+ua4%CoVAEnkQPSxu*2*$Fq+b=S!WeJKEwt8aF z7@n zCBt?O>74x4q{MxQ#K9kJXT+b1yFtumU>&-Dde~ zex_Ey|En9iWzx5usIoaR6gU~$Hn%v))t!m&mUP(1PnN)|(jQ%ud6HnYRq?}xF%cSM zfWC5qa(`c@(PoEv4bj)1KR0{VFIA1hgNstl<+W={pCvx64<|k^wiUz8fj$ zoDZ>!0xWf6e~P*n@24NGoI2OD_gwZ1-g=_UGx z(-!r(I^28@=co2d&sh$qCv3QdUn}%QHj+1R;mqy%rfRIsFE=y{mcCW{leaww&3_i= zQt1oG`%rW-E4>r#25 z@xsLE^Y1af@{jXZRo2E^o&Zp%I8%=oW9aNeI*2h-efGL^e$;$!eP0F*Ca&=1N{aO% zEjD^j&$a6;L2R7L-0#t8^QJ-L z0EI;pQ!y#ysIS-3zI2MagzViL^!F`05yp9w3)YCpy1LtJcp$!RCQ7M-Su2JJ6?%N9 z=9wuJ{X{N4eh^FUd=;0kx~x%N!o~R?a;mrMDQoQ#I<(OWN*=cqC3c(yJ60~i6mbMZ zi{^zSV|wX%C-2%Oaz3)7HEz3E%a;`Pe_|3(blecLDVE%Of~8*e(p_9!Y?d1^fSs|7 z;a$V@ADes?ZEbC3Wo0i(ULGDE8X5$E7BfM+LFN2mYfB3kar7V4c$osU5U~#_U^T`N zG0LQyU*jm0SBjzT?bskXv&-rjOM=L4V?;su=^!KwG%T#~@o{@gOGkg{96q-{%mk7B z#*U(0)o(-jV>pRk6GwlpoY&OUba!=iB%Q~*sqkkT;U9w!$8PxvO9g@GDt2ptfJGZ& zVfDxUcX3h!QEye%)swQaAhlI=>yO!%Iyp*BomP#@*Iw zt1&j~eMlKrRKpkBn}TJOCis=XvqCQ@uV1${CBX&!{7D3Z3F+yi^ZNJGS>Hat!@hg? z*INAE2k*7c&d%<;fLd2iTAJJoI#f#jo}Zz=%8?~}_N8*UL7^lg8!Uv_TU*P@$h0(F zJ1W!Ts}{;F)|$tD&Wn>$;L15+Xaa3F8`cYuVrD25%^$jg^u@)4KId&*-mk5#RUCTH zhX_k-r1PTaGgc*#iJ4c{);b@~l?#a&^!d3#al~MPZfv{_VS?E39J+w!qkS?Ib`P40 zR7&(pD%BXz@7YoGKY1X=PApnmSU9{?S68z$G9DPK7h*-^e$Z=a9ZHcYP${W1PZJF5 zHR2-HkAqB1WY1c83TAps`i6*2zQEO>Mm6w<2=jZn&7)#?uM^4NNe_RlRDToFb zm6DGK3pOkQc}{Je$zV)FLxV6n9xiSuCYhJ=!KLC~VQ7p&r8~v1u<6rx|1%Z|akSZV zp*%DNJ)|d<)7${0fBdYimvUF}d)|Tz#%eGRZ!QQ1k6}KSymR4^k&!{tv#VWXWMV?b zB7fqYALL9oeaH|tx%4W8bXR+#WS|&yQ@ac(xZIym;iH+4{G`Ob@+U_JX+j5gw3!K5 zSy?qxgh+pd{SbgZ3(S_p+g6V$9`eXmr$jQRO@-L0DZB=VN zE_|r{ccQrq_JC%XM|Lq|CXmgdYk+Bp^m|+pk4Eoqgfn zQ)Y*>(gxpVGIbV$_9R?zK2Fe+q}e@U1nUX`E80|3$@(uL4G`tYImuJi^4~=me}SSu zr@+sn2%f!>>)ay#S@grfaP;wbZ59a`4m;RWpDf{hLDS8EqT!mVXb3&Q`>%|wpBjZL zEUlk6`|mrqiObtb3@n?imU@m}1halJcLKlK`J}c6f>@!7!&!N46bR2Y|1!2ptnh(d z^Z&JLYRXTL@`?%=?Y!?yOjypt7Z5{CC`?DqCEsIkcdBAONoQRstTj6VFL4vq%>1orY09%43HA;ePU6C*7hCu<9+gt`lE<&;+agT zIc=Ll5xBHeMpm|U;m!RZ44I?kIBy>`5t5P~Jxu!A80hNi8W?1P-)0x(b%^C;?@z}V z%{f$c^}(amnwTSFF0ggwKQUSU1+(bdr1?IwyjMT)Jan21jr;FWg9 zMj1S@KXokf(Cww)Yln^usH@v|+9YyBq+-!T|G3?k7>99NjEJ31wz4swlYJi-lo_4P zT}PMRj8!68{%qhRim$R4m@rfRCSy%bM&Jo^^$yQQ%J zz$fcj+%t0e_L6|#k}sTY5lLwBA~)q@8X7G3&7%bPj^i1WLpKexotnq?U;1UFMT?#K zg3qp${3?z4wsvA;|5^kuHWn#h6r^Vy`&X2SXwm+>_mT-+4oWy8%MfU6NUtjuLIe?` z{c^f!O`E|)jy)yZNDu~@T439+b7HmL@7+8I(Rg7np+umk3(~MH*nXf2>y6V@Qqt8u ze3-Q0VoV}*Nc=|E?RbWg!9VaT^xPS#|0B^8udiqJKC)cW1gq)O}=%I1JY;Om0L=jyj{Sy}PRirBS*+jHq^WbRl43cf`3r5;NUgEv!&nQYw}03QlGt6x#hocD>)4u0KDb17 zWXY^Lh>+#s9qm+7Pnp}kEB|gmX(3e7P+JXb5*RO)tC|$J_L_ZJCvuj%+;~nnQUuzs z`Fspf_Hr3Tet}zO?9>r>J{dA2pzolkWHPlt$phOgx>oJ4k~}Z)FDL+ft|f~r)|-?; z-3|tRDJcm53I{;?Q^Dc)sCsLYP}WNJ$&VlBSGf4r`!uIt_nuh-Roi}AA2PTOGE%7F zV|S~!em^d2Qn-Fg8874g%<^+8V}_tN^X2Htp`_vbws&}7%fq=W;YV)Oa_NUD=wHM0NKyeO)cooyBwS;p%8hEsTLoTk#r-kLuLeE;^S=J;x zTY~ z+?Jbl@Lswd2mlNFjGH8lGE2qBi#+;n$_MGYV>BJO3RE)~iF?pObN48w%dsFvM@sp&Bp#-W_mLhu+&}((JaTk z>n70KLq&vd#s)+n5R3BX`lH{rsl8ri-2%6zP6X}KOnjjct<>!O?M6X37|kHAGeX2v>O_>wzanAbca}L ze)atNVzoBGFZ$7}cF}?h?G=29+R)bdosV$rV4h`~(NAGcG#H+Y*&@XZ>)n9Wd3?^R zZf{@x!UhYoLd0;ev9aI2Wk~pgv=CbKpL0QvKnuS(fT|C36IheIqVH%v8}3blu61#1 zF#yKA?k?Cw4!=qIRcT&DDWDMfast+1h;scVG*`dC?J{oj7J}(3DdsuDa9RfBRTHGcX4CVS_(LR!&YZ#S>90`S{?#%F=SN!B$sKZ)LqZXuPFZmh@kJ zlfIUiG{jyfZ$JT%k{xcr(uI-u0N|)I@+!co^ctgFp$8=hH-GclaU7+Wj#fB*`?T@P z<%O|Ed&j}V^ha$W&5cA+&^kAx;=2UpFRyCX;2Z>*$E!<$u7*bFz1_xvhyeGTiRK}G zuLmO2*5IAmvD#q^#E1tc10f(cUnOFY%}3bq9X84<_+O)DJioLF5@kZ+cLQ``(aJ9F z+3Vgr*WuC8{(og_F3AsJ9Ews104M!Ti~zjC9VuTL1%VtwfTQdh=XfKi04H`gYV5#0 z5=!)a{4Z0x<{NiDmK{v)z|1)pW8SyGgME-|n%t`ZTp90zE`E)qy|m7juY&_RF&ZT` zJCYdVXWzr)?-9SZ1>@^_{r#>#h_JRSiCr0jptF9D5gqCNGwO4~pZxhl{+I-r0^{l` z=?QpP(g3D0U5iZn7)avd3Gie1!!@7`g>nsEUfx5OmW|%9EPehLlz#@{iZ}16H=k=E zApUjc+qY|-MIQDBIUKAl>L%(GLVadmGaYOrCqDx8pNk#*lQUE`m5A{1|a#zydL8n?EI~|WxffwIhJ@)s5lRqSfhVCZEUtb)QR8CuR zq{=qs3Q5I#Wp0!Uj7s+BxmzTSo!iLD4JLB z_*l`z*J2$5L;AX8WyxrzA>U(V{*U7noXq>s8+q_Ga{wDR{iHAASn{p2{_X;i;cXqw z927EJS0(C+j7jEn@%-0ZO?^t)`U@(XWCt7hYqqWLd z1LV3{gIf&vXgd?#Ns_3*#L!-x37$UQJS>u(no?0!r6!0B`u0r^x~u=<4$7e0mtakj z@%Ea8)ka-Dl4i@k{ip01$e482G(dWT>ElDMC8bXJ&3h)!KaRB=j2$ar-N!w<{`fNf z-qtM4!6li_v3sBTNwH6hnxS5;DvHEDqtL)+)waOP$~m2o&T!zYSd7#+D0~w{&yHsZEeAV%4&~iKbo%` zPkpWLcETYp)hshWmUQuFncL*F!iwL=!q2H6oF^U@!V#J_N9N59l3_p9=zlmpJPsHm z|DVmomteP(?}TaZnu?JG9^9AZ#+He@M_K((@}$^E^|E0 zUc%#FRX?1u`ZkEhN<|l!Mp;awYbDf{FCC+$Y<`MJuKGE|R?mI9YckB|8jm0bm-du* z&~77c1`yLwEf%UHAazm<9S zKN1wnWnstRbf3=tIQ2?PPm4&+=y;cbg+Tp~Hg_zrT&iPRR9rgi;UEiL!wt$jLoi05 zl|ze(R|Q00>y!9ZGT6{{l(1hGmBhHesY;DKDu$@$p4MDGVR7-{wNAMP zJw78oT9ORxU720vpLp5_I8vEuXb`;v@;dSU>w!J!h!pfOZ*mVtco{%uXZvf)#BzQN zZ=;1!ad4=Vs9ksrc1p#P3t3fbJ>YY=>`gQ^H4XnoHQSpC{8v&vs14(FnCB0#VS`Y` zHQ@?@Kp<{zbw)Ca+*CW6f+?YOUteEN4vw}q1@46>_-xafzd6sufqLKF5k6?byhhHj z<~U-@A+bJq7FX=AQ?pFL#pPw>_wULjYUVRo3OP!3b)??(vMMSn#>SidEvsV`+)jtx zafDx|_i+DBpd|`MCTb?Pw)CgU(Uz!{!uTvKl-rvdg6|4fd@0kpYK(BA?{UAHn!Z9p z$}G~McH#MFN63da9GY5snm6^pvn_=nn0tURRWNcfet3KL7HxU(U!$X@7N;dSV<<;~ z`u^9a$G0zyX@-R$G9@MDaNnrAyBjuHy-aF9P`=83zI4KeJz8v#{J%B%mkLwQaS>x= zjl*V=JiHC7cKH7N`z{ooEXN-kw(AojL16K8aAYgf%(2^}^ye~4m(*Snq~Hmf(wFf1 zOop$yd3kTp`u|A&ci|tqg8QJz(CfI;9Hk|`#}W2#-F!%-)pMK$BWD}Ei46FH2GjQET(aw0Kb;Bmx?+~UKsB|m*?`kZTc1fmM|`p5fR zyT;>K!;Dj0T-?7qWhsyZTTpDQU(i}|rFMl(Z7;9hev4EK6PfcGXX55uQ`}y;F&ijY z@O(TKlsQoyx}vCd8w$&&4*u{FCOCb!bcLesFMIo&C(qa}^WoghdNG81D9~xxy#C&Q zxDubh5li`3!Y?=q6PkYZ|Lq8^ZB}HM_U|KBUhwI!i%t zTRqMixt|l>99_N@+*W^(9mA_kIx77OX}>mnA=y6=8sj--c;2h6!Qh7xWg2*c^ziuN z9KDszoX0T?Xw|y>Bm{mum$KFe;Kmd0AJCn1mP+W9p8fkerFFu6-kZ|IqD&b%)$98j zceM&8pU3H%=w|&AdLRMoxB(vnI2^*Jz@cN@l)_t(qSd(Q+QR@j}eff65R%1}}lqyxDyq>jtfswX;1+ z2i;enH3%^J+C0yP4k1=2n-A@=1ZJHMqXWA^t(BLth)-4h)0Hb7_x(aQ!W3lZKk8-$ zXccZwo)>c-k2AL${quNk4PpuL$$B7*S`)y;M7OJ)uMjcZlH>eb1s3SPq z_0@r6CxrCZfqmbsJ`+#U*jy_wdsU8UQ4P#69Z<#2p?IHS(~;;2Q7z6SFzT7~-3ZAf z*GMQZMqUbU8^To{I?QZve9wD{zz0i}DkyTfr}&h4)pTR{kx{B=_!>t|M2yX#vaEeO z`NsEA*H2A3I{dhHp2|c|P}f)MPYW51#-X=|rbAHygobnbN*+u~Y~noZF`)ETLyNxA z$v3u$KA)c(JbmcVuFz)fD+~<63;Rq?U%6M#xZT`$O?=yk9nrpo6pJ>>5MjMp@!7sn zceTl?VMskCGaP~Lc}a}#iCpFcU7FdwfKv}!X{j^LyIq-1uA8Ou7;qktdjmR2Nzw26 znjJ?9KcBV^v^luTX{2j?f&*O2?>P6DHZ^)8vwqz_K_`3j`oxObONyU&UrruvDpT=7 zKQOdB$607fHNme@siQG_SuJGbK|J0I3q+U~Ti!!QZC{>qrU93O;l{s0hr|Kt!-SImzYfFyCXslRCH0|3*RZAGVy_HN(kK{jKn z=WoT^-z!-6b}Y?isVBNPyu)gP&ZE}m>Q8pR5pLX^g_OSvh-Z`(VLK{)>lY}dI~z)! z)u}vffe@iM&5Y;OU!{BcIua{)=6+VB&4Io%1VQ^QPj?{d!0xq!&5G|~uPcv^@NJ4V zx{3lj=30~GcrVtx1uC8(zvY@dWp$1i`Qcuv#q#y+WORrI)mf+Q@!v(GMBQr}Dt?Gv z@Nes|4^7;Hl!?_`rMEtDFPDtvhHQ(v$l02{$(|-$5CBR5sDh8M2F2*bRNNCCw&KJmapg>bI(&! zuW~kS1=(HPlI?$Xsbm`7_QpSnL>#|6^R$3QpUPpY0P8mXmVJt>Z))1A!jTD!^aZAt z4gcEk>)h@~@{3S71_&NRZh}uyx&`1+GTz!ewD>qkFoA0gTOFaCes;&jW9dn=wxnm% z94XMWjFr_1(zm+;PIXo62bHshF+mcfpIQw=af8NEFZx_{*Ivh|0>D%^4wj#9QtiXC zL~903^D)wyI=q9c#EW0is#tLsQ_;~A3;)T&b&C7YUa|DKf42KA!0L_?lcbk+%3D#*<(gRHK`86W@Ud*Bv8n1>hSNL|9E`@5YN6b! zC>4Tx1hs5NO%=&)wsx zTV5=ls1s55eXjG{Jqc`GX#&}9Ur`YRac;)^VP&~+t`9>ufj95qNw(Fx)fZm&&@zE5 zzz^Wke7PzgP@vz=kJ5xhqk`O?wsH2m8RC{ReOpK6Vkl@TTG$)EQAe3xSZ~>pc$VP? z#tq$RO>q=u_ske*bt$BcApljbWj^4-gaT8ODZ^(z;RSV@CT0#HHiPQ(=5cP8&Xl9h zdH*uwb^U~UZ0-D$Ud=&_C%AXPh>K6BJ1-9HBlTQH4qbgrxuGLEEgoUEk6`b)6+!C? zT!2*9aP3@|+K39ze}&uEV6VDY*g|VB-I|(E@d+w|Jewt~-Q-|shKpchIXgs^%vK}N z(Q$D6XD~)guFX&bS2M1SbAF=9DE2bOldv)YQS3!7W%HH69(;~Ed*sRGp>IkevD4s; zpM?5zpWeX+6=Qouqw4?K`>rhWbaPid-Z zcZ~#h9_*Twa&dMi>R9PU-B4zyi7II^`CBp+Q~73zfK_lOdAZFKpWOz`!gjTm(f4za z8quzPy&qGR10NXoUb2N#X(Y@ShxQNw>!i?|?JK2?c~jvQ(Fn!>hEPB@5N z{AAEIYV>xm9K*`i)hHLGv_vF8;P4$Fy2LY+s1<|uH z4PG>Sb_GoK>wAP@+kUBH<4A||Q8kgddS+$$iR>7whkeTD}YP zS7h8FtaCFwmV4G1+>+-%$F`?rjv!a$9SnBb0Kh{UtN(0m;+FyRtqP3edg??f)AQjV zc*`m>Mni2GAV4c!174Ibp<2^Kn3d91e_OwvyV0KyfmH$6sr37+xf4Xu&w{ zI?;}AX>kaS=A0s~|J2``-@!)exAy@^S5x9GuUX%D`2?KG=^Ag7rLa7LlCh`Kms4Y+ zQ2wGD{U!fTP5zZMeL0PF^H!1bq>Ghgcl7K*@JQD}OI=&d6g1}QImw9Y7?HnG4m3qN zIGp2cz7|yMD)8bF{>0TQ~z^;$;5Ba#8g6#NavO11v2Ny7JqDrkE1 zA+uXmI1Z~KM)1C(nt-iNw$o$t69r(_mo(W8{eW>NzPUqtBH;4d@r!+{i60TE&4LNA zjy#smcf+LJn<|rJNh;GCaN%(n~OcN+HxkrzHb-=G%MU zfuIgg=^_I|r#J(Wo197s7)8f=m%e|NGRh@~>$&Sg-KgE$Oa?@orI;j!5_q8wa}91W zKtY811Evx@3oePp4_9|4>K05A$$*RN3o;83H?7veU=XNPetK5GUV#fgDiodFE_Scp z6Kr*PIdfe$#9P+w2 zNy+6?f!643Up+bXw^ZsPG49O-m6aqYnkuj>q`^15T)+(%Fc1R)4!)1ZFSg-4MQ7y_ zG}}7xT-4~A5;0fkug}rK)jrYnR(Lx%xV^qAoaU3cl6H=y+hND&TTKo}8We7#+H66P ze{5_d7n(3owwh6^I|f@UH(vdY72iDd7GdEGM*`-g0bp;MfBfy2`ESv)90tqa(-qH6 ztgf!F&2C|Q`~+RbMyNnP$~P*Sc)Yowb38nFQ8*6_+53tw6X>m_8fE3n4PZ&46+cM0(dDu4h zC6kMUM<7Del26i*r+VNP!7I`~BA83;(Ud~q6Obp<2tVXCdOdG-UsQ(~oD{ z%d422xZmY{HQ}A5D23tP8oO?>>V6|Boqh3@-r*AO30AGV$`1?(v=mt}6S9krd7Cxmbq3KO#eV#}J4~{rJ zF^nc_k`#@PwT@0Trt4Th_57?BipRBY+^puD!z=o)0iRI1F5jTiS4HNo2?*{kb!H1T+z3oN|72shg z-Oy~z0rqjmdb-)6HsJ_K<}qt_S4X9fx=Cl$rkqaskS}(Y+p z6#+eQLcnjL|Go)?#Y-`Vy^g2{wNil*(+2RQ*0mXXzD0d~uT{_K9SG)j8*W5o=7N@I z?V?HZO}x*s?B6_{Ntj5ES8t)itBMr~v)_CdNPHboP*pyM3b@=U+2bJU*$!`ncJ$-w z_l8X;vyyfmY>keo9xtH^1Hr4Eg@px>GSsn}p*NCz*&dduem=lPRd$ZgySWA-M5wM+ zKsor)=1*WFghjyg6`<0{b6Y~^CU~7y+LCFEnENy8XDg)TAeQdQ0|;%84uQ6?Qw1wv z{!?77fJ6bqSOaLcxOH0KN{D=HDNFY9+T1_Uhfb0hktG8k)C`n4A3X|~nWcP0}M2jbqnFS=A{vA&WP1_q+Nvvll^)T^2=p05f=k;R_!0t2~<^v#w4}_srcuhW9rJDTqdz(TFAK5iIO)drGH!#RI&v z(QlqZ5;lJ*!v!&)&q`t*dzH6;-5!`sSRxRK<71E(v*r@;AN9Tt0wJ3uR8h%}FGV>G zn6NLOmRPW``fh!`RKIPZZK<9)1?yi+d&Z?HU36Jfye288TWU6GWo%_sNSv&rw+K&h zkrMsZ)G#sC@w7-?D&Z);^+{}Q&a26Ct4NaPh?^f~sL1M(km<)<@_F9ibHB_*Y$|f6 zjW)k@$UBdc#r>(K(y^!4(QG>!)QHx5Kdl|TdiW599&0#dV6(61HLh?8i)4EL%HWvW z%qH2=>)zyL7VL#=ZMNQkYGp6K#QV!=< zEdlQd7k4M0dD3&Lk>*!#shdq z`mI|1&cMfleqm^l24V-Lsg`4~qT-=Yfl!+I%I_is8Oi*HR*3P=64EZgoukjKu|78{ z;~IGp&D{D(n-tA{{l%YH($!S9=7q3AdG0?F+Yu)Mn}4-+2Ky6)oiNUJ?^M2xEiiDHT2}~wLU-WOq+ve@2OZf*Ye;x!#?f%yY{_j zZ_wOl^x*u}vh}m$Jo6$pI*6F!*wo7#@}ChZByLK z&0=@vT*ywnee!(%%#O(I%hEqGHf)i-vi`^Ek{y>;ZVgUSwa=T8@+qgXDxhicxgRIp zZ!!1E_zTuv)m3im_K&b-2->{mYsS>Md?$CkF4I5y@rkPL&tF?->$IzP){3vCr+$e-?V6-(|8MV}e|_F#i-yM^OE3GB69PwP&}*8&r5gV z-9P;2RPrXxwof>FFx2a0(TqvW+}S$=JGRQq+2?vT*S6Z`Uvv3hd)w;$)nEV3nI$oA z&+pTh((>o-Da-qAZ+2kW+vCgS_uVV~|84d0&!^vq)$zJ*_w)6S+gJGH*UyU&zvju! zxBQ%x`Rd}_qw3u9_iKK9OD#1pvnzY^X5Q*zcKvsgbuWUa5>^{p;(~%e7BuN2~e!$b9HFzwv=Zj-e^$BD2GU1EY8_gu#V;(B7>BOFf`I4GDtHtB3+V0cgGMz z4MV(#-}AojUF)vr-v91DcfETp)-Y$z*?XUTc6>jvPvl!Qc@ko3Vmv%N5=8}wCLZ3c z?|69l&+py>j;s*sqJWQk?g|D_JUr62n?L+cw;$Gcc+c?^A#b$((syU=g0yw!i1x25 zRag>K6!$WiZY$i)_I>;M=X2s8Z2G^y$CaBKjhmRDJ{4~mmT`Y3ru_VoyYXX^oU&Vj zsU4r>NEVf__=AMo(&YPxxTb}K8PU_e6pIDn^%>~Est7IVO+9=T=Qap|&z7o)cSLx2 z=8U%`fN%F17x3}$^zY)60l!G!^#cx3O1BW;;r)JiiyjZ}UHHR&;1K7>|8vRz?^m|H|y-{eX=ytipK-o>ci%E(U|`^C5k+EUH^2xg$xw#u z`lyv06NYlqK_Gt<#8>czbolom@9lz=sOb7pIG((?7(elG(*9GC5htE(ire@(xN!|l{n_RV|E?0>g!!$6>*wLZmw zjqIjJkr5Ti(%F%*SARwl+yuBC?Emo?RflemA6m3Y*SKW`Z)roXujU_VO#S$15S0l6 zH45#`L_*(?$5&9sh}Ts(;!fK?gPuh6Mye*UlHN_nD!66;h>F`@Ecra!oWw>vts-aS z*C4>5Aruhc)tudmupx$~Ui-{*gU(lHf@khy3J}tm&;)+iMlXRcme9MQFAHpHS23j- z5rrw&uUbZr@SV#-V53Id*zXsrIF5$ zP-D}S@}XM$K0^Aqdh}5PiCKE@ncI6ctF;5<6{G2kLb>^h+N_qa=_&KG&E*kf#8xFo zg4yp0#}pGYw++5|s3-Nj|N7b0rH)d*BFnNY46y*m~mk+k)x{`l+&jV}rGIGH}<`LfFoNxkvD2f{6q# zp7EXA5?=N$g51WnR=r7l>+yf2Z7i}qmpg_@XwWLk_r2(OxLneNd0vR)E=GTDIl6dP z3Gr8;N7SMG{CnFM;otMyMQr=(mMou;dvH(XLPcoj8&ax{>oIyw>NY~@J?hz?biN41X!?lQ`2iU5j3OSjYV5Oo? zC5ijh{I-jiI!3p6%(Cp&9o^D_kh8^LQu)qJ9i7yl9Q{dLHrLp}1%nDpm;$HI-@j)9 zLewOL#o8PX?moog>O;-(7Pc4{vfE~m&jL@h53n;-X0#F>mX*!TY~u9?RVY4X$oIh%FI6LxLTYp37d*syWA9v7n>LO^@4J+Cf z^(*ZQTg@*IIvrlfe-ho^)O_Ouom)Kr_q5w2j=A&b#L4Af){GGbH<<68I8~E5b2@bL zY`_)45AGa@rsEamdo@#EpwhTqIIJbVRTE^y_UQhaWP)eno}$7xb(Qi4keT<+>6RiU z015W;vJ)gHsn4Cp-=!DgLBzS~|H`X2hFS+E8nsZZ3JH&G!8T3;mr`Dchj3o`$dZ!h z$C0Fo)aU^jK{KxQb=#X_Yz%OY^JYG0`Rbi@%P?cV;oRL03O_fY@zGHdqW zySCOEct16gat!8MEI*YmctGYLtS=N4;<{ec+5ZsH~Hj8)|KV%O~_!k?w>4`6U zBkf!8hIVTLiHI;phR!J|pDuCUlan1}QqKNYSUk|wZ;LS9UYpE=qC!#yrVG2Q7`j)l zL6m{kHbvK$dzSgbhljnQo0~!0aOj|YDq=so~zufc}&R$$C|a$bkM;Da zl{A!xm<92A45UK}tet;(ZTx%KICq$Jy+SLlyQhonww|si{0Xd2-=CK%SO2xH>^MHg zt#3_3=5B#Lt9=DpahqRcBWyjka+IbzNY4*t6%70Fyf`v)kjPA-9ZqX2J=HA?^{{ssbHtw3g;RF`_qw%#Z^74k=@;N1oRA{znF(RIyy+H z1zzV4u_g9Uu&PZsSBG4ln*;&T=h4HYZhZ2gKp-B@QB26m*c`Y^avXATFq+3S-yuf; zg*;zC7zw+~);aLo{zd9MB4=dG;idvhV*1`?=80Ri-gi)`6OT!y%n*}EhMim(_Rvn2 zRVTxwbAtLP@9l&v-s;=4OdcPK*bHbf#&gkch>IKG&X^ zJ-e_GbUQk-2k|{C5hdD6XLixW4bc&U>Mk>5PqC-o%wkoOQh&Fbn2TK1eLI8iX+-jY z#Hx#XcC$C{CnS5>bzR8fXIp}(`4~Sa`r5UfeINw={OPF6_PFl>c0Lrf<>ezKHP_(J zSL4X4b`%@^_~FpOGGU#2=In@iq3B2kudA`Vd9gOSp3nnnj5MZy@+2`S$)}Uf_W_-l z01uCPz9u=IvEXfqhvcj4HIIh+QX0jij@Ht0iHYg2wu%+|N}HN8q3bOD8EGrn=B9#n zOJK1us;}M$mWTRcDM`s65nKoH_izu;Ir|&Wcp;(>f2JOW94M-Xn zYNYrDp(n(}n>^V+Ps4u9|9eQ^92Huv=ztH=PDgF|NC+4%`FwoF1XKA^Pq*&Q30YZO zWK2{Fmu7_bmXxvrE%uj3NQeVSOiU1vsF{&v&KKC{C{-_u7BU9a9_O*_fi~NqfPq3&Io3RSSI}v3Ye6ruIVYB`%Mf@kr ze3k-4DDCpE>)Nd#h;Jbfa{%L!y~m|{&Nt-S)mu4cauR9=boz{*5rQ!%n5Or{g>&1O zRc53ps&CUaw*_tc{QUe}Ema^A<}5V5U0TYR<1(FE?c%hBepY2DPF_`6xsN63BM-e9 zhT`zvRSeb`fvZUFw@vG}Ez|F_-K%4Z%8g_kEgyhvrkCfgNcJ^OG zxSlK?_}zN{xEzTNWR;NTt!Nn-D+xfCn?@40&{#O2b zn)NwI$0`xg`{x+w07z3Sw3<=W!B-m~rU}eHgQvTSRu?<=T>Q-y7f(W%tbFTr$%JsL z&^$}6YG#23j{R1QXZ6ubn<@c9#Y_2*wWI6~h>>|PYsl5`72Fvk7@xdR{MMe5OUZw` zM1zXmwq{z8I>vO6wTC4~BUdiJfUuVG_ayD<9FCqmhCwRiFYMLY!g`h)NRx<=@MLSO zJ)9A*HlUV}3<6P941rWy$;+-s%mrce{my*K> z)j+0gd!#1Y-|a8D5QB*0;Cziszn|VCx7jT%o1Vcfh*cq<*H0RBB<5>nHHnnwvz7o4 z{3|ThS!=@igreSQBWD?-H{LMBpA!j7Q6B8eVvrJ_^L{4@GF5`eBKu9i%RqGBf6XNl z*pSW2Qy7u_Y%e9H$^=~J;`S(eA@bng z&SepW!&UAwV_u-iB)4XXhW088Yd+K8?>@lj{hnjn$e^V3zW`9$z?#)yKC!USnu^8L zOzp7_ho3*m&3zUniDP zTDo2_SisLLANxSuGtZ|#6-q!v*q@THvAe6GJDwD;aWZbyDM(F0&i**HfJMgKT%D@j zrMGMUWbM&VCj-3HwB$J`VJOZjzLEDGrp4swz_^9RmX=tjmbM6nS82OsQtsF3qKgAQ;G?%EDg4yAwvXez z=VtPlm76@kM+;#9mZICd)S3^y4%#|x@K-BsGW>0$9MJWXxZ1Q$@5f=KT8AQ7x44wu{2MiVOgCBp122Kp<{-g+*Hi zX5CHP>&M!d9=}@+DkCEmh+VY+fPVw4`fQDxnXS|Gf;mC_61tv(_Q;9DG|fW_^7pE_09*2Pl0=? zQ`IHXB|`amc^||5ulHs}Al7lw(JJcd(4?RZM#DOA=Ol zOe>kx<65wQB?M?Eex9a-eOV@^uE>q9cthmHiyc|AefifdG7()0-B*`TsY`(y3dGel z!O%rX<%mv*(;8?>#H@##+Z)|+g6pf($mrp8=kiEVH0-8&52+impPd|iY4iaifNn1!y_d51S& z>IR&9RY+$msvN1RlHBB&%!{V#V(@z|DrR_iGR>-%<%%d76QljR_|GaX|7u-oIV?OY~~Nlf0rZRE07*dEs{d9mieO{q0a5m%R|N>T0fvkqloJYz{x#QWBg4)fpN5{uf} z8Uad98Q%1`(X`onTbDjgIPherxOCTZa`)ut&z~0;K^chcXE=I#dQW6SNl8rGqC&oA zBm@NSO=0kpIAy$zXHIdnu$Z*G%DjQv(^Q@a>@$D$ki5b_>a}}+QugUXcyCN>Y;1Hi zCpR}Y2M1ru3>DvPA|f(6v2Uy2A$x(Cm>7UT3}`gvq^y@~(&ua%h#`6>_4pS3 z!p~Ru>JYiygL5K@u-;V`W@cGAIa@nB6w1uKf}yC=itJ6i0@I_&4YgmQeOQ}yoEJ@M6cxlLe&9= z4`E?$&Q>rsZtj8k`RlIu7kxU|Ot&}7i;IhUK$`bB__OG4e?aAs9W{*sbXq*>I^5KzbXp2k)) z)2VdUvJA*2MlM&k7)UxCiLamUA0OMCpQ^}bK?Nzc@fTA6a0a}4i5ea*_uVsHFRifc zuhW1piUUP(B=(?Cr*Xye=C6P})})&ZOKe%t-K(A~$2NS=&VFH15Vo@4cNznm(-)h zW!N68WlBu8Efen*5>XBLyJQa8ADx`o7VKEK(7$^L^e&t2!>#(4#*xjg#x?UAMcS@T znBSMAGd)0^;Dt?1SO2nQ;G9A(Qt7pR*pQ_X(s=kI^#_HB_k zcad}$?5+w?{WJX%-4fkx+A%kPo<{UT3&6lNF9DSYq3h#Qt-=x&6;(e(@}7RPK?vx~ zz22RYK#hG~lM&##a)EA!#hp8Mc$@27o3%_$=loqv;nRD+3=*yf#94cKriMqtNa^a} zF!1%oD24h3Jp<26cK;(XM`YWZZ4}k@p|Xa7fsunlTHE5?dk5&*X}y1{`|Ark8MTqx!<2Y>NON&mGB)6e=w#=|^6YR=ncj*TOD@O(*~1;_BEQ z8E9xI2)|#GB{sGb@HSV2@(H`J3&-y4v>O2V+1c@DGe~Qm12R_29SI4Ei_4poVn#5vqWu`x8eg@WgD{=Ok&weXyw5q*N85aOnyMt?sF+@H=-(mOC!J&X4~5ezhl+gTHTgql48xC5>1fZx3CL zVSssQ70Ss$_6O2M`+xOE!S+p>Lw-X*8pUI%AeTAJAj1#D_-Dw4WZ>EZ8psA*`_GbOqo5CD%lqU|LM%Ug~_Pvi`}E@CLTw|5LO zS`2Tf=gXCs|7Dz_3aP59<0hDMt`?xYM2P?U7C#!}VRkrw{r#FQ*L87b8-aJJZtANLpK$nu0I0{6OAYqarB$5I48? zZ@c(YoQpuk-;wN+C;4;T5KC{>w2|z^&@){%mZxeTgIDG)?yb zo^1LZPD*80S63SwW=yeKVM4dHByPKI%z{p$W$cgGnNeqg`c+e4O-`Mm6W?S|uw-zs zq?MJ8xbK{5MpE|^N=i~1q5KjT-UzD%C8=RYhRVsHNQLKYn3JnW7%i!z8^g>TIJT=% zkL%$#SbLfXZ4?HkCfsQm$qE8DcZ^_uzyAKb+@zsMZn^g4#Dbo_(52dat;poSk7RC+ z25I~RQ#{M9Q=GMhD1xM)oV3aRB{8XccR`f5$Pz+1HyHgwofEcFj(!G696@UZYFs=X-5IG zpZLuXOIK`G=e00@B~)4e)y2hS`1_Y?p{0AbJ&N3P9^0>7neBbNYASzMWQ?wWRN~fq z1otwTb4JPEFQY#b$3CnPcpA6&Q@k>N%5w8b!Xf&rFOjH|(=VZhV@SbID&&cdQu|tzI*lO}M9+TzJ^7(= zWw06P`T*X`n3EK+TrPfUoKSGJ9sgpBpCi7;d_4D_;%12HTu@9;df*R>?HU`Qw7oCv z40APk>Nc&D(Q&#P$4P)V3J^$s5(8hEHxpRe&&~trB@ItYL+LKhmW{z#%8=F7)$VRE zqExwf%(Q=gf$I(+tnWuGcw!;eg439aZwz~>j2Q7|q9!$~xicGH^8O%!rCL_)|K$b1 zzF!x!-8xpvwxC!}AbcE(o$8(mi)r^i$Ilh#-U>X8Z>n+F8q7);ZOGRwVMmbNF|?Eg)OTMf&Fd)BV!nm&L0D83C1Q~TO@G7Bk#w9qo}BK5Xluv0i4qI8sQ zevHpTO@jQHH>#k>rDQkXP8(8rW+wAVJ=RnAtC&QO>$1xw;s>AEHdp-TzjKgE%l61R zF}etu>FWMW5#ChxluUX756g*-At_;@YF{h@v=9hzF?jo(sfVv~oU9)W?QJW0IaY+i zP{GPGdt!b7D_S4Iq4BtiZdzycfgkAWxj*-L=l6)KRMT{nCmOOmNuet1-%pvKn(Hi8 zuIgc(1}cZ|gvZH8K(MtsBB2JU{Ikyh5pLJSEP$iJ0(UB_(qdLzaEP4&B%?<|-wzgD z!!Kq20#txehCCR@83$V%RQD;U*DT^>XV+kRtX25A30tuJ&dtSzi=CYppwlWQfsl=p zvUtp~X4*w4t>35B=KlNFEsO5JT5|i=`?qXIKsr1;JUKZzIM~EK=)8#r@md&OBI0n& z?y?><(H44E ztTdH0IE`IA*#wtkln+0GLZ*Ij>yF1{l0!KvvJslgzr~GlmwJ=hZbh9ib`8WGXWc+( zM)r})b}U1bNt{uMv@JzT{a$P-0^w?J52z?!rcMl!h8O+9KL^z1fdKVQ;fTMVAFSOH zoW=9-?pY8R;13V{T*ZlvfB<>cwM?IrGOF8pc+*Q&RTT(%OHs=C!{5Ju-`KEcU^v~A zasB|TZD&?@e5Ong)y6UqfDzxF)*qiWpw>Z|=(D~jsu}$L9US%n9W1ok>}Gp?1uc@Z zF}%hi!+A2z*y(8}k2`!AhaQ2-lXtmDKE3;g5k?_dRJpnw#gH}CD=NxXRce#gUK91n zJtae4(G+Zt4R&|YicF6@m>*@zjkH6g>t{35(}M(Y#1qa!`I-i1X3cK%O{R?j$LLwy z=i<8V8>h;ZzH~fp1?rL(2@A58u4#qpfjl~8(wcgBx*TJbzIxL$?fsZfxIQZm8_cl( zRXj?$YW&+E*cZ1cikdP|q58O?BQ$1N9lAdgZ&m*@Syz^|TQh=)NcIeJnl$#!al9dI zTcX{1Slp;<`2gqx5&ucu)_hMN03D<=V%nyKB3`$+G4U&e zHL=TG=+ZjRZfN%(>O^*@P*oiVBVPcA&~meiC~4{y32tyAI=7$HardHh>|wCZWkOkF z%f0hn$E||W0bo?LFGCqFaV;JdOSkFQ<&V>xqKuUZ2|WSG3kwReq)WA{KHXcAX9{fgpuq`5eY+e|L8` zpmEMwNSW!8nc4i=+1bLv!hrBCTZ)@{3!0bd!@68+PV@GY#jUCl>;R=%33WNh3#2e+ z0RBH}#mLk8bQWJXW{C1xDvbj27a(bZgRy5?ZlvBBhJ)@R8wt&HBTk&Oq^jx5nZKOo zdQ}yUsr<7T%%$ooIGoJ5$h~71i=7?e^*iM8<=wUGdZ)@~>Qa&md!bSnm#0`V@Wguc zG$03(>IT5$@$oSrJ%Hlbn3z7MNDW>%R2lN{MFE&p+-@ie zlH(M}@ICDrV5M51HXm*`f8{*iB+1G7tE6NX6mFFeyjLr1fg_VOyTDjmsA2v^#%n}+ z<_>szx*d0v9@6>916GOP2twX)>@D;XDx&G&Y_6JenI>+RMvRv)SjGPJ58=4Mp&wJ* z991}>Z(}-+ksFzXn&%|def{yPsmW=Vg%wT*qks(P23;>f&}$qGLe8B(v4713w;87TJAsm697_Og0eM5sC>- z+|u1HGtuee6w(XAxBKU}H|O9|$S*$Nh|u8I>ApBCjB}I<;vK09di&A*WEs4!Mr#qG zQ)5`FsFgq{a`E9#2}u&qmH%N>Xr>qC{m7H#6Z4kAECHJ1Bzd_KbsC%XNB;ize0FLB z2hyW+K&zjhu(K)uwn;;>GvApvhGiA0%+8`>6TI;X*2y|1?89&OHmLDsyr)5 zZd)`*6Fj1$`>ESW9m7{)!0|Y>q2b8FqU!y7RaRlIvPw?LMAW~B!^4lhkDVv?-vY%J z+SL~pYJfE4A=-fxD)Qr*JjPn7uOH{SAk<+JlZEOEE-ra$>n=4=2*}FZ+)72oe+XO; zoiYlnhuI5|uR3GfdzI(0MZuD6T>Z`2jF3VM@6*5Z^t-cyg89N`i%(`}Xw6^wd5Em+ zmXMH?+`m_(Ln)e*^T^4mjgAyijaWg{yS~Wz_U+xy4v}f-<%C=FO$;k3;dgnCl{(g* zYVcPalnPx?y5{&!;3`DmUgci#%-q_>CJ_!lZIFoT1R~n__;_-1^32RkIC#1~Uzo<4A_GR)Tm zmZ1t?d` z%L!k-Nu)P3vjNE_FdXY9qyh5I)gO?Xzsa(bkUdsoZ>;MeS zhOVNcqhqOQqiei)a%(>U5VN=gpxnzA32;h|Ri>tOMk?l)S>D&q3#sqWo z^P&3-t#fnm3DT3e{T705nTStkxG2Q6R-5WAAcq=mJEDxu+?uK?QCiafuv`SUZY?b> zt$1Q>`oj{G@{f=EmPEEj3e`P54`b?PGShe9={vqMnbfY20Lx`<_|q6UmfjQxkN=Qa z08&~bT)Z(YAdOX763F8V3)dG~!+=z(QH+nc4NNBby?~uXYcW{_0Qt)pY@c7?+qZ8u zHNQeY$ZAPvshiZ?8b*XWJ2P%`#7E%WT=K`eotk0`xXbD3G-RN@z5Ndrmikm2?DQi* zo$XdnU;Qh@+qf}>UKk)t^tFn#Z@q6pq4YrUA3uI%Vr4bMkczcr-34;GqD{W%(f8Pw zWwhTGBdhxhe`aYv4j<1|Gehr}XwA3Cn3zPRd@8dtLiZ?{7J?SlY)lfLPyMCif6fF( zle?7{(y||!-`Db zzRSzX^1d8$^P<6DxCNBv?i>Ha325S>p&@;sq8PxsNAk-4->HEC$zGGV&t&;~;h!Xz z=Oy64YMZIb+URHl;5(JCw1*D z#G(}bt{=EsoBeb3wXd>`g!mBz<^eVqs+2IF{`q{g>j$)PnNP6ThHXXv;`8i>@GX2- z&AWalT5JMCLuP&fhX5odAvw3{J#m{g1Uu_*oa|Pl+!9K&8vEHWTmR(F9Y9~Fc=-G? zY(Iscbu&BST#1Q(Ai&YddvUS&EC|tF4nX41>zUJ8S@S)MZy_IH1MXBvmc%5X` z|0DGE5~Cxh6ZhGP;_)=@&602s4Vp04vJy^XXZlD(KR_dqob}DCwXm|J|6nP~kQ)xh zLdvZou&48?gkfQwFOcc{e!n|Mi=@F>+8lv$pEhSii`CY@^db)q8pQV=_pDOwKoQzo zupd8vZbk7lZFEoD*Nn7=t$n!V6x?W1|5?>839$Lr2>4iB`J_udf;arXza#bl6?=MA@H8fe>iL+_6dd^e({e zCMH%lNJJ{F77gvof(|jcj4~f{<@^N%1iV}^i)~4LD$wA@Sxb*ItOxF7RXqjtIBK?{ z8KVsFM_l?})=u!xw#~>IFHa7bm51Rx42L@vfdFv@DAT5-e>z`V{vg$53D@OKEqhlV<)R!gvb+C(BA=F0gg;`{KpSUlm9I3XXtI1TIM_RfcPZM}JJOjp4Y2h)R5azE)!ahb)zk0s0o>kb{ z-kmN_OKOPZbHX0V07Ix`|7g?038h96b!Xs3C~i6%Ak^lNBm{)F=|nwC3t8(xcyJQ@ z!4Q>}`{51U30CFhfYH;guPfdnJA1D0`@#OA6u<$nCK8+Z+ni05k!u$HF6#aguTf{& zelM;60N$KeYAhOC6midwG$JSn0GEC*^BKO0hcuOo!Hd7EaqE#@rFG zqX1>;KPYc+G5WX)YsK?CMP9(YBOf<@xosw&mimA;wrz2N)6b(NIwF8SvAJf&eU0=E zc}&JLaZ68Y^IBiklmL`^eqrn=#gJqau0N0^oW00dfSbDFJr)VzHyr#VPU)MV_GVMa zvh`Ir3ux(nEnwJd>mAYh6j4dTNduOuftuVSpKY$ZHi^dU6@(0 z{b@>Wj0C;!TF%PV3uz`#i%HQ{fGctRF?>(9EgbgJOKXSn$-~EIlvn}cnYZWg}q&DMpavn$(fn4nUc6K7|Xw%4C`0(*Sm~4MOs!2p%PVk zJV@zmgBpbU@m2*yz)Eh$t=W6$HJ~|99&OS@+5?<-Cxd!q^tT_{yUiDx7XWn*+i(k| zIX~Zi!E^bB=-vIrz=M)M*5$jCS~{AC_HX}Tn+&aT7dM8)K<7(QkGK55N#> z=5IgxO8*S4AF4a9&sl0n8rb_fyQN>Y8QbFSw$=r>se;JnJ{OX12qsN=s`@p2g9(MC zlmeYVWev(5)wj`SjFiWZ)w1055|ECg(@x5%|e=ZocIxF z$hQC{*}ygX7vzmcn;ZC6f5hen{T!MtT7h0GTPU=5mc7x`e6)9xA1?l(wr42UZSRo4 zyhdD8i{NB0i#6e1jhL;K25kZeB>Gjj|{?2|aDO>#V>!1qtm_V}qhAKoSnd z{S3J9y@R*Di0-ZVVwd@BAr%c_dgzWSNvn39t$fD6G(#*8QGh8F3;H6~Hw#D7HwT^y zbAQFY$#=91Ioqj_0HsPvO{Sou0o@v)uYHQ$JEtr`#4#r+P2X#_JxC+aIOWiIeRIbe z^t3+OXZ$E!QKgRG`YPw$TV8UKl!vW(^%Y+~YKMY`oj5bhl-2kDLzQuxhW% zjP7m*a_3TG;6>VXnmXiC{*%Z^#v%<{DqtA~oW&(omtT2yK@9HzFF}7^{Yc{}i)!*i zSqMY$C~wgcW>B3yahIGNoFP6RMRlsKc<*`6@pe?oi@wed$Es=WAcw3_a9R0bSyo6Y zFbCtgE8aabQV6KSts0q`4I-flYXhpDrpuN3JNfx8PAJNda|c)7;|C0AaLT~3B?sW2 zdun7D4e{D*Y%EG3V%S;s$*Y!@fe>_tL&a4E;a%a4M1+qtO!7N+v;Wzj-tUuE2b0UP zbj`*^Asq91jJ9|I0s-LOK3uDUDhzf>bn4oSo&dIJH2T-y%6C!1GP!&X+AJVyQNcRQ zrj=bs9i1Wrg%V^H+XG)iUtF#af8wBn8gr80{`lD>LfBDh3?guL0vi~c17_2R=>ndR z;0;;RRKsp|uH#KK!E?&{=-L+rQK@_CEICV-iL>bEIsA5pu#M{JoZBC`uM#Z4(gTa{ zf$kZ}##-pH@sFYD;?T>%p_BFw5Dh$GzDIVtSQsw~QXxoE zu*YXTzKq|>Xp4lVNkq@5x@yPyCAq({ov=9dtA3IpQmO~|-e+XI0h?qA$)|LJDp4XwR6|<*LOXuK+A#1yG;mAd&0c5tG^C&SydJ-z4m8)JHZDKN8d!e*S-(;YbyWmKF964 zSc7bLhDUoy(?&7E?x-joSH11XE?3`V6)KfGcViBUy7UCE-1;U}8>N*Y2>4iOg{oPG zcy;mT&UNtl>HB5dc4X{B0TiW)M-`(6UFi>mCe1`q&F*jURL6Qh879xgiIlQFyr%MQ zzZ1XZq_I1IJJzhphp#O3wb$1^o{8R(sCn1lLb}^HQV*%w8P}1b{=ba2l)-Qw7a%y% zwsWuFSz4i$^3~GLV*-J*XlP!($oUH~19Vq=jUFSnn62_4yQ{05JNM6l9uNWB+5!-X zPV;pLpkOa+sRP>>I0Xd9F254t8Pg(K=ZC9Zxma_E=r=HD%SEpBz_MHL5~0gN!B>F| zxhVUN$qhW!o!q68pyHRysA}$TIe$vNIlA^?$9Bt>7I)qSek%{LLPw{F)WE0DuAivS zya1I!o?|dfIWk5Z;!*)?`neT6Y7n2a<$7Pw=0Mh(Bb8#zcen5MM@Ji|ah3i3715p8 z4?D4|hZbd;pdLwW6mse~E6YT{wk=J4r+!6w8%^*XW#qHFmD4J9Z47}N9Pq8>h*uwJ#oRnrb>&-$k^L z4<~gLpz1?hAETC{qxnDq7YDIrM?~}rYo4M+WaF>4*^TKW^!Y=t#sP@wR^wY~(e`P{ zcU}_P&5EWHuQcSZP*l?%CBX#{?XQP3o*PX8fwp|?D8c~hy3q1n6#A&KQ4(+>@bUG` z1#H*KS%E;|(j%kRcONwDm~6wjRRMG}a~^P+r`RlUI`bV6hzV{r08@u);I6%FxZ(3x z2Au0W{U^_81-vX*0A{gxegMJYKqD$B#`d2bHBc9ifmSh4DptXB{mqV(bRlnIx~Ew? zdWDMfgyhk&8W~%k19;y^Hppxqa6d~l-j30kO29b^2YC$q;HS`lW|+=SaUa+3h$GZO z*&I6K+JD+EJH?@qn8i6@sRZWB-ht|?i|)w+>WtArt=WJp>Wh{#3nSEHy0elQSKsKg zXEcu&U3e#z2CETf-s7&&t_z6-BA*AA^Frc2sJf+cXb*~hQXF>xE_xxIACmdxPLDT3 zhOW@F#(a7$hMfub-@Wi8-{geA=RKAhT6zq4q!FIbG(r+X%wcaE;e)%sN>M=Ya&piq z3VF=H6S!3*P%!Zh|BX6$@;X7?lZt09ctv3sz^9kzckHXy`qPy4eu-Grh zu`uHM3_fY&h!F!qQsXvbN$@Nn&M{no{2A_Lj(nX(TybRqb`xYH-w!KY}lh7lREB?u}g!0Ygq-jaaRYvOG z-AF`~(vJnt-M+mwAB*uTM#wiYko*p`RcEWAZIdu#qRLQC*1|a0Cb`cnQDQ&ZXwh|E z5Cr-R(}Vnd=`1w2*@rLJ*tM(S7AeGusACgOfr-${`x)y%8kRu)P!SP%-&jyih|FQo z3Y`}1149oDQ_uCDFwmC2gpr9&EoODXWrn{Kw=HNAG_-jCS2uxrpz@$pMv;lWCx>FL zXBJ-T^7JFk`z!c#q3pAbmGAIIe(FF0h}x&-lPec4FRR#e4W8fq22is=?34M;>x!TN zWt7A@i5t^1iM}2El)O3^=gg25tLP(_>-`tT0EMQB!N2uN`tH^RF0?ERkm0wqXA^}g zV@@coZ6x>iLbJNM*j}=09Qe%udEQK=#uM<)<(oml(=6dqHj!~nZkF`_$^;XJZQ=Hc z>p67^;pcPakq~2NZiH?`*0VI>X zYxN;Ey-T4rPZ9h=4pL%}3+z#;ZK9oS^Vt#i z`AkbXh13dMQwfv}pEUm+@rn4+BMIC7uK;Ulyt8qb59}Y>2evACWAPUbM4ZM|QUuro z#(rwq4G0)KNOWFFJJfXWkuUCpcCQ@c3m{4i3O2CTHLt)`KYO>y8olHjRKa4F{cm(^^VY2fOUpd1!VWOjIuu1Shxd9A@X+B&{yAFcWMg7} z2)sR@>E^uvu`v@hZs-`-`*_CGER(=4{r`4LzDha4JNoWHH!gM!EG{bjB_sZV?Wh0R zt^Z)?|Lo)cZ`1mkWw;4QF$egBxc>kDfB6yV6F@F! zfk$L90|Vb-5N14{zaj-Fc-hm%F{EP7+k=LTK;EGRU;T4A;uip!Llrb!XZUKzz?gT^ QWiiMLp00i_>zopr09FzrH~;_u literal 22176 zcmcG0WmJ`2)a{{>kPbm4q&uWRkdW>cq(i#9r9ncv5v032r5ovPq`Ujuykp!k?*IE; z#}N@^pS{;!G1r>&F+^Tg3>Aq02?BwjN{EXnLLkt;AP^`LL}>7pO?cHA@W(3~aSeM2 zV1Dd_xF?1R^2wN!ca!V9AwlQj-vJVuHVb(i6|1neUHjieo8RoiD!Ia_DYK zC6Y;9y>umd&uIEHxH><-dV;p;pptFq?uli|R6kZS{?tR@`rONSgxh|E&3@%*;`o{u z*>~6&MhKDAA2v+h9Ki=&2r=_t(5rW({^*#3iK`gkJ5c`rtAEX0sWzLUh4vLB$3#X( zCY)APRt^pe!$S1GJ>P!5LWhHcgN5$s?ad20>Uks!B>qN{_pb*7QgtCMKq#G1tbABt(Qj>Ei!{7}MYEu&da4R$gA-*w`2!xh*GO zpv=qLgz^5fh?v;mz<_KT&s2N+>h46|>({UU{rfjHHB~}HBD902`(11&lA4AF4grCa zzRl${D>_@-njiuM9>>3-3lBOiY$G^G1eqoZ1>mWHC@pTkc=LVqSE zCKeVn!6k`^i0J5ecZcGjTHoX0;*O;8)`9(FBN@$>>%DsQDje~GE~iIJO>IQ#va+&mUXPNJk_U$`zI1)DtK{r_ou8ktS!ab2 za{0VEv3r4l_HJiy&uMo&z}kB6zhBK1(vl1QV$SW#_hJ?J~cdG_Vr=_K3 zXK(J$lsO;HUp_tF=jT%&iOHt(-QJ#?NJ$L>6MqCZ3@#LG(d+J_z~3J>4=VgKA&*0T zW8)ogVx1N@$E^VzbMyV!SnO1fps{1!_x@gk195avB;XEvBZyM*QqL+YSrrr%tgVmN z*YzQZoYwF1Jo=(Y!G6lLTh^O%CU#?}#yA8zBL`O$UNJuR9EYw*e_&nZUb3QQ6 z&CNk{&CLfj6XWA+&)mV!tt!hTGW!aW&}-KISeWhT0G~E{+(v7z@9a?1(@W`URj6a$eh>r#RF;u_- z!|<5wmIDI<{(k!)d-ji(p8iL8_~Xj+lZl~W7Y!+9NGfbkLklq>p{Bfixzphn85tQ_ z7$c*t8uOVaZSfBT3?DvBf}jGft6A@HYxn9^2)GhXi_wN_?c)$ZE32cnm9UVIwdu+^ z3lkHQqXig**Vx$D7e`Aenwlyq-5}-?FddE-T`%{h7VGw>OO#Yp_??g59{&QLZ?tl- zut50~78dH$dx>AcGVmhXVhenmV{$SVY8MGUx1T4HF$*QE~CZ(Gu^n z5E~oYQ4S>hGZrrHzY=hZTP>zcR8(rp%Gmh$TqYx_AdM8|=YM!e@&EY~!@QeWu2M5l_`{}lKdAT*jlYoGrr>m>k^*r!8D}#=PreIl} z95Y0a#AXEqnEl~=4G#~`d$EY>s;cvg3lwDJg&K3bV=txX zG3g{dbI1Eh6cBYFDY%}livsfnUT;JF0Dk%itogn+IsiWa$E~fcT@<2?Bf!N~wJv>|P*r6wE&U@VW&)UjVA?Ky zg)>kx$IZp%$2)!=;6^Fk@5#va*rlYU4Ox>G_w6WSZuh2&td<&WD|vaL%kd#4Od{I{JVkj#puyt|*b?505!N}m?Z^Z&&*Tn;Eb#;7PT=6@n!}J`Un1J158WI6o3ticWF zK9JwhD1Y7F->=|9hZ#L7Lg@cldV$nbU~ zv4EZA9z%>l)m%YA0k8sakDu}J9Bgd79yc~EAGv8Xw6(R>)SRClZbd~!k&uuUjqK=g z2S-QcG&NJ$qI`WnefviJp;9^mYdn?PzR~$umh2}ADk=;#bbZ*g*XqGsm2lAOxR@9$ zEUbyYe>G|?G@P6`QieY|9nAiGFUDm_DV+%NbLV{lFcytcE;TJJEj6{eh6caK4YPni zn_R}n@$qqh11vZ+wX_~Gyq`kC!-;qtr~`y{ms^@*Vw8-GDC&ZMQ%vv2u$evsD+z?Z zA)Q3`UFusT_Lol){rwkgdUA4-KvvVdikzGr#12?=Y2KG)Qel&-v;a-4#JeN+1Z1# zoZa2AGGcWN-zqkgx8f?QxlQ%$d2$TI?|_wobzfC}@>3T3F?MtA)e}CE#J_+JnJyt@ zHVo#02udQMyn$|U-@d&s8ynjhG8~A*je1@({*_lZ)s=m;(HoC~1}+z1QP|Wd^h}Mr zpHU=s&v@e#dR>T#%xeLyUKuJy_(S`dRurZ|B#+D%=Y~sIZrpwCzYKR3^NTGiPSAxe z(KUG?{^-P!@3!FKD9pZzPkb9P=#3_Of7s@c85odbW+u7Pn$}|7R4s z#R5mH5JrXvvL({6Az22sH zc|}1*d1Ad`|G(WF)t-~puQR{C!LZ+s2OT@k%!z65#qu5oZ~vzk~#cdH4GZZXCRX zDksZ>Cg*O$vo;o%BnuAr$Gf2SpJA)!EGT1g%Dkm@o@c}G;EarF+}y-WMk6*oJPu|D zXG(Kyw6Aw;E!ut9K)vkNN5i+Fq@_($vNCbD9Q##8kDD@V9Ep!nTtpZf71gU>ktf&o zx8dA3hH3>su>Bb&fB)L8f2tL82QBV85DQPI`}Yg&KK$mmyz~cS<2eR0q}N=Auox2h zUU**{|Gf)R*(ibEXX-idsBHhQ4az!Hcr!^=g3NZ4=`2-C=55Uju{e$4)n8=)_%;`5WXdg`xXob1bj7?;x9- z$^rf!us)(;ZdG#!z}pLH8#6PZA&H69Y5cso);dPO;{yc(LXiN#4FYw#<(}elA&yS>&@c-pkYS55o2HR>QzruKU zWYBJ*b#V4RIWr>l>-bl@R!bElijRT|>FVBcIHK<_S^K!@_1Gw{^{_zfiiJf1ad~X) z8&`~}BbJcBI5JmI(1YX`XG1}l@gWdwBiWD%HX-2Naug=?~gc|j+0*~ zY3G;3QG&27Y9Ii2t$A@!Kte&0oTQ>$%%gy^)ufqpR!JPCHUkAyZR^xPjGX94xH(SZvZ5QG(h{zkdH1 zDk#XoLA?>Hp`Gc}%#3E4x@8-OU7BZCHK`mI1%(O;8T~`ed>>*Uif7hU8IMarl}Afg^j-7ME#h`GKO9StYV_Z+Fr zd_;)P_7`vY$ae}%6inUMt``dKCW%{DbEK8g>=qopZ0nD8B*K*5`=6Atd7J~^@mG%= z4&G|bF*gI?32@6)k&I4DvW8M8m;06HOlc)Zv$;8O_Q`+04T0K_`+)7h18{e)w>OTZ zWs>`KWdnD5zhTD5$I>-HnL9XiGwTEA574!98M^u=%yveGY(39=?r)2x`7XCJ*whx!XDt0$|=<#}CB*z-KU zeLLIiU*gtiD~;$l4C*(8ftY+7G5@z)WwR}NSgrsOH1P_vDZDK|F^PZ`@)8Y)g)~d5 zF%^(ed5jnS3MFo)DJ3b9!;HDXedi}*0xg}$>>5t->RVCq)!%*m<~0?y3GN0}HMO2U zLNcE}Tg+F#i;gDa;K;%lx(pT} zb-yoPsH=L%chju<>0-4bjqvq_^AjA|I72l4R69NL*k#X_i5WF95Dn!0~v3Pz`gM*uTyf6Bab=B`IR#w&l0q@fJ2K&VF^05~8IbJ8e z=ZA*zN#!??T1)rjR4qwzB+%9E_WkVAtYdv;S`b(JI_O9dc_49AX&*D%yfa;ys72+- zwlNh_iMFD%`};g#Se4t$#Ktxt+wz$zf%wwvLc#J8dqK&0A89b@u}NYxfd!f|E_-W2 z#Rk?UWfGQ_5cYOYcazTL1z0djwFA-xl2pd9dwTLdM;=ug zh24&(kWI3@q(AxhRx5#`VeNxq)=qLG{cqY#V~Vr0Ln35jBju(~k$Grg6wd>~MpC&O zJsP5aNE3funkZ6RxVsJL>OS4oQpf){`UNi24aA54jq53Nt_+Nt z+SsIpx`wj$$B~&C=R1e}kDgo<*q9+gWPg)}LX!!s*reY7PLxTRe#`Gh!W#Wdjf=bb z5B_}HFN65uQy?R4VSisfHGT1|tCBwt$_ws=S5(wpRaGqb-O}>>hQ}cy zhr*iMuOHTjQ$wRUpryK6zs_O~2lt=T8ToUV#n-R1twgdJ@M2=W6up_2*-Vz3>My3I zbG2F@kWJ=D$!A}B=pA=BIA#}S01D$&Iwg5xxUD8AQQ-nQWo0i54;~+dH#VG^)XOan zX5CaM;^Hbg&xzkQf(!ZR~looAP~njhfzA46Ni;S&lLGoqNC6?}g3 zsNzi-)-HE03obu->JB5Eo*w@OIk~#0b9v28Q?L_G*ru!+ae7*?>7K+$i&UiM_Y>n{ zAA#w_#l=4v3P8y*?;VFkzBkx7dIQ+4m;16AUI}TQ9o+$a$F$A4rLQ5;tZcVl@$`&d zQ=P(^8m|6%CVH;i&yb#QKhp`_i*NN_kDP7LLOTL4GhGOzUB6=}NnQae4EMA|0RN3E z4dc<>-KC+eZ7V8mzB0rmCTVWgPe6|}(@!dX7M0+`ST}IDAa8tQ<8mj4p=7xGtH+T# zLBvM{Fz-Z!K(w?-STLrGp-4YIYamLApCG?#s4B5>NhlacfQOE94#B&Q%$Z5wX0*Dtc;7O7m)YSzZx3J|0y1b8BDpyLaFocxpB4bmv%4&Ym$Y(%E#(FG2)Ndv2myIi*A>Dq7$VJaYjZ4br$_}3^mu++w|2No#UAC^iaIK zh-lW58Hl9qu#xfzD$20G#r#SbP~Og#M-Lm1E>s1PQ`VZS{mFH3V&tgR%RKH5lldX4 zsKqxlq4epCTYZq2f`Qa#czDO$8{;9L_hQMj3_?V2Uu>7YXNJ#Y{a3C%pkEztnCHP#Eb!MzP2#v7mK->P}+k{*b z2|D6(L( zSnVj?pLyTXVsy)pv|+Bcu`tl%ePgqJb*O_hW;&GEf{gdY)pg0jLd=bZX0{$fyHEw)I`&Tsl}^%Z=`{ND-O&4w`IO=ZY-^>AWc{~gfy2k)9buWP6mz_zBDS9 zZ_s%T4vJr@6O_c(u|lk@OrYw;$oTHyU#;WSLBFxF%yIOH;k@-686}wzX-tj;IZ}wS zwh|Trahv6p#Ty9;q!4l$GKm;*r19~GQJ?3e#pq}jLe4Mv_y?(+a>0VDE7X+mLc(kF z>^l?NoPmPkK7hl>hY1ezV=-v&MYyr#)Kt{qo*lOIjhh-c-FUW1jcw*Lw?38&di|&; zpk*{Qh4t{TnUg(Isxh&X-9{xxLX9Y!5vcGx*<8yX7P6crCO+2UjdpdldN9PO%)T;UHa1^VHZgI_si@@FF34pEo0@up?dt!+9YGhBzNVChI65YB z{j_db=?=S&j%F;=q@pAn|IsNKBaWkN#^%&lqrX_6X1^VAb=CTO#qf+d8cyzi zdg?%XcVhjC%r^lK8_zEeCpP{mhZ)@r@4rQ+i+$^?^`>Z7osS=7^|J;~Hxxd8GjrHuvLECBPc?nJr&m3%Ko1hyEhLT?uG~g&s;r zg+chU+Hvx4SO*n8ljA>wZ#}poqQEjSfj#jv2zWP_9d}Sj4S~cVwefri3MzwW_f2~{ zUO@qy^HDZi(gR^QF`81YPY%Um+jHH;7A%r9SIVPj9d1*`@?I znKk2ZD|RbOC2;E$j;X)9)62`@PjP=1-+~5KQxg%@(l-j-OzFis)Y@$TP}n%ap@s*> zu{%0$czWg~rtpTpIam9AQxtQshk=E`eY`#{qvBXzWImF>^gwud@QRT0PnKx8v-O}z zfIOiu7*zR2CA~7}{c|vR$&XX_n# zd(OH@Zte#{Q&ZnI0a*C&O}wlB7V|q_a`nBMBJ}jMt|jV2M5tcX9P;(yZ?>dfwPKPF z6M-B8g16@TtKRKXBO?ocZG)TK7w@lMO6K=A0j(CKDifHr<;uULlRV&HlOqZR%wBvK zJ5U=vrzO`s&PR@JZYT3KT`N4}hiVda05fW{1)>R58HcyDJzx66J~3oxx6j}$w*{SU zWEK`0{T9y00i`^j-=JdE`xyoUpA_t-cWo5;Ozs`&g1Wn?VMK_YTOu*LQt<^UyP+SA;x5=8D zV+{?z(36?I3W@iC*NH4BJ?ixFNz>D_0`m$1WKD6z)Koz=yrCfyhLUa=k^HTf4J{#| z_?I)=I3ti%=otywouw`{l@)8wl-O^_ql5}k)(rqtTN-Tv_qn%T8JTNo`b%*Z5dkcU zi+l3mI`}zAe()u&-($Z;(X9Jk$GL)Psd#oqX*p+Sw>1E@)Kq7qRl?d|`p%W6K$DOY zH!dL(U^)wWd?~3!e!}9CwSU7eXTtsd()dzy;Nmh`SO}+No!Jo*XUII?XEl?)1fbmTgp!nk?SD|twG&=Nx|{I-XaVYU+O9?ipiN9{9Q^IKzkC$(f8qepxQ3JX zV|y%3xiRWDGmhfoY{io1W`HCIsb=G`r54i zhxJtV;eW`pfgqH>S5Sg6=5d+8d;pKvY@bH(T6atHsCFTwYRyh2?E++YbVSe=aGd zVrcY95{bj|d%GaMz&jx!LB&d(-=g^%s{qg+`lk?j+`-DqdL%Rx2mfe3yRp5wyWEVQ zANz+u&Co>TiFNt+FU#22>hRIqp!%vEQPGYiB6WIv7Ubd(vJ8CnXge`Fv=rK_4F;KHM8g+|u0a)r95m^`8;S&+N);;N0DrKhPHx zd!)p5)1<#eFTXt7T8zd7@zAbO_4y3oxKL`#U0nXS&na!r$B_%zaS8VU{*z4XoIw;) zpnj8)d0Fp-U{T@X;lZ@GJwM&M^OIaqy&OT6C5hRRU}wiC4hOO*Be`Cp<-YEJ8j2%p z&^xkPXISc}(6?D@5647G`-KSetbIj5cbXpbrUWSqZ5w+kM?$yOZr6dRgusnfhmv%N zuE#Qk_4M>oXH-;F7HTc;r{1C82?NAvR%mWUD#M!iHW_&-FGYlGxm|8aMKQ zYJQ%aH#%`v*YmL^h7wfYtqdNVR=v(2Yn@x!*?a6MO(tj=ou-XWa5_5bEd)--R(HXp z83H74w%GRo`foXvZE(9KpCxo2xpJv;=p-a-=Tr`KT+T4k=DMw<=} zsE7q*@tFmsMY7qmHjh=@+`LRpiw^vsmB{}5SyEP^dX2yO!T3jQr5)gowIyEV75*wd zkTTlBSDLuX$duO|BRRPYD5S+_-OLl-+}s4L_C)J*m>SS`04d0Qb^i+NE83Si;-Q4J zKd|}|(Nohvb4qNi&X<8Y%c1=lWMh4IG2>10uzuY>b%747(PJrc#PQkO1gnr4J? z@iKVrHmitu$y!>#M8X#7T1>>E!68I$UpB3Mg;+M-U!`a@sObdU;q}2>%z*X#w#)q) zPI_rc+K=v6kCDQnJJ&DCJDi3Aj+Zx4fVjH4-blw;*|IBTNE(zwkPq74X--s6hg4ua z*je1im}n}>7R!&&XHVeE%%gc%he&wnt_IZXi|fZgsh03k6tirHXDam+RUaQG$WsIG z#A*HKPe8b(hK{1*IG~otKR?l`%FCmlJu0`}+-QmQo`AvrhuwYBi?A2ZiZ53Ojn~e; zUjSU)iy3#Dz_6GUM?*tKRJ5O?JcvlFC>8&nqv%LOvcxwKAM%Yhbn!|BkK%0Ztc-<8 z$?<}HDDb)w#)hxSWjjG~Z<`4PlK*>RL%^f{^k8lyl6ZH0z1;RapBIY#HpkFue}6w9 zV=11OPPPZ<=8~=te|;)^|M}YoesO=VS4X0e@|u;7blG`eTw<*uuZ+D?3vl^F5GvtV z%YAISAc3EPw$gh>+IcdCCy}C|EbjyvEUeq)zi*_S6yT)3d>6#E-eZ^EJm2$m+k^?@ zd>8yf%k4y0Ph)Htk8NYQ?W4oFF94`27S10bx&wD>>T6X8;!SKe~Ae(~xiwmyj#o*qr{K`;*`1=BV+^|QMAg4nK zmF&9tZ&+u)(I$WG*oDiIec;(wmv+srYb?$lyP~5onkuf-aP*qs)wm{w@gWnv={h_M zfgw+rolPXfN4Y#%B(~KpHZ47_K2j*Vb5fzn9vA&id@<)y@$cU`oAc5PCH>;tSav~S zxg^P)!+9LJJYvHNa;QLvID{H%5f(^0AYY+SAd*lHP-IYcX{o8&EpAPE!diK<*`cA0 zYGp{8XF)-U*7M)L;uk=o!aPiua#x{-km8}jSd57$EpB!xr>L=jVH2CMJ` zj;Irpyndw*`RBwIy64=wdd!u(B;?w$MiMLZBl*$AW^LzhDvVy8RwMS=N_q|CB&X8u z`f{HE_ZUsQZk(K#F^d@j*lvu(MZE&+d~?}e@bY*NoA59$}h^P zuxcxX_jy|CBDS1*J1I;?T_|lW(X&iw`tC}Q#3x!>luB|7-EVXGYvmSs5vOd^h+)Vx zVSJW)ih}5{jGVW+<~`IZyzei-3b9J!lApiy5eK?sN0j>4^ z;TE}0*aJTD>D>!ntSzPo&8(c<%}1g;oyLpRC0?Gj9Q9&;!{$)g0bizsy3vEHu078gw@85ka)GbL|+%wly_~ z)SK1ScNQk9_g}rLZEX#AbmF2d%*xH3!s0Wbd03G;0ds}Li=kVpqZZ~k$_>|l(xNgl z3fx5P<6Aejq?wbIg@r>|rc4uxPCAiMls{*g>$B~Gdv_5j-cSZe$750%;T4%vSDp_# zVYVRK1A z5EW&Ztvl}hYKN9)F4|U&oi6!1PF3afNl7a2oT<2ouB4E*FrNeoc`&*kQ(u3bj0|+S z;B}i5=n#mapk80q+?<8->Yb0}v+w&Kf&G$_vP+VjGslhIr+g4+O?G6MR}gAy15CkX!3`+RKTL6kBVp!pZiHr(1@Zw8Xv7g- zPLiK82lM3If%Il;^MiVEjzJIX@q!5hEv>_Pm!{k(R7i*@ET$(Xzc_ikPi4}PEGm>NDrz(S zMo{84Us_t4^S4V>)TrN3HvQkjds13jMp{}rnu3zzp^|l6T1D!vv=JKH*!Bt&Lu&_;?+1a>={PK>@c5-%2|ZEUb$D7~!c&Ni(x| zu?d=$>YmH3EwM4eS{3WEK!{LM+z3c^Q&WZImV3~%vhzX{S_5rMeR=sLpr?}9P$7a6 zrq7LzFsj8j6HP0eR@vc%&KlA`T*mKi&zelGhJrfoAdooa)691xt~s$Ic6u$1lOisz zwgP8l?2a9+o*pA?mR%unbS6)8ES1UxC3+ua>GIuEXv}_T^j-gHEN|BG7vJ360388< zS422*cc%Ak$W|i)cG1z6hW6=hjNQGwu&~sMvx7bD1x-bP*LPf=-$c6Xxv=3DKJyNt zy#9AjLlEw?H4t}la*~~${qXRRoJ>F&Ljw{&6O*-tMYHj6G87Da^$Ff5qBq(d?=Rk` zb`QKAW?$3LO63Al0>H}sDZ1@l`sH0$wuMKW9C3VoCm-AWpl|`hnL%Z2criX+SXi=T z^KWS6__}e8{<{fB<@-i-UwKuPZp}X_c@4LT?s`in^Nrbsg%Pr4&U!MKF)cA%f^sE& zf><}&>U8~mHrq%;vkepDefg;ADl6E%`uhKlmP_dA+>MqR0d&|6=rUmGN@2og;B^dD zG1%wy;%Ls#--!i6H0h-A=)Yu>_|hlhCqQXvx$+b%jq7?rJ<})tx3~9)pig4rP<9RE3}XbvW_)3NgL zm6)p~y%#G+LBZyFyuamFRf>_6rpLtmZn+SsNUh(|L7Xd#dVO7I<9LYoE}h5yYB*DP zN?54J{;r~O?~L)u^P}UhkgKl{N=W&fe|`e|2-a^jQ4R6nj*Cp2f6M%y;YVRtp83BM zpt;ZyEs%C)WzuNF*ZOqhq25AKL&?J=BG?f8@;4!@p{`TPbJBJ{&l!*E&Q&x$ex>`F zM1FG9dQcqGUP^kP5WA@e2kkhH2`E;DRiy^x^M7NV4|d^dVin&F>9abK@s1!EgBs{V@=m-kG|f z#>R+B+1VI}rcYlZd49m*;RQzq)mB`g0Wov9Rn%$<2ZP4|Ha}J8s(kW#m>b1LB7fr)+ZBau9Ro2N2oH8X(`QgCS+_UQR-xX*+NPVBNRIG|z4$Crx z4+?7%@_DCE zYr7Z;GmfqaIUB|Ty`3GWPnw2JUK5&;hv#=;sMWW82!xVS5@@w{7t}OFL;%}Y5A>UmU-{w#L&Xq? zurQpAj42jY4v_0{->Pe-uukq9Nef9Uo{x?Du;T zG5tIPn9=J)tzWyLbc0EEFP1{zbkaa{r-i?F2g)^62OZ<5S}s9I^8EYfrY(DHLPOsw zeErm=u89H}LKQ!*+V{FNNuc}*7zOW3rIP&STw^fSNmyTp=sIM4l(K9+Qmz_M#f1Qd z1YYt_rBMk!sZbjd79Xa~e_A20lng%0FK8oSZkj)AkzT<<2axsL+rA1pe)DgWTdU!Qp8l|?l-gg zF4qr(mDWLQA6#j8mQq~Y@Lr7P3(Ab9)<3g4iyr38%y-;CE|PVUgIDks!U*#NRvf1O zQs+2f9Em)L;3&-Plz~Mm)H_A6om;FXdce#=lXJNN-jD^_?{-khmWEu>?NdjYS7D7m z1vx#x%Za@$3s6Y)rD`=q3$EUxuCD`x>T-pGSik?)Ozs4iAJZlvV5*@(1$7W$#`DvV zmC9}pQ0m+MG6axO($HjO3E^Ur#l}x77NE#BBqo+;XCo#(RP|QtwEj3+sLLlyryfEH z8+#o6rfzPT9``k|%NfPkITW1a1UIBq$487BGWgLn0A ze}cWYN0p)#;G?z=mtEIIj5Ovlyu!}RjLn|pWVs&sOYHOytZ!md%9EjfV$CaXi*U<<*_1BZ>$;nOsM&-CYQu{G6Fz+nD?#?UXCL4LG zYM8o%B`~wHgx#HRarX*Kx;**lMGWxSw=}=eg)K`JuKjbNM3!ACxj7X}c42>+pPqzN zw9$eo@2M}$5-vmI!wyDWd1UF4$a0)TTpXCGxL*rpd@MmH6Y>TS4bx^K_cAIL8%WB- zgTm9l&mR^rs;lz7z@$zK2m%BPr21=^R{dDM;wXRo8Lj5jrizaYti z5@-ER?ySS_`0ANAi!&Hqw4ge58+cL|rw}Yh+HITnHk@=-q6BvOxNsU2#L)ql(}5Cs zwe4cab=a^&8QC<8xno)2`f5KJ!P*@6V3@d=2?~OOYvbJai)HrWxmGrT6uD)%(13YP zLsX#QD6e`=!s(RwqcmWA+@Bu&e*U~HuG2gt|$`DXHT;!HkS4V_6I2y^Ox->Z-OR1;GpwMGTXJ9uunCyvRbX;k=pVzl<9=s$`Jm>to z_*d#&TZ)L+oA;}V5??+pDXVFziN+2a69-e@KLqG;iig_IyBQ1=7LBg7wcWH8m|1=T zxo9mvU-bU^9`wePY*l(No{pDa&$qp$PQ)U7>bX+6poCmV{pTqb`(I~HZ>&L?jI{TJ zlTgi+pFJ(q2`?@|3985*9VD|0yFZO+`A$b`sDE2KN_V~ZW{z-%BF}((~l@;iI%g6t;lXOktK16^Hg@?7hX zEiI#$-bxKV0g(6$DnR6}_IUYx+vbtSKghsI?2zE4PmU|1vsgyipYG_5M5Q|%9&%z* zZ+C4GAQSQ&NzFk(%iY|nu?TJxmK4g0mbB#MMC4VVc7Ay1xjI}>_gnk?nbnXL0<;wm z_e}nQ)4c6?nNBZypAw(~;Bv>UwF>BsBvfT2I2%j93YM9-nM4?vcU zDxjeH)su$N>gZ^R!2aJiFn9+%STMY65spM%|G9A~6?wC`%;lrkmS&sP(q?y8`zYGM zAxqPHU%=UBatI5Th=L#ai>3^Z>x zHn5n@8vge=L>tnBttO+W+1pja5x^> zE)%;x`eaBhBKj#$wgiJf$QzVQ|M~LembFs@aoNB$Uf<6!J`^j*N6VrTyP-|@mBK+I z-95F6!Qs(BS8!=^0#GMFO~4VsQ;o$s2~m*k(azzNUj=gnnWPspFQXPqB?aI6>rXPM ze0;yEC!qXfL;!o`|2y0~ZkilufZo+?IXlvbOn6P3g%5ke#BUUIch;&j%M# zdGw-Ti?5=lhng4n@5!t_dcO$ww3IKJLN^T&QT(IOnb|FK#?Z}Py--YOh_EMT-}&8j zAMg6Hksw;<7jN_PdP~&eVw&n)&-X7bfQX~!!A+{O_%1P~%iu(GYtgX3R(C5cLT_QeGyzEU)S_WK1$&mDH1q^{! zLD>JTm{DDsDy^ZMYv~_K#l&}+o}0^;N;sxPLhcwuuC;674 zw<_CIq$WXv4s9}=Y;DB;?Qni(ceezSM65`w1E}g)jW>D@0ozUR##2o}6<%8#giDo4 zosBqR4erY@Q+RzH3}dBJ;73NH;-|~Ky6bIuw?~K$4?Uj`7vdu${Dc5#!SQgF2@j7P zrPW;U4t)LCn)Q~C59s;STN){VGQ{!48$8L-bvxm?Y#`0eF3wFGm7Hw6O~%7u5E+I> zT9Hq`Cg&o z_Msk6(e=#C+|E`Us+HAxd?ROJfsc_eVE&>D9xizVLslR?db;G;EGq$2AU@}74ofp% zpuu@jnM{sc?!n1r2q|CyvEEQU%B+1EmK|n%hZYg@i+Ek%@X4?L95BSTP*6;Y zN+yr@OlkcV{qBUFI3!rh#&$QikY{#^eS0t={?)d%Ty|Sb;*Q6G`bAH; z+4JEj+KX&;B<)u&c;D~kCo6kXB%2Bj26e zuqdm3FJt=9R|dqY+7S_;kOL;{dBIoyXecB`Zq)FZ{Mb%x?g`UXVz+j zy?mYcDSrcqL!wBcWBmHW@tI#_u}o#!TSIG|a%I|<$H&A#xuO%k&LmSwSDIgbb>&o5 zm+`@7)fp!U4JHn0rqtJ8qzWxmzUe)9{BLQVg~a~}nv}G>0*Z!4y$QFv=95NJouZhA zYjEb;bFJn3u&@-T!@C5bVE5|?R9!3Gu^*m_rXL8ck1HPU8s-+f)ok~$4UIa6Q%D$= zesq#fdcBlFXv<~3dMDJY3aZOo zmh;Xy+an!$a_Cqvm6gL>Z-xFt6|iXma9zEf8@=VuOdf4zsen}m?CK*JRUgk^a>n;@ z-m^Ar1)IgUdrw6{kn$f~OcZaDtaF@?h1Bu8x_knAGSGaZR$rt+2yCvbK!OZv%}O;bSec&T?CUrEmA+gz?hni5 zifOeByDa2CcKxyfDGg0W8t<<>gwj%Z^*&951)$Qp+}}P}_9W-ILqoXjlyDN=+5*D1 z)``4@tK;XAi*95@r0*v-J9Fn~ox;Kwu}b-CVkR%j28FhasF zN{<+fY>8}1+PFu}?J>3gH25YcgdDx&XPUeB*X7;<{{Dg)AH6a0g@|4l8=hJ?>h^WG zc1j_}lI&wmDw2JTY{Q5!82dU3Steu`W|S@aIt+&KobKnJcz$?(nqTIe*E!d@&gc8N z&h`F&tN@J;YG^ghNN?ZS$xq32-Ptigj)Yh3{KXqxYB@J?x4`0U-XjQaBn0AEOZrjx z7f0k}050fiWCEiyoEp%Kwf4tWP3(h8_UC?4#A=?RUmw@Ed263;z$YU!Hv< z_u)ge8!MpYP$-6(N}ZSW?>RsqUA-?88)hA9Xw)<|mrR|3-tEN_0cJ_1k zDohI-8IZtdp=ZGO_s=nSzVQ7r%LBZAdy5hNe$oFaVd2G9TA-BCFahwoa!{wa;a`$U z22KFLXU8xMJ>KMe)aF|;s3{Qbt7yGzo|)^_hXW1a906zMy4=ko?4U9WeQrCX>97ot<89)9A?q3U&M8ja-7Y4d9MM&iQD3aGm zLZa>ojfAzjQoxy;1}I4I#xIHjH90w8>t$eoK*X>nionLq%nfFmQ;Q0Iad1ud-f2k| z6Klu4%G5{ZYigE?LC$?~EeXPfNl{UK6X_k~(_ucUP97QxCJ>eMi<>>&Nv%pJC#H`J zD?F()L%t1rXTN@Je*eB!SXd&-t+bTDanaG6kUlYyi$iO@925q-!-{g1`bUz%V25EY z5MG=%2*kxDmlLpE{G?Y@`QyT(vnP%?z@4g82U3orfnEo0&=8yYnppStm17 z7aJPZKc8=C6ua8hI4?IodTQ`&^^5;T#=U#}qyWdKfr4uDe^y7zA3S*C=N}t$lZB2+ zL_SC*3?LwnO$#vKN*hv z!yw8an?)RgOO;*s^r)MhEVKG#-(T>Si1B|14F!i?@f9&%iGW z+7S!O5pcjl)gEqa#fVBjhx!phOifYqp?9ka3h<-*ti#EVtsx3#q6E5wAEEpI>wUD`|sjX>j&%Wjqvp_0Pvo-YX5KOCE+Sb}>O@ z)4gzrDon{F6pWUWZRciTVdnh9$_+`^Un9nCimh*OQeWb=!-S(MC76>R>c3@V&N0fA z8pB|0v>&{5eq1;~bW2ZDkd$C4i_64xdc2)^x!>TLzf{LFrvFVh5gn-;HEAUt?q3ZWgsDHFD;GEI^QuIf~#Ab z!M6v_%{lGw!_T4eLPA4dUiqGcj-c$hRRVO4B~u-vcPihjYHH(Wo9`~Jj)VaDSGt-{ z-A)Yp5_8sbkKnm}2U6c}ab&Nph1I)E5#^19!?Q!zwHMnw>nqjgi|xquAq=Tb7UMYXO=ZL z*Q3AjhX-{#y?*=Jnb|b-%-kNQk(XCPC0@2s2f9K<8x(n?8kWhLi4E|L+dDFLe|ELn z>gkgr15G)(7J09j*7Q9-i0gg+cu(263FW$ES)43S7sh4m*p# zfDN>F@96H`tGAy)nu*QuYR zM|60Xp2HFmxnU*Hm`COgRDRr=0B#ID>{vHpayLlC zn@5E(DfkPeuTC!?d1|euczcXe`ntd`iZ`9_x!-Ve^D8J`)6&M*)+ry2nefhkaer3o z{-|Jm!Rcty_Ohbl0MK#g{iH}*mCT)q#W(qU&drr%URx_m%aA+td9I~(iJpFNf8R3f z?A#j;{{|1TJKBxeYV-DXCKRGmfKaL%%$1JbBI){$>?_--M*k;nf;kOd$j@Tt_F5vh zRAy^FCNga{-cD8iqvv8>A6;Q1i`BOVBN41>+)&PIhB7aLhug5aO8Fb3NW{!c#*ZK0 zJ39#>#C7VZqopOYlk#$?(c~m_rcuhaftx)Y6HsaN2NywZR*gh3TSlif0%5zBn zXa{tv=Vm}57(F%bys}VEN#aC(m{t!T>VOC}%XC`{yhd@Ef|BpiGs6#v)D-l7Uvh9| zB|^wR5>QTIm}`wyMT8oymuF=W3T0(8)9q5Lu91tyI>JLlaus|q?d?^x$+|$~j1jAd zJJ$AS^Mfz>43U-9V{Oepl;^3ObO#P(uhqd1mz=Q+P}F<=duGXlF6XFfZ2H!zcHLvD z6H@H})>?dWB%VjhsRsNhGKO+KBEQE8^1@1!u&;MdNT^2PdXiHSoDIft2-hp!+ zxV=?V&a!duiO>D}mg(vDHYR_rER7eJK-oCu-JglBuZjlZRivt*dTSG})Q^r%HPbRJ zGc%xn=R?GF$9%}{dB%8{&E@d>kyAkNmYyCM$UY8bX0EZS^UC#9k9zx1jDcZrv!?dV zH(Cu13-C;XgalC9Za!_u%=Dk{l@eQ!m5(bi8r#{Mh>YZpD7XS_$gOPQNC9?pV;}CC zSX%6bhkzC{}hcK%5-)0Z)~gEwli-?`MMBQ`ZH8hT35;_va8 zmQKey@66|i9Y5cG!(iUpHsDelr2GH|YxVH$roAL9i~1}^JULjABvM{RHKw$f(03+j zbW&Yu0A@x^%=MF!)YO{viP8o+Jz^d>xfq3V{&uA+M;`ks>J9>7rxS0sO{9GO{CP=3 zLki}Cz~?wIWm#6{78@I^ynAO!U;kQM9FM$rK;NJ}Zgdn#)#}QludNoav_w}I?CyF; zf9)~1i_vvm(tQ^X)Mzlc5*0VPEVwnN;Pr7Oo@aUgK6@Ne#6(p99IGjotQ*@mZ8bRN zyMQz>;Zt#6B_DTeN`%vM-Wjq<%7xs;e%_e`XgT}gt%v)B zOuR?UB?Bnh7Z)!SH(S~bM;Qn6F*BPP!iY}l67TxDVn$f53aJklc2=xc&%PF3e%@TKzV2Y!5Gm(A7H92`(l+?8WAEC>50jn1!}m^CnCCfLP(b zo6G46@H#lg*>7r2JOv5#%a_z1JTn?(Zs(kol$9w)Aebd30~*mWr7C_*_87?o%xLqk zZ9ySKgItZcon=M!((`FPzMB4i=dv<(JYLV(_?sqS*1PiXkXI?3d?FL8*#h_PMUpZ& zl0(OLI$-OY%BOwF2|8;|PJAJ74Q{dU~z-Lrx5X82_)d>;4 zJaAXlF)i2r;P`e`#U|2Y{Zz7yRCi^Qlj7H*+4Reur_@|_0|OuLy7D<-9P*M){eOR5 zq@qDnQMv?$1d3lJ9nH3_udgTt=DE5~J$$$;2wr)iu<5fXvyCeUVh_ALJ>wc1x0uw} zI5^~fDuzgYFfSIn%zFwUtKz#4Jf;{c(yF|7_gZ*o$MUjR@dPz1Q^iTYmAJ* zC&eOGRs%-f79c0b`{KCwyI!ic&`q`-eAvd6LVbNUcnyBi#0&Lh-epSb3 z-4;ANw1|(N7#x(95SJ+`+Tm9Y0&t$eKHd1P$2?r6`$1712J5O4O$#w*)vi*!$^5;mMy#-&55#a+6?C@vZ@g056YqLl47&0L z@H5)$>o)rO+3v6qGUefe)QltYhH8&AHw5(RH;YQAG}_y-!Q(?#`h;j8aqs--;$mZv z8`AmjgH9?CNct*YD)942fLa+~qN#wj3kbwT3oJcAo%ex-0|<0k{eS-kIDb&&OTh4f mKvw_{_5X+b-x#qU7ZlKBI~7{!%mVOaKzdrnnke;0QU3!T($$dw diff --git a/vignettes/ii-modules_files/header-attrs-2.29/header-attrs.js b/vignettes/ii-modules_files/header-attrs-2.29/header-attrs.js new file mode 100644 index 00000000..dd57d92e --- /dev/null +++ b/vignettes/ii-modules_files/header-attrs-2.29/header-attrs.js @@ -0,0 +1,12 @@ +// Pandoc 2.9 adds attributes on both header and div. We remove the former (to +// be compatible with the behavior of Pandoc < 2.8). +document.addEventListener('DOMContentLoaded', function(e) { + var hs = document.querySelectorAll("div.section[class*='level'] > :first-child"); + var i, h, a; + for (i = 0; i < hs.length; i++) { + h = hs[i]; + if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6 + a = h.attributes; + while (a.length > 0) h.removeAttribute(a[0].name); + } +}); diff --git a/vignettes/iii-cache.R b/vignettes/iii-cache.R index 5d720bc8..bae7526d 100644 --- a/vignettes/iii-cache.R +++ b/vignettes/iii-cache.R @@ -100,14 +100,14 @@ clearPlot() Plot(map) ## ----eval=FALSE, echo=TRUE---------------------------------------------------- -# simInit() --> many .inputObjects calls -# -# spades() call --> many module calls --> many event calls --> many function calls +# simInit() --> many .inputObjects calls +# +# spades() call --> many module calls --> many event calls --> many function calls ## ----eval=FALSE, echo=TRUE---------------------------------------------------- -# parameters = list( -# FireModule = list(.useCache = TRUE) -# ) -# mySim <- simInit(..., params = parameters) -# mySimOut <- spades(mySim) +# parameters = list( +# FireModule = list(.useCache = TRUE) +# ) +# mySim <- simInit(..., params = parameters) +# mySimOut <- spades(mySim) diff --git a/vignettes/iv-advanced.R b/vignettes/iv-advanced.R index 92af1a50..8a376259 100644 --- a/vignettes/iv-advanced.R +++ b/vignettes/iv-advanced.R @@ -1,13 +1,13 @@ ## ----memoryUse, eval=FALSE, echo=TRUE----------------------------------------- -# if (requireNamespace("future", quietly = TRUE) && -# requireNamespace("future.callr", quietly = TRUE)) { -# options("spades.memoryUseInterval" = 0.5) -# -# # run your simInit and spades calls here -# # sim <- simInit() -# # sim <- spades(sim) -# -# memoryUse(sim, max = TRUE) # this should show peak memory use by eventType -- i.e., summarizes if multiple times -# memoryUse(sim, max = FALSE) # this should show peak memory use by event -# } +# if (requireNamespace("future", quietly = TRUE) && +# requireNamespace("future.callr", quietly = TRUE)) { +# options("spades.memoryUseInterval" = 0.5) +# +# # run your simInit and spades calls here +# # sim <- simInit() +# # sim <- spades(sim) +# +# memoryUse(sim, max = TRUE) # this should show peak memory use by eventType -- i.e., summarizes if multiple times +# memoryUse(sim, max = FALSE) # this should show peak memory use by event +# } From b1f3f608d222cdad75b9910e8f9405dcb851fd28 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 2 Apr 2025 09:17:59 -0700 Subject: [PATCH 086/128] spadesOptions table --- DESCRIPTION | 4 ++-- R/options.R | 5 ++--- man/spadesOptions.Rd | 4 ++-- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index eb86376f..0b0553a6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-04-01 -Version: 2.1.5.9018 +Date: 2025-04-02 +Version: 2.1.5.9019 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/R/options.R b/R/options.R index 187af75e..4d929e78 100644 --- a/R/options.R +++ b/R/options.R @@ -67,7 +67,7 @@ #' \tab The default local directory in which to look for simulation inputs. \cr #' #' `spades.loadReqdPkgs` -#' \tab Default is `TRUE` meaning that any `reqdPkgs` will be loaded via `Require` +#' \tab Default is `TRUE` \tab Any `reqdPkgs` will be loaded via `Require` #' or `require`. If `FALSE`, no package loading will occur. This will mean that #' modules must prefix every function call from a package with that package name #' with double colon (::). \cr @@ -162,7 +162,7 @@ #' undesirable for some situations where speed is critical. If `FALSE`, then #' this is not assigned to the `simList`.\cr #' -#' `spades.switchPkgNamespaces` \tab Defunct. +#' `spades.switchPkgNamespaces` \tab Defunct. \tab Do not use \cr #' #' `spades.testMemoryLeaks` \tab `TRUE`. #' \tab There is a very easy way to create a memory leak with R and SpaDES, @@ -240,7 +240,6 @@ spadesOptions <- function() { spades.saveSimOnExit = TRUE, spades.scratchPath = file.path(.spadesTempDir(), "scratch"), spades.sessionInfo = TRUE, - spades.switchPkgNamespaces = FALSE, spades.testMemoryLeaks = TRUE, spades.tolerance = .Machine$double.eps ^ 0.5, spades.useragent = "https://github.com/PredictiveEcology/SpaDES", diff --git a/man/spadesOptions.Rd b/man/spadesOptions.Rd index f9004063..cab70338 100644 --- a/man/spadesOptions.Rd +++ b/man/spadesOptions.Rd @@ -72,7 +72,7 @@ Still VERY experimental. Use cautiously. \cr \tab The default local directory in which to look for simulation inputs. \cr \code{spades.loadReqdPkgs} -\tab Default is \code{TRUE} meaning that any \code{reqdPkgs} will be loaded via \code{Require} +\tab Default is \code{TRUE} \tab Any \code{reqdPkgs} will be loaded via \code{Require} or \code{require}. If \code{FALSE}, no package loading will occur. This will mean that modules must prefix every function call from a package with that package name with double colon (::). \cr @@ -164,7 +164,7 @@ the name \code{sim$._sessionInfo}. This takes about 75 milliseconds, which may b undesirable for some situations where speed is critical. If \code{FALSE}, then this is not assigned to the \code{simList}.\cr -\code{spades.switchPkgNamespaces} \tab Defunct. +\code{spades.switchPkgNamespaces} \tab Defunct. \tab Do not use \cr \code{spades.testMemoryLeaks} \tab \code{TRUE}. \tab There is a very easy way to create a memory leak with R and SpaDES, From b537a96737609a94b5b8e2fe9929247c9582ebd4 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 4 Apr 2025 19:37:00 -0700 Subject: [PATCH 087/128] Bump version of Require needed --- DESCRIPTION | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0b0553a6..14fbbce2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-04-02 -Version: 2.1.5.9019 +Date: 2025-04-04 +Version: 2.1.5.9020 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), @@ -40,7 +40,7 @@ Imports: lobstr, methods, qs (>= 0.21.1), - Require (>= 0.3.1), + Require (>= 1.0.1.9000), stats, terra (>= 1.7-46), tools, @@ -82,6 +82,7 @@ Suggests: Remotes: ropensci/NLMR, PredictiveEcology/reproducible@AI + PredictiveEcology/Require@development Additional_repositories: https://predictiveecology.r-universe.dev/ Encoding: UTF-8 Language: en-CA From 2bffff3c6cd53ef363c2eea1ebde706774c9369c Mon Sep 17 00:00:00 2001 From: ianmseddy Date: Wed, 9 Apr 2025 13:43:00 -0700 Subject: [PATCH 088/128] comma to remotes --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 14fbbce2..a16f55f4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -81,7 +81,7 @@ Suggests: withr Remotes: ropensci/NLMR, - PredictiveEcology/reproducible@AI + PredictiveEcology/reproducible@AI, PredictiveEcology/Require@development Additional_repositories: https://predictiveecology.r-universe.dev/ Encoding: UTF-8 From e9dff1fcb93d82844b09a8905df9bc68f321a62b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 9 Apr 2025 21:48:25 -0700 Subject: [PATCH 089/128] test-downloadData workaround? --- DESCRIPTION | 4 ++-- tests/testthat/test-downloadData.R | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a16f55f4..379a7ea8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-04-04 -Version: 2.1.5.9020 +Date: 2025-04-09 +Version: 2.1.5.9021 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), diff --git a/tests/testthat/test-downloadData.R b/tests/testthat/test-downloadData.R index a3d11971..185da0d8 100644 --- a/tests/testthat/test-downloadData.R +++ b/tests/testthat/test-downloadData.R @@ -40,9 +40,11 @@ test_that("downloadData downloads and unzips module data", { ) a <- capture.output({ - t1 <- system.time(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, + t1 <- system.time(dd1 <- try(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, files = c("DEM.tif", "habitatQuality.tif"))) + ) }) + result <- checksums(m, tmpdir)$result expect_true(all(file.exists(file.path(datadir, filenames)))) expect_true(all(result == "OK")) From e0c770b880b62539d92ce5cb34bdf3c2b64a6934 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 10 Apr 2025 10:29:27 -0700 Subject: [PATCH 090/128] test-downloadData fails on Windows: use GDrive instead of Github links --- tests/testthat/test-downloadData.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-downloadData.R b/tests/testthat/test-downloadData.R index 185da0d8..b9ffea4c 100644 --- a/tests/testthat/test-downloadData.R +++ b/tests/testthat/test-downloadData.R @@ -33,15 +33,15 @@ test_that("downloadData downloads and unzips module data", { objectName = c("DEM", "habitatQuality"), objectClass = "RasterLayer", sourceURL = c( - "https://raw.githubusercontent.com/PredictiveEcology/quickPlot/master/inst/maps/DEM.tif", - "https://raw.githubusercontent.com/PredictiveEcology/quickPlot/master/inst/maps/habitatQuality.tif" + "https://drive.google.com/file/d/18roW33nu0qJ2ybUk8SG1WJa-HZq_PZ12", + "https://drive.google.com/file/d/1wpkVWeXNNfFaDQePNw9rwA6sFGtFCd2B" ), stringsAsFactors = FALSE ) a <- capture.output({ - t1 <- system.time(dd1 <- try(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, - files = c("DEM.tif", "habitatQuality.tif"))) + t1 <- system.time(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, + files = c("DEM.tif", "habitatQuality.tif")) ) }) From 55dfc3ff94ffe530e9761b4a805fba4fd62abef5 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 11 Apr 2025 16:50:24 -0700 Subject: [PATCH 091/128] use httr2 instead of httr --- DESCRIPTION | 6 +++--- tests/testthat/test-downloadModule.R | 6 ++---- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 379a7ea8..dac778d6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,8 +14,8 @@ Description: Provides the core framework for a discrete event system to URL: https://spades-core.predictiveecology.org/, https://github.com/PredictiveEcology/SpaDES.core -Date: 2025-04-09 -Version: 2.1.5.9021 +Date: 2025-04-11 +Version: 2.1.5.9022 Authors@R: c( person("Alex M", "Chubaty", , "achubaty@for-cast.ca", role = c("aut"), comment = c(ORCID = "0000-0001-7146-8135")), @@ -59,7 +59,7 @@ Suggests: ggplotify, gitcreds, googledrive, - httr, + httr2, knitr, lattice, lme4, diff --git a/tests/testthat/test-downloadModule.R b/tests/testthat/test-downloadModule.R index de237c2a..29b10033 100644 --- a/tests/testthat/test-downloadModule.R +++ b/tests/testthat/test-downloadModule.R @@ -29,7 +29,6 @@ test_that("downloadModule downloads and unzips a single module", { expect_true(all(f %in% f_expected)) }) - test_that("downloadModule downloads and unzips a parent module", { skip_on_cran() @@ -115,15 +114,14 @@ test_that("downloadModule can overwrite existing modules", { test_that("downloadModule does not fail when data URLs cannot be accessed", { skip_on_cran() - opts <- list(reproducible.inputPaths = NULL, "reproducible.verbose" = TRUE) if (isWindows()) { opts <- append(opts, list(download.file.method = "auto")) } else { opts <- append(opts, list(download.file.method = "curl", download.file.extra = "-L")) } + testInit(c("httr2"), opts = opts) - testInit(c("httr"), opts = opts) m <- "test" skipMessReGoogledrive <- @@ -139,7 +137,7 @@ test_that("downloadModule does not fail when data URLs cannot be accessed", { skip(skipMessReGoogledrive) } } - f <- f$value[[1]] |> unlist() |> as.character() + f <- f[[1]] |> unlist() |> as.character() d <- f |> dirname() |> basename() |> unique() |> sort() d_expected <- sort(c(m, "data")) From 70fbe5ffbaaa7106b30a5aee93dd963ceb21cd17 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 11 Apr 2025 21:03:35 -0700 Subject: [PATCH 092/128] rm fastshp from GA workflows --- .github/workflows/R-CMD-check.yaml | 2 -- .github/workflows/pkgdown.yaml | 2 -- .github/workflows/revdeps.yaml | 2 -- .github/workflows/test-coverage.yaml | 2 -- .github/workflows/update-citation-cff.yaml | 2 -- 5 files changed, 10 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 02db889a..540c7902 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -58,14 +58,12 @@ jobs: extra-packages: | any::rcmdcheck PredictiveEcology/reproducible@AI - fastshp=?ignore NLMR=?ignore needs: check - name: Install additional package dependencies run: | pak::pkg_install("ropensci/NLMR") - pak::pkg_install("s-u/fastshp") shell: Rscript {0} - uses: r-lib/actions/check-r-package@v2 diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index a6bdc026..117cb083 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -37,14 +37,12 @@ jobs: any::pkgdown local::. PredictiveEcology/reproducible@AI - fastshp=?ignore NLMR=?ignore needs: website - name: Install additional package dependencies run: | pak::pkg_install("ropensci/NLMR") - pak::pkg_install("s-u/fastshp") shell: Rscript {0} - name: Build site diff --git a/.github/workflows/revdeps.yaml b/.github/workflows/revdeps.yaml index 50df0b3b..5506cb11 100644 --- a/.github/workflows/revdeps.yaml +++ b/.github/workflows/revdeps.yaml @@ -49,14 +49,12 @@ jobs: extra-packages: | any::rcmdcheck PredictiveEcology/reproducible@AI - fastshp=?ignore NLMR=?ignore needs: check - name: Install additional package dependencies run: | pak::pkg_install("ropensci/NLMR") - pak::pkg_install("s-u/fastshp") shell: Rscript {0} - uses: PredictiveEcology/actions/revdeps-check@v0.1 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 060935d5..5f577102 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -35,13 +35,11 @@ jobs: extra-packages: | any::covr PredictiveEcology/reproducible@AI - fastshp=?ignore NLMR=?ignore - name: Install additional package dependencies run: | pak::pkg_install("ropensci/NLMR") - pak::pkg_install("s-u/fastshp") shell: Rscript {0} - name: Test coverage diff --git a/.github/workflows/update-citation-cff.yaml b/.github/workflows/update-citation-cff.yaml index 72da6f92..8cb759f7 100644 --- a/.github/workflows/update-citation-cff.yaml +++ b/.github/workflows/update-citation-cff.yaml @@ -40,13 +40,11 @@ jobs: any::cffr any::V8 PredictiveEcology/reproducible@AI - fastshp=?ignore NLMR=?ignore - name: Install additional package dependencies run: | pak::pkg_install("ropensci/NLMR") - pak::pkg_install("s-u/fastshp") shell: Rscript {0} - name: Update CITATION.cff From cb20e14db3b8990f04752f0fbfa03f96417810e3 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 11 Apr 2025 22:14:03 -0700 Subject: [PATCH 093/128] Revert "test-downloadData fails on Windows: use GDrive instead of Github links" This reverts commit e0c770b880b62539d92ce5cb34bdf3c2b64a6934. --- tests/testthat/test-downloadData.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-downloadData.R b/tests/testthat/test-downloadData.R index b9ffea4c..185da0d8 100644 --- a/tests/testthat/test-downloadData.R +++ b/tests/testthat/test-downloadData.R @@ -33,15 +33,15 @@ test_that("downloadData downloads and unzips module data", { objectName = c("DEM", "habitatQuality"), objectClass = "RasterLayer", sourceURL = c( - "https://drive.google.com/file/d/18roW33nu0qJ2ybUk8SG1WJa-HZq_PZ12", - "https://drive.google.com/file/d/1wpkVWeXNNfFaDQePNw9rwA6sFGtFCd2B" + "https://raw.githubusercontent.com/PredictiveEcology/quickPlot/master/inst/maps/DEM.tif", + "https://raw.githubusercontent.com/PredictiveEcology/quickPlot/master/inst/maps/habitatQuality.tif" ), stringsAsFactors = FALSE ) a <- capture.output({ - t1 <- system.time(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, - files = c("DEM.tif", "habitatQuality.tif")) + t1 <- system.time(dd1 <- try(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, + files = c("DEM.tif", "habitatQuality.tif"))) ) }) From b0a6cf0a76ac89c7af32bbbe69a82eb2d8ddfd2e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Fri, 11 Apr 2025 22:16:38 -0700 Subject: [PATCH 094/128] test-downloadData and test-downloadModule --- tests/testthat/test-downloadData.R | 5 ++--- tests/testthat/test-downloadModule.R | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-downloadData.R b/tests/testthat/test-downloadData.R index 185da0d8..281543dc 100644 --- a/tests/testthat/test-downloadData.R +++ b/tests/testthat/test-downloadData.R @@ -10,7 +10,7 @@ test_that("downloadData downloads and unzips module data", { } ) - testInit(c("googledrive", "terra"), opts = opts) + testInit(c("httr2", "terra"), opts = opts) m <- "test" datadir <- file.path(tmpdir, m, "data") |> checkPath(create = TRUE) @@ -40,9 +40,8 @@ test_that("downloadData downloads and unzips module data", { ) a <- capture.output({ - t1 <- system.time(dd1 <- try(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, + t1 <- system.time(downloadData(m, tmpdir, quiet = FALSE, urls = expectsInputs$sourceURL, files = c("DEM.tif", "habitatQuality.tif"))) - ) }) result <- checksums(m, tmpdir)$result diff --git a/tests/testthat/test-downloadModule.R b/tests/testthat/test-downloadModule.R index 29b10033..a4176e14 100644 --- a/tests/testthat/test-downloadModule.R +++ b/tests/testthat/test-downloadModule.R @@ -137,7 +137,7 @@ test_that("downloadModule does not fail when data URLs cannot be accessed", { skip(skipMessReGoogledrive) } } - f <- f[[1]] |> unlist() |> as.character() + f <- f[[1]][[1]] |> unlist() |> as.character() d <- f |> dirname() |> basename() |> unique() |> sort() d_expected <- sort(c(m, "data")) From 89e6d6f5a80379063a6a3484486cf2c324b0a3e4 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 30 Apr 2025 10:47:42 -0700 Subject: [PATCH 095/128] minor re: recoveryModeOnExit --- R/simulation-spades.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 5fb9dcc5..0a5d6d49 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1627,9 +1627,12 @@ recoverModeOnExit <- function(sim, rmo, recoverMode) { message(cli::col_magenta(paste0("Setting options('spades.recoveryMode' = ",recoverMode,") used ", format(rmo$recoverModeTiming, units = "auto", digits = 3), " and ", format(recoverableObjsSize, units = "auto")))) + recmod <- as.integer(recoverMode) message(cli::cli_text(cli::col_magenta( paste( - "The initial state of the last", as.integer(recoverMode), "events are cached and saved", + "The initial state of the last ", recmod, + singularPlural(c("event", "events"), v = recmod), + isAre(v = recmod)," cached and saved", "in the {.var simList} located at {.code savedSimEnv()$.sim} as", "{.code sim$.recoverableObjs} with the most recent event as the first element in the list,", "second most recent event as the second element, etc.", From 1211b0e2c1c88e061b26e2b989a1fa0b59196945 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Wed, 30 Apr 2025 10:47:59 -0700 Subject: [PATCH 096/128] reexports --- R/reexports.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/reexports.R b/R/reexports.R index 6ff765f1..9f7b5fcc 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -15,6 +15,8 @@ extractInequality <- getFromNamespace("extractInequality", "Require") GETWauthThenNonAuth <- getFromNamespace("GETWauthThenNonAuth", "Require") getGitCredsToken <- getFromNamespace("getGitCredsToken", "Require") trimRedundancies <- getFromNamespace("trimRedundancies", "Require") +isAre <- getFromNamespace("isAre", "Require") +singularPlural <- getFromNamespace("singularPlural", "Require") getDrv <- getFromNamespace("getDrv", "reproducible") isWindows <- getFromNamespace("isWindows", "reproducible") From 39165a1bf855435b323d0b431aaba092e8cbfbd1 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Mon, 26 May 2025 19:02:36 -0700 Subject: [PATCH 097/128] redoc --- NAMESPACE | 1 + man/Copy.Rd | 4 -- man/SpaDES.core-package.Rd | 6 +- man/addChangedAttr.Rd | 13 +--- man/addTagsToOutput.Rd | 12 +--- man/cacheMessage.Rd | 18 +----- man/checkCacheRepo.Rd | 9 +-- man/clearCache.Rd | 63 ------------------- man/createDESCRIPTIONandDocs.Rd | 6 -- man/dealWithClass.Rd | 33 ---------- man/depsEdgeList.Rd | 10 ++- man/do.call.Rd | 33 ++++++++++ man/loadSimList.Rd | 6 -- man/makeMemoisable.Rd | 6 +- man/objSize.simList.Rd | 11 ---- man/preDigestByClass.Rd | 7 +-- man/prepareOutput.Rd | 12 +--- man/robustDigest.Rd | 31 +-------- ...> sub-simList-character-ANY-ANY-method.Rd} | 6 +- man/tagsByClass.Rd | 7 +-- 20 files changed, 63 insertions(+), 231 deletions(-) create mode 100644 man/do.call.Rd rename man/{sub-simList-character-ANY-method.Rd => sub-simList-character-ANY-ANY-method.Rd} (85%) diff --git a/NAMESPACE b/NAMESPACE index fb605d3c..d552e07f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -101,6 +101,7 @@ export(dhour) export(dmin) export(dmonth) export(dmonths) +export(doCallSafe) export(doEvent) export(doEvent.checkpoint) export(documentation) diff --git a/man/Copy.Rd b/man/Copy.Rd index 1fde21da..379c01e9 100644 --- a/man/Copy.Rd +++ b/man/Copy.Rd @@ -7,8 +7,6 @@ \S4method{Copy}{simList}(object, objects, queues, modules, ...) } \arguments{ -\item{object}{An R object (likely containing environments) or an environment.} - \item{objects}{Whether the objects contained within the \code{simList} environment should be copied. Default \code{TRUE}, which may be slow.} @@ -16,8 +14,6 @@ should be copied. Default \code{TRUE}, which may be slow.} be deep copied via \code{data.table::copy()}} \item{modules}{Logical. Should list of modules be copied.} - -\item{...}{Only used for custom Methods} } \value{ a copy of \code{object} diff --git a/man/SpaDES.core-package.Rd b/man/SpaDES.core-package.Rd index ce58ec98..fd5ec1cc 100644 --- a/man/SpaDES.core-package.Rd +++ b/man/SpaDES.core-package.Rd @@ -366,9 +366,9 @@ See example in \code{\link[=spades]{spades()}}, achieved by using \code{cache = \tabular{ll}{ \code{\link[reproducible:Cache]{reproducible::Cache()}} \tab Caches a function, but often accessed as argument in \code{\link[=spades]{spades()}}\cr -\code{\link[reproducible:viewCache]{reproducible::showCache()}} \tab Shows information about the objects in the cache\cr -\code{\link[reproducible:viewCache]{reproducible::clearCache()}} \tab Removes objects from the cache\cr -\code{\link[reproducible:viewCache]{reproducible::keepCache()}} \tab Keeps only the objects described\cr +\code{\link[reproducible:showCache]{reproducible::showCache()}} \tab Shows information about the objects in the cache\cr +\code{\link[reproducible:clearCache]{reproducible::clearCache()}} \tab Removes objects from the cache\cr +\code{\link[reproducible:keepCache]{reproducible::keepCache()}} \tab Keeps only the objects described\cr } A module developer can build caching into their module by creating cached versions of their diff --git a/man/addChangedAttr.Rd b/man/addChangedAttr.Rd index 5a9dde31..d32a975e 100644 --- a/man/addChangedAttr.Rd +++ b/man/addChangedAttr.Rd @@ -6,17 +6,6 @@ \usage{ \S4method{.addChangedAttr}{simList}(object, preDigest, origArguments, ...) } -\arguments{ -\item{object}{Any R object returned from a function} - -\item{preDigest}{The full, element by element hash of the input arguments to that same function, -e.g., from \code{.robustDigest}} - -\item{origArguments}{These are the actual arguments (i.e., the values, not the names) that -were the source for \code{preDigest}} - -\item{...}{Anything passed to methods.} -} \value{ returns the object with attribute added } @@ -28,5 +17,5 @@ When this function is subsequently called again, only these changed objects will be returned. All other \code{simList} objects will remain unchanged. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.addChangedAttr} +\link[reproducible:.addChangedAttr]{reproducible::.addChangedAttr} } diff --git a/man/addTagsToOutput.Rd b/man/addTagsToOutput.Rd index 4c997b19..72b55419 100644 --- a/man/addTagsToOutput.Rd +++ b/man/addTagsToOutput.Rd @@ -6,21 +6,11 @@ \usage{ \S4method{.addTagsToOutput}{simList}(object, outputObjects, FUN, preDigestByClass) } -\arguments{ -\item{object}{Any R object returned from a function} - -\item{outputObjects}{Optional character vector indicating which objects to -return. This is only relevant for list, environment (or similar) objects} - -\item{FUN}{A function} - -\item{preDigestByClass}{A list, usually from \code{.preDigestByClass}} -} \value{ modified \code{object}, with attributes added } \description{ -See \code{\link[reproducible:exportedMethods]{reproducible::.addTagsToOutput()}}. +See \code{\link[reproducible:.addTagsToOutput]{reproducible::.addTagsToOutput()}}. } \author{ Eliot McIntire diff --git a/man/cacheMessage.Rd b/man/cacheMessage.Rd index 371e8ecd..0fe08767 100644 --- a/man/cacheMessage.Rd +++ b/man/cacheMessage.Rd @@ -11,23 +11,9 @@ verbose = getOption("reproducible.verbose") ) } -\arguments{ -\item{object}{Any R object returned from a function} - -\item{functionName}{A character string indicating the function name} - -\item{fromMemoise}{Logical. If \code{TRUE}, the message will be about -recovery from memoised copy} - -\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, -1 showing more messaging, 2 being more messaging, etc. -Default is 1. Above 3 will output much more information about the internals of -Caching, which may help diagnose Caching challenges. Can set globally with an -option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} -} \description{ -See \code{\link[reproducible:exportedMethods]{reproducible::.cacheMessage()}}. +See \code{\link[reproducible:.cacheMessage]{reproducible::.cacheMessage()}}. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.cacheMessage} +\link[reproducible:.cacheMessage]{reproducible::.cacheMessage} } diff --git a/man/checkCacheRepo.Rd b/man/checkCacheRepo.Rd index 6eeccd93..6f66db30 100644 --- a/man/checkCacheRepo.Rd +++ b/man/checkCacheRepo.Rd @@ -6,17 +6,12 @@ \usage{ \S4method{.checkCacheRepo}{list}(object, create = FALSE) } -\arguments{ -\item{object}{Any R object returned from a function} - -\item{create}{Logical. If TRUE, then it will create the path for cache.} -} \value{ character string representing a directory path to the cache repo } \description{ -See \code{\link[reproducible:exportedMethods]{reproducible::.checkCacheRepo()}}. +See \code{\link[reproducible:.checkCacheRepo]{reproducible::.checkCacheRepo()}}. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.checkCacheRepo} +\link[reproducible:.checkCacheRepo]{reproducible::.checkCacheRepo} } diff --git a/man/clearCache.Rd b/man/clearCache.Rd index 90f7a662..835eb52c 100644 --- a/man/clearCache.Rd +++ b/man/clearCache.Rd @@ -48,73 +48,10 @@ ) } \arguments{ -\item{x}{A simList or a directory containing a valid Cache repository. Note: -For compatibility with \code{Cache} argument, \code{cachePath} can also be -used instead of \code{x}, though \code{x} will take precedence.} - -\item{userTags}{Character vector. If used, this will be used in place of the -\code{after} and \code{before}. -Specifying one or more \code{userTag} here will clear all -objects that match those tags. -Matching is via regular expression, meaning partial matches -will work unless strict beginning (\code{^}) and end (\code{$}) of string -characters are used. -Matching will be against any of the 3 columns returned by \code{showCache()}, -i.e., \code{artifact}, \code{tagValue} or \code{tagName}. -Also, if \code{length(userTags) > 1}, then matching is by \code{and}. -For \code{or} matching, use \code{|} in a single character string. -See examples.} - -\item{after}{A time (POSIX, character understandable by data.table). -Objects cached after this time will be shown or deleted.} - -\item{before}{A time (POSIX, character understandable by data.table). -Objects cached before this time will be shown or deleted.} - -\item{fun}{An optional character vector describing the function name to extract. -Only functions with this/these functions will be returned.} - -\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. -Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, -this will also be dramatically faster than using \code{userTags}, for a large -cache.} - -\item{ask}{Logical. If \code{FALSE}, then it will not ask to confirm deletions using -\code{clearCache} or \code{keepCache}. Default is \code{TRUE}} - -\item{useCloud}{Logical. If \code{TRUE}, then every object that is deleted locally will -also be deleted in the \code{cloudFolderID}, if it is non-\code{NULL}} - -\item{cloudFolderID}{A googledrive dribble of a folder, e.g., using \code{drive_mkdir()}. -If left as \code{NULL}, the function will create a cloud folder with name from last -two folder levels of the \code{cachePath} path, : -\code{paste0(basename(dirname(cachePath)), "_", basename(cachePath))}. -This \code{cloudFolderID} will be added to \code{options("reproducible.cloudFolderID")}, -but this will not persist across sessions. If this is a character string, it will -treat this as a folder name to create or use on GoogleDrive.} - \item{drv}{an object that inherits from \code{DBIDriver}, or an existing \code{DBIConnection} object (in order to clone an existing connection).} \item{conn}{A \code{DBIConnection} object, as returned by \code{dbConnect()}.} - -\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, -1 showing more messaging, 2 being more messaging, etc. -Default is 1. Above 3 will output much more information about the internals of -Caching, which may help diagnose Caching challenges. Can set globally with an -option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} - -\item{...}{Other arguments. Can be in the form of \code{tagKey = tagValue}, such as, -\code{class = "numeric"} to find all entries that are numerics in the cache. -Note: the special cases of \code{cacheId} and \code{fun} have their own -named arguments in these functions. -Also can be \code{regexp = xx}, where \code{xx} is \code{TRUE} if the user -is passing a regular expression. -Otherwise, \code{userTags} will need to be exact matches. Default is -missing, which is the same as \code{TRUE}. If there are errors due -to regular expression problem, try \code{FALSE}. For \code{cc}, it is -passed to \code{clearCache}, e.g., \code{ask}, \code{userTags}. For \code{showCache}, -it can also be \code{sorted = FALSE} to return the object unsorted.} } \value{ A \code{data.table} object showing the subset of items in the cache, located at \code{cachePath} diff --git a/man/createDESCRIPTIONandDocs.Rd b/man/createDESCRIPTIONandDocs.Rd index 8b81e0b7..b517cfd5 100644 --- a/man/createDESCRIPTIONandDocs.Rd +++ b/man/createDESCRIPTIONandDocs.Rd @@ -24,12 +24,6 @@ be imported. If \code{FALSE}, then only functions explicitly imported using \item{buildDocuments}{A logical. If \code{TRUE}, the default, then the documentation will be built, if any exists, using \code{roxygen2::roxygenise}.} - -\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, -1 showing more messaging, 2 being more messaging, etc. -Default is 1. Above 3 will output much more information about the internals of -Caching, which may help diagnose Caching challenges. Can set globally with an -option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} } \value{ Invoked for its side effects. There will be a new or modified diff --git a/man/dealWithClass.Rd b/man/dealWithClass.Rd index 8448bcb9..5768a6fc 100644 --- a/man/dealWithClass.Rd +++ b/man/dealWithClass.Rd @@ -39,43 +39,10 @@ ) } \arguments{ -\item{obj}{Any arbitrary R object.} - -\item{cachePath}{A repository used for storing cached objects. -This is optional if \code{Cache} is used inside a SpaDES module.} - -\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} - \item{drv}{an object that inherits from \code{DBIDriver}, or an existing \code{DBIConnection} object (in order to clone an existing connection).} \item{conn}{A \code{DBIConnection} object, as returned by \code{dbConnect()}.} - -\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, -1 showing more messaging, 2 being more messaging, etc. -Default is 1. Above 3 will output much more information about the internals of -Caching, which may help diagnose Caching challenges. Can set globally with an -option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} - -\item{outputObjects}{Optional character vector indicating which objects to -return. This is only relevant for list, environment (or similar) objects} - -\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. -Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, -this will also be dramatically faster than using \code{userTags}, for a large -cache.} - -\item{...}{Other arguments. Can be in the form of \code{tagKey = tagValue}, such as, -\code{class = "numeric"} to find all entries that are numerics in the cache. -Note: the special cases of \code{cacheId} and \code{fun} have their own -named arguments in these functions. -Also can be \code{regexp = xx}, where \code{xx} is \code{TRUE} if the user -is passing a regular expression. -Otherwise, \code{userTags} will need to be exact matches. Default is -missing, which is the same as \code{TRUE}. If there are errors due -to regular expression problem, try \code{FALSE}. For \code{cc}, it is -passed to \code{clearCache}, e.g., \code{ask}, \code{userTags}. For \code{showCache}, -it can also be \code{sorted = FALSE} to return the object unsorted.} } \value{ The same object as passed into the function, but dealt with so that it can be diff --git a/man/depsEdgeList.Rd b/man/depsEdgeList.Rd index 4221c626..a7d28d38 100644 --- a/man/depsEdgeList.Rd +++ b/man/depsEdgeList.Rd @@ -6,9 +6,9 @@ \alias{depsEdgeList,simList,missing-method} \title{Build edge list for module dependency graph} \usage{ -depsEdgeList(sim, plot) +depsEdgeList(sim, plot, includeOutputs = FALSE) -\S4method{depsEdgeList}{simList,logical}(sim, plot) +\S4method{depsEdgeList}{simList,logical}(sim, plot, includeOutputs = FALSE) \S4method{depsEdgeList}{simList,missing}(sim, plot) } @@ -20,6 +20,12 @@ will be used for plotting. If \code{TRUE}, duplicated rows (i.e., multiple object dependencies between modules) are removed so that only a single arrow is drawn connecting the modules. Default is \code{FALSE}.} + +\item{includeOutputs}{Logical indicating whether objects that are only "outputs" +will be kept and labelled as \emph{OUTPUTS} analogous to \emph{INPUTS}. This is relevant +in the case of \code{objectSynonyms}. If an object is not used by another module +then it will be removed from this \code{depsEdgeList} return; this keeps these +so can be determined if they are e.g., \code{suppliedElsewhere}.} } \value{ A \code{data.table} whose first two columns give a list of edges diff --git a/man/do.call.Rd b/man/do.call.Rd new file mode 100644 index 00000000..efc1475b --- /dev/null +++ b/man/do.call.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/simulation-simInit.R +\name{doCallSafe} +\alias{doCallSafe} +\title{Memory safe alternative to \code{do.call}} +\usage{ +doCallSafe(what, args, quote = FALSE, envir = parent.frame()) +} +\arguments{ +\item{what}{either a function or a non-empty character string naming the + function to be called.} + +\item{args}{a \emph{list} of arguments to the function call. The + \code{names} attribute of \code{args} gives the argument names.} + +\item{quote}{a logical value indicating whether to quote the + arguments.} + +\item{envir}{an environment within which to evaluate the call. This + will be most useful if \code{what} is a character string and + the arguments are symbols or quoted expressions.} +} +\value{ +Same as \code{do.call}, but without the memory inefficiency. +} +\description{ +\code{doCallSafe} is an alternative implementation for \code{do.call} that does not +evaluate the \code{args} prior to running. This means that R does not become unresponsive +when there are large objects in the \code{args}. This should be used \emph{always} instead +of \code{do.call}, whenever there are possibly large objects within the \code{args}. This is +a verbatim copy from package \code{Gmisc} at +\url{https://search.r-project.org/CRAN/refmans/Gmisc/html/fastDoCall.html} +} diff --git a/man/loadSimList.Rd b/man/loadSimList.Rd index 424681aa..d626e350 100644 --- a/man/loadSimList.Rd +++ b/man/loadSimList.Rd @@ -36,12 +36,6 @@ incorrect paths in \code{Filenames(sim)} if the the \code{file} being read in is a different computer, path, or drive. This could be the output from \code{unzipSimList} (which is calls \code{loadSimList} internally, passing the unzipped filenames)} -\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, -1 showing more messaging, 2 being more messaging, etc. -Default is 1. Above 3 will output much more information about the internals of -Caching, which may help diagnose Caching challenges. Can set globally with an -option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} - \item{zipfile}{Filename of a zipped \code{simList}} \item{load}{Logical. If \code{TRUE}, the default, then the \code{simList} will diff --git a/man/makeMemoisable.Rd b/man/makeMemoisable.Rd index 1380d0ee..5344e35a 100644 --- a/man/makeMemoisable.Rd +++ b/man/makeMemoisable.Rd @@ -9,10 +9,6 @@ \method{unmakeMemoisable}{simList_}(x) } -\arguments{ -\item{x}{An object to make memoisable. -See individual methods in other packages.} -} \value{ A \code{simList_} object or a \code{simList}, in the case of \code{unmakeMemoisable}. } @@ -22,5 +18,5 @@ memoise a \code{simList}. This method for \code{simList} converts the object to a \code{simList_} first. } \seealso{ -\code{\link[reproducible:exportedMethods]{reproducible::makeMemoisable()}} +\code{\link[reproducible:makeMemoisable]{reproducible::makeMemoisable()}} } diff --git a/man/objSize.simList.Rd b/man/objSize.simList.Rd index bcb91864..5a157263 100644 --- a/man/objSize.simList.Rd +++ b/man/objSize.simList.Rd @@ -6,17 +6,6 @@ \usage{ \method{objSize}{simList}(x, quick = FALSE, recursive = FALSE, ...) } -\arguments{ -\item{x}{An object} - -\item{quick}{Logical. If \code{FALSE}, then an attribute, "objSize" will be added to -the returned value, with each of the elements' object size returned also.} - -\item{recursive}{Logical. If \code{TRUE}, then, in addition to evaluating the whole object, -it will also return the recursive sizes of the elements of a list or environment.} - -\item{...}{Additional arguments (currently unused), enables backwards compatible use.} -} \value{ an estimate of the size of the object, in bytes. } diff --git a/man/preDigestByClass.Rd b/man/preDigestByClass.Rd index 0cbb7578..151cdbd0 100644 --- a/man/preDigestByClass.Rd +++ b/man/preDigestByClass.Rd @@ -6,9 +6,6 @@ \usage{ \S4method{.preDigestByClass}{simList}(object) } -\arguments{ -\item{object}{Any R object returned from a function} -} \value{ character vector corresponding to the names of objects stored in the \code{.xData} slot } @@ -16,10 +13,10 @@ character vector corresponding to the names of objects stored in the \code{.xDat Takes a snapshot of \code{simList} objects. } \details{ -See \code{\link[reproducible:exportedMethods]{reproducible::.preDigestByClass()}}. +See \code{\link[reproducible:.preDigestByClass]{reproducible::.preDigestByClass()}}. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.preDigestByClass} +\link[reproducible:.preDigestByClass]{reproducible::.preDigestByClass} } \author{ Eliot McIntire diff --git a/man/prepareOutput.Rd b/man/prepareOutput.Rd index 3ae71de5..1472009a 100644 --- a/man/prepareOutput.Rd +++ b/man/prepareOutput.Rd @@ -6,20 +6,12 @@ \usage{ \S4method{.prepareOutput}{simList}(object, cachePath, ...) } -\arguments{ -\item{object}{Any R object returned from a function} - -\item{cachePath}{A repository used for storing cached objects. -This is optional if \code{Cache} is used inside a SpaDES module.} - -\item{...}{Anything passed to methods.} -} \value{ the modified \code{object} } \description{ -See \code{\link[reproducible:exportedMethods]{reproducible::.prepareOutput()}}. +See \code{\link[reproducible:.prepareOutput]{reproducible::.prepareOutput()}}. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.prepareOutput} +\link[reproducible:.prepareOutput]{reproducible::.prepareOutput} } diff --git a/man/robustDigest.Rd b/man/robustDigest.Rd index d1075263..99afa5a1 100644 --- a/man/robustDigest.Rd +++ b/man/robustDigest.Rd @@ -7,45 +7,18 @@ \usage{ \S4method{.robustDigest}{simList}(object, .objects, length, algo = "xxhash64", quick, classOptions) } -\arguments{ -\item{object}{an object to digest.} - -\item{.objects}{Character vector of objects to be digested. This is only applicable -if there is a list, environment (or similar) with named objects -within it. Only this/these objects will be considered for caching, -i.e., only use a subset of -the list, environment or similar objects. In the case of nested list-type -objects, this will only be applied outermost first.} - -\item{length}{Numeric. If the element passed to Cache is a \code{Path} class -object (from e.g., \code{asPath(filename)}) or it is a \code{Raster} with -file-backing, then this will be -passed to \code{digest::digest}, essentially limiting the number of bytes -to digest (for speed). This will only be used if \code{quick = FALSE}. -Default is \code{getOption("reproducible.length")}, which is set to \code{Inf}.} - -\item{algo}{The digest algorithm to use. Default \code{xxhash64} (see \code{\link[digest:digest]{digest::digest()}} for others).} - -\item{quick}{Logical or character. If \code{TRUE}, -no disk-based information will be assessed, i.e., only -memory content. See Details section about \code{quick} in \code{\link[reproducible:Cache]{Cache()}}.} - -\item{classOptions}{Optional list. This will pass into \code{.robustDigest} for -specific classes. Should be options that the \code{.robustDigest} knows what -to do with.} -} \description{ This is intended to be used within the \code{Cache} function, but can be used to evaluate what a \code{simList} would look like once it is converted to a repeatably digestible object. } \details{ -See \code{\link[reproducible:robustDigest]{reproducible::.robustDigest()}}. +See \code{\link[reproducible:.robustDigest]{reproducible::.robustDigest()}}. This method strips out stuff from a \code{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. } \seealso{ -\code{\link[reproducible:robustDigest]{reproducible::.robustDigest()}} +\code{\link[reproducible:.robustDigest]{reproducible::.robustDigest()}} } \author{ Eliot McIntire diff --git a/man/sub-simList-character-ANY-method.Rd b/man/sub-simList-character-ANY-ANY-method.Rd similarity index 85% rename from man/sub-simList-character-ANY-method.Rd rename to man/sub-simList-character-ANY-ANY-method.Rd index 2a5fa6a3..e87e6bff 100644 --- a/man/sub-simList-character-ANY-method.Rd +++ b/man/sub-simList-character-ANY-ANY-method.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/simList-accessors.R -\name{[,simList,character,ANY-method} -\alias{[,simList,character,ANY-method} +\name{[,simList,character,ANY,ANY-method} +\alias{[,simList,character,ANY,ANY-method} \title{Extract an intact \code{simList} but with subset of objects} \usage{ -\S4method{[}{simList,character,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{simList,character,ANY,ANY}(x, i, j, ..., drop = TRUE) } \arguments{ \item{x}{A \code{simList}} diff --git a/man/tagsByClass.Rd b/man/tagsByClass.Rd index 9079ca49..1dd20e38 100644 --- a/man/tagsByClass.Rd +++ b/man/tagsByClass.Rd @@ -6,15 +6,12 @@ \usage{ \S4method{.tagsByClass}{simList}(object) } -\arguments{ -\item{object}{Any R object returned from a function} -} \description{ -See \code{\link[reproducible:exportedMethods]{reproducible::.tagsByClass()}}. Adds current \code{moduleName}, +See \code{\link[reproducible:.tagsByClass]{reproducible::.tagsByClass()}}. Adds current \code{moduleName}, \code{eventType}, \code{eventTime}, and \verb{function:spades} as \code{userTags}. } \seealso{ -\link[reproducible:exportedMethods]{reproducible::.tagsByClass} +\link[reproducible:.tagsByClass]{reproducible::.tagsByClass} } \author{ Eliot McIntire From 041ba83c132d8f400267e6656e422387b0f7ed4e Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 17:55:33 -0700 Subject: [PATCH 098/128] redoc --- NAMESPACE | 1 + man/clearCacheEventsOnly.Rd | 20 ++++++++++++++++++++ man/objectSynonyms.Rd | 2 +- 3 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 man/clearCacheEventsOnly.Rd diff --git a/NAMESPACE b/NAMESPACE index d552e07f..87911e39 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -79,6 +79,7 @@ export(checkpointFile) export(checkpointInterval) export(checkpointLoad) export(classFilter) +export(clearCacheEventsOnly) export(completed) export(conditionalEvents) export(convertTimeunit) diff --git a/man/clearCacheEventsOnly.Rd b/man/clearCacheEventsOnly.Rd new file mode 100644 index 00000000..e1c3584c --- /dev/null +++ b/man/clearCacheEventsOnly.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cache.R +\name{clearCacheEventsOnly} +\alias{clearCacheEventsOnly} +\title{Convenience wrapper around \code{clearCache} for SpaDES events} +\usage{ +clearCacheEventsOnly( + ask, + x = getOption("reproducible.cachePath"), + verbose = getOption("reproducible.verbose") +) +} +\value{ +A list of individual \code{clearCache} outputs, one for each event that was +cleared. +} +\description{ +This will clear only the event- and module-level caching that is triggered +using a module parameter, \code{.useCache}. +} diff --git a/man/objectSynonyms.Rd b/man/objectSynonyms.Rd index f4f7b381..f90a9a64 100644 --- a/man/objectSynonyms.Rd +++ b/man/objectSynonyms.Rd @@ -72,7 +72,7 @@ sim <- objectSynonyms(sim, os) sim <- objectSynonyms(sim, os2) # check -sim$objectSynonyms +sim$.objectSynonyms } From 100e42d017516ecfde8ed684ce50289a98fbe491 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 17:56:19 -0700 Subject: [PATCH 099/128] suppliedElsewhere -- allow objectSynonyms --- R/suppliedElsewhere.R | 43 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 2 deletions(-) diff --git a/R/suppliedElsewhere.R b/R/suppliedElsewhere.R index 4417dc6f..cfd3e3c2 100644 --- a/R/suppliedElsewhere.R +++ b/R/suppliedElsewhere.R @@ -95,9 +95,22 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") objDeparsed <- as.character(objDeparsed) + namesInList <- names(sim@.xData) + if (!is.null(sim$objectSynonyms)) { + namesInListHasOS <- lapply(sim$objectSynonyms, function(os) { + osInNamesInList <- os %in% namesInList + if (any(osInNamesInList)) { + os + } else { + os <- NULL + } + }) + if (length(unlist(namesInListHasOS))) + namesInList <- unique(c(namesInList, unlist(namesInListHasOS))) + } # Equivalent to !is.null(sim$xxx) inPrevDotInputObjects <- if ("s" %in% forms$where) { - out <- match(objDeparsed, names(sim@.xData), nomatch = 0L) > 0L + out <- match(objDeparsed, namesInList, nomatch = 0L) > 0L # check not in because it is just declared as a objectSynonym if (isTRUE(out)) { if (!is.null(sim$objectSynonyms)) { @@ -121,7 +134,33 @@ suppliedElsewhere <- function(object, sim, where = c("sim", "user", "initEvent") curMod <- currentModule(sim) inFutureInit <- if (any(c("i", "c") %in% forms$where)) { - del <- depsEdgeList(sim, plot = FALSE) + + # The includeOutputs = TRUE is because depsEdgeList removes objects + # that are not used by another module, so it will miss objects + # that are part of objectSynonyms. With includeOutputs, it puts _OUTPUTS_ + # analogous to _INPUTS_, so even dangling outputs will be kept, so they can + # be checked against objectSynonyms + del <- depsEdgeList(sim, plot = FALSE, includeOutputs = TRUE) + + # Need to deal with objectSynonyms + if (!is.null(sim$objectSynonyms)) { + objsInOS <- sim$objectSynonyms + ddel1 <- list() + iter <- 0 + for (OS in objsInOS) { + if (objDeparsed %in% OS) { + iter <- iter + 1 + ddel1[[iter]] <- list() + for (OSitem in OS) { + ddel1[[iter]][[OSitem]] <- del[objName %in% OSitem] + ddel1[[iter]][[OSitem]] <- ddel1[[iter]][[OSitem]][rep(seq_len(NROW(ddel1[[iter]][[OSitem]])), length(OS) - 1)] + ddel1[[iter]][[OSitem]][, objName := setdiff(OS, OSitem)] + } + + } + } + del <- rbindlist(list(del, rbindlist(unlist(ddel1, recursive = FALSE)))) + } if (NROW(del)) { # if ("c" %in% forms$where) { From 60931cae17b329d004ed011bac17dfc510e40eb9 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 17:57:11 -0700 Subject: [PATCH 100/128] objectSynonyms tweaks --- R/objectSynonyms.R | 34 +++++++++++++++++++--------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/R/objectSynonyms.R b/R/objectSynonyms.R index 4a1d24bb..ae73c93a 100644 --- a/R/objectSynonyms.R +++ b/R/objectSynonyms.R @@ -66,23 +66,24 @@ #' sim <- objectSynonyms(sim, os2) #' #' # check -#' sim$objectSynonyms +#' sim$.objectSynonyms #' #' objectSynonyms <- function(envir, synonyms) { # First, this may be an overwrite of an existing set of synonyms. - # If already in the envir$objectSynonyms, then remove it first - if (exists("objectSynonyms", envir = envir, inherits = FALSE)) { + # If already in the envir[[objSynName]], then remove it first + + if (exists(objSynName, envir = envir, inherits = FALSE)) { for (syns in seq_along(synonyms)) { - for(cur in envir$objectSynonyms) { + for(cur in envir[[objSynName]]) { if (any(cur %in% synonyms[[syns]])) { synonyms[[syns]] <- unique(c(cur, synonyms[[syns]])) - whSyn <- unlist(lapply(envir$objectSynonyms, identical, cur)) - attrs <- attr(envir$objectSynonyms, "bindings") - envir$objectSynonyms <- envir$objectSynonyms[!whSyn] - attr(envir$objectSynonyms, "bindings") <- attrs[!whSyn] + whSyn <- unlist(lapply(envir[[objSynName]], identical, cur)) + attrs <- attr(envir[[objSynName]], "bindings") + envir[[objSynName]] <- envir[[objSynName]][!whSyn] + attr(envir[[objSynName]], "bindings") <- attrs[!whSyn] } } @@ -130,9 +131,9 @@ objectSynonyms <- function(envir, synonyms) { list(canonicalVersion = canonicalVersion, activeBindingObjects = activeBindingObjects) }) - attrs <- attr(envir$objectSynonyms, "bindings") - envir$objectSynonyms <- append(envir$objectSynonyms, synonyms) - attr(envir$objectSynonyms, "bindings") <- append(attrs, canonicalVersions) + attrs <- attr(envir[[objSynName]], "bindings") + envir[[objSynName]] <- append(envir[[objSynName]], synonyms) + attr(envir[[objSynName]], "bindings") <- append(attrs, canonicalVersions) envir } @@ -140,15 +141,15 @@ objectSynonyms <- function(envir, synonyms) { .checkObjectSynonyms <- function(envir) { - bindings <- attr(envir$objectSynonyms, "bindings") + bindings <- attr(envir[[objSynName]], "bindings") # It may be passed in as a list with no attributes if (is.null(bindings)) { - envir <- objectSynonyms(envir, envir$objectSynonyms) - bindings <- attr(envir$objectSynonyms, "bindings") + envir <- objectSynonyms(envir, envir[[objSynName]]) + bindings <- attr(envir[[objSynName]], "bindings") } - Map(syns = envir$objectSynonyms, bindings = bindings, #name2 = names(synonyms), + Map(syns = envir[[objSynName]], bindings = bindings, #name2 = names(synonyms), MoreArgs = list(envir = envir), function(syns, bindings, envir) { if (!exists(bindings$canonicalVersion, envir)) { envir <<- objectSynonyms(envir, list(syns)) @@ -164,3 +165,6 @@ objectSynonyms <- function(envir, synonyms) { }) envir } + + +objSynName <- ".objectSynonyms" From 1e1216efc9b990fff2edc16ae565c173ceaa7c4f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 17:58:35 -0700 Subject: [PATCH 101/128] setupModObjsEnv - new fn --- R/simulation-parseModule.R | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/R/simulation-parseModule.R b/R/simulation-parseModule.R index 61c7891a..ac1d8eb3 100644 --- a/R/simulation-parseModule.R +++ b/R/simulation-parseModule.R @@ -674,7 +674,17 @@ evalWithActiveCode <- function(parsedModuleNoDefineModule, envir, parentFrame = newEnvsByModule <- function(sim, modu) { sim@.xData$.mods[[modu]] <- new.env(parent = asNamespace("SpaDES.core")) attr(sim@.xData$.mods[[modu]], "name") <- modu - sim@.xData$.mods[[modu]]$.objects <- new.env(parent = emptyenv()) + + if (FALSE) { + sim@.xData$.mods[[modu]]$.objects <- new.env(parent = emptyenv()) + } else { + + sim <- setupModObjsEnv(sim, moduleName = modu) + # if (!exists(dotObjs, envir = sim@.xData)) + # sim@.xData[[]] <- new.env(parent = emptyenv()) + # sim@.xData[[dotObjs]][[modu]] <- new.env(parent = emptyenv()) + # sim@.xData[[dotObjs]][[modu]]$.objects <- new.env(parent = emptyenv()) + } sim } @@ -699,3 +709,23 @@ currentModuleTemporary <- function(sim, mBase) { ) sim } + + + +setupModObjsEnv <- function(sim, moduleName) { + if (!exists(dotObjs, envir = sim@.xData)) + sim@.xData[[dotObjs]] <- new.env(parent = emptyenv()) + sim@.xData[[dotObjs]][[moduleName]] <- new.env(parent = emptyenv()) + sim +} + +dotObjs <- ".modObjs" +dotMods <- ".mods" +dotObjsAndMods <- c(dotObjs, dotMods) +modAB <- "mod" +ParAB <- "Par" +modAndParAB <- c(modAB, ParAB) +.moduleObjectsNam <- "moduleObjects" +.moduleFunctionsNam <- "moduleFunctions" +.objectsSlot <- ".objects" +.objectsArg <- ".objects" From 33de73ff7eb54117478b300b4203f75e373cd0f9 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 18:00:44 -0700 Subject: [PATCH 102/128] depsEdgeList -- add arg: includeOutputs -- so we can get _OUTPUTS_ --- R/module-dependencies-methods.R | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/R/module-dependencies-methods.R b/R/module-dependencies-methods.R index 2a43644e..5584a412 100644 --- a/R/module-dependencies-methods.R +++ b/R/module-dependencies-methods.R @@ -18,6 +18,12 @@ selectMethod("show", "igraph") #' so that only a single arrow is drawn connecting the modules. #' Default is `FALSE`. #' +#' @param includeOutputs Logical indicating whether objects that are only "outputs" +#' will be kept and labelled as _OUTPUTS_ analogous to _INPUTS_. This is relevant +#' in the case of `objectSynonyms`. If an object is not used by another module +#' then it will be removed from this `depsEdgeList` return; this keeps these +#' so can be determined if they are e.g., `suppliedElsewhere`. +#' #' @return A `data.table` whose first two columns give a list of edges #' and remaining columns the attributes of the dependency objects #' (object name, class, etc.). @@ -28,7 +34,7 @@ selectMethod("show", "igraph") #' @include simList-class.R #' @rdname depsEdgeList #' -setGeneric("depsEdgeList", function(sim, plot) { +setGeneric("depsEdgeList", function(sim, plot, includeOutputs = FALSE) { standardGeneric("depsEdgeList") }) @@ -36,9 +42,9 @@ setGeneric("depsEdgeList", function(sim, plot) { setMethod( "depsEdgeList", signature(sim = "simList", plot = "logical"), - definition = function(sim, plot) { + definition = function(sim, plot, includeOutputs = FALSE) { deps <- sim@depends - DT <- .depsEdgeList(deps, plot) + DT <- .depsEdgeList(deps, plot, includeOutputs = includeOutputs) correctOrd <- unlist(sim@modules, use.names = FALSE) DT[, fromOrd := factor(from, levels = correctOrd)] DT[, toOrd := factor(to, levels = correctOrd)] @@ -50,11 +56,11 @@ setMethod( setMethod("depsEdgeList", signature(sim = "simList", plot = "missing"), definition = function(sim, plot) { - depsEdgeList(sim, plot = FALSE) + depsEdgeList(sim, plot = FALSE, includeOutputs = FALSE) }) #' @importFrom data.table as.data.table data.table rbindlist setkeyv setorder -.depsEdgeList <- function(deps, plot) { +.depsEdgeList <- function(deps, plot, includeOutputs = FALSE) { sim.in <- sim.out <- data.table(objectName = character(0), objectClass = character(0), module = character(0)) @@ -83,6 +89,17 @@ setMethod("depsEdgeList", if ((nrow(sim.in)) && (nrow(sim.out))) { dx <- sim.out[sim.in, nomatch = NA_character_, allow.cartesian = TRUE] dx[is.na(module), module := "_INPUT_"] + + if (isTRUE(includeOutputs)) { + dy <- sim.in[sim.out, nomatch = NA_character_, allow.cartesian = TRUE] + dy[is.na(module), module := "_OUTPUT_"] + modImod <- c("module", "i.module") + setnames(dy, old = modImod, new = rev(modImod)) + + dx <- unique(rbindlist(list(dx, dy), use.names = TRUE)) + } + # dy[grep("nonForest_timeSinceDisturbance", objectName)] + DT <- dx[, list(from = module, to = i.module, objName = objectName, objClass = i.objectClass)] From 89b6eab04f72fdab824fde6a1a4b7cc3b8941ed5 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 18:02:53 -0700 Subject: [PATCH 103/128] .depsLoadOrder -- protect and identify failures --- R/module-dependencies-methods.R | 73 +++++++++++++++++++++++---------- 1 file changed, 52 insertions(+), 21 deletions(-) diff --git a/R/module-dependencies-methods.R b/R/module-dependencies-methods.R index 5584a412..3b677c08 100644 --- a/R/module-dependencies-methods.R +++ b/R/module-dependencies-methods.R @@ -269,33 +269,64 @@ setMethod(".depsLoadOrder", loadOrdersInMetaData <- Map(mod = sim@depends@dependencies, function(mod) { if (length(mod@loadOrder)) mod@loadOrder else NULL}) loadOrdersInMetaData <- loadOrdersInMetaData[!vapply(loadOrdersInMetaData, is.null, FUN.VALUE = logical(1))] + loadOrdersInMetaDataOrig <- loadOrdersInMetaData if (length(loadOrdersInMetaData)) { - dt <- as.data.table(as_data_frame(simGraph)) - Map(lo = loadOrdersInMetaData, nam = names(loadOrdersInMetaData), - function(lo, nam) { - lapply(lo[["after"]], function(aft) { - a <- setDT(list(from = aft, to = nam, objName = .rndstr(1))) - dt <<- rbindlist(list(dt, a), fill = TRUE) + # keepTrying <- TRUE + iter <- 0L + needFindFail <- FALSE + rmTry <- as.data.table(expand.grid(nam = names(loadOrdersInMetaDataOrig), + befAf = c("before", "after"))) + iters <- seq(0L, NROW(rmTry)) + for (iter in iters) { + # while(keepTrying %in% TRUE) { + dt <- as.data.table(as_data_frame(simGraph)) + + Map(lo = loadOrdersInMetaData, nam = names(loadOrdersInMetaData), + function(lo, nam) { + if (iter == 0 || iter > 0 && rmTry$befAf[iter] == "after") + lapply(lo[["after"]], function(aft) { + a <- setDT(list(from = aft, to = nam, objName = .rndstr(1))) + dt <<- rbindlist(list(dt, a), fill = TRUE) + }) + if (iter == 0 || iter > 0 && rmTry$befAf[iter] == "before") + lapply(lo[["before"]], function(bef) { + a <- setDT(list(from = nam, to = bef, objName = .rndstr(1))) + dt <<- rbindlist(list(dt, a), fill = TRUE) + }) }) - lapply(lo[["before"]], function(bef) { - a <- setDT(list(from = nam, to = bef, objName = .rndstr(1))) - dt <<- rbindlist(list(dt, a), fill = TRUE) - }) - }) - simGraph2 <- graph_from_data_frame(dt) - tsort <- try(topo_sort(simGraph2, "out"), silent = TRUE) - if (exists("tsort", inherits = FALSE)) - if (!is(tsort, "try-error")) { - doTopoSort <- FALSE - simGraph <- simGraph2 - } else { - message("Could not automatically determine module order, even with `loadOrder` metadata; ", - "it may be wise to set the order manually and pass to `simInit(... loadOrder = xxx)`") + simGraph2 <- graph_from_data_frame(dt) + tsort <- try(topo_sort(simGraph2, "out"), silent = TRUE) + if (exists("tsort", inherits = FALSE)) + if (!is(tsort, "try-error") && iter == 0) { + doTopoSort <- FALSE + simGraph <- simGraph2 + # keepTrying <- FALSE + break + } else { + if (iter > 0) + set(rmTry, iter, "OK", !is(tsort, "try-error")) + # iter <- iter + 1L + needFindFail <- TRUE + tryRmMod <- names(loadOrdersInMetaDataOrig)[iter] + loadOrdersInMetaData <- loadOrdersInMetaDataOrig[tryRmMod] + # message("Could not automatically determine module order, even with `loadOrder` metadata; ", + # "it may be wise to set the order manually and pass to `simInit(... loadOrder = xxx)`") + } + } + if (iter > 0L) { + if (any(rmTry$OK %in% FALSE)) { + imposs <- rmTry[rmTry$OK %in% FALSE] + warning("There is an impossible cyclic dependency in the metadata entry for loadOrder in ", + paste0(imposs$nam, ": ", imposs$befAf, collapse = ", ")) } + message("Could not automatically determine module order, even with `loadOrder` metadata; ", + "it may be wise to set the order manually and pass to `simInit(... loadOrder = xxx)`") + } } } + if (doTopoSort) { tsort <- topo_sort(simGraph, "out") } @@ -352,4 +383,4 @@ setMethod(".depsLoadOrder", loadOrder <- c(loadOrder, noDeps) } return(loadOrder) -}) + }) From e28a4aa69bbfe0990c3843af22afa5895cd6a84c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 18:09:06 -0700 Subject: [PATCH 104/128] move mod activeBinding to sim@.xData[[dotObjs]] away from .mod; .robustDigest, .prepareOutput, other Cache consequences --- R/cache.R | 555 ++++++++++++++++++++++++++++++------------- R/copy.R | 55 +++-- R/modActiveBinding.R | 6 +- 3 files changed, 430 insertions(+), 186 deletions(-) diff --git a/R/cache.R b/R/cache.R index f4b35d9b..d3b88238 100644 --- a/R/cache.R +++ b/R/cache.R @@ -35,22 +35,45 @@ setMethod( # browser(expr = exists("._robustDigest_1")) curMod <- currentModule(object) + # if ("fireSense_dataPrepFit" %in% curMod) browser() # check .objects --> why doesn't it have the modObjects 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) - + moduleFunctions <- ls(object@.xData[[dotMods]], all.names = TRUE) # module names + moduleFunctionEnvir <- mget(moduleFunctions[moduleFunctions %in% unlist(modules(object))], + envir = object@.xData[[dotMods]]) # module environments + moduleFunctions <- lapply(moduleFunctionEnvir, function(me) ls(me, all.names = TRUE)) # obj names in .mods + + # Eliot addition May 2025 for new dotObjs + moduleObjects <- ls(object@.xData[[dotObjs]], all.names = TRUE) # module names + moduleObjEnvirs <- mget(moduleObjects[moduleObjects %in% unlist(modules(object))], + envir = object@.xData[[dotObjs]]) # module environments + moduleObjects <- lapply(moduleObjEnvirs, function(me) ls(me, all.names = TRUE)) # obj names in .mods + + modFunsAndObjs <- append(list(moduleFunctions) |> setNames(.moduleFunctionsNam), + list(moduleObjects) |> setNames(.moduleObjectsNam)) + modEnvirFunsAndObjs <- append(list(moduleFunctionEnvir) |> setNames(.moduleFunctionsNam), + list(moduleObjEnvirs) |> setNames(.moduleObjectsNam)) + allObjsInSimList <- modifyList2(list(".xData" = outerObjs), modFunsAndObjs) + # allObjsInSimList <- append(append(list(".xData" = outerObjs), moduleFunctions), + # moduleObjects |> setNames(paste0(dotObjs, "_", names(moduleObjects)))) + allObjsInSimList$.xData <- allObjsInSimList$.xData[!allObjsInSimList$.xData %in% dotObjsAndMods] + # allEnvsInSimList <- append(append(list(.xData = object@.xData), moduleFunctionEnvir), + # moduleObjEnvirs |> setNames(paste0(dotObjs, "_", names(moduleObjEnvirs)))) + allEnvsInSimList <- modifyList2(list(".xData" = object@.xData), modEnvirFunsAndObjs) + + # ord1 <- .orderDotsUnderscoreFirst(allObjsInSimList) + # ord2 <- .orderDotsUnderscoreFirst(names(allEnvsInSimList)) + # allObjsInSimList <- allObjsInSimList[ord1] + # allEnvsInSimList <- allEnvsInSimList[ord2] + + allObjsInSimList <- sortInner(allObjsInSimList) + allEnvsInSimList <- sortInner(allEnvsInSimList) + + # if ("fireSense_dataPrepFit" %in% curMod) { + # # after .addChangedAttr --> .objects is a list with `moduleFunctions` and `moduleObjects` ... with `.robustDigest` alone, it doesn't + # aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + # browser() + # } isObjectEmpty <- if (!missing(.objects)) { if (!is.null(.objects)) { FALSE @@ -62,56 +85,36 @@ setMethod( } 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)) + .objects <- buildDotObjectsList(object, .objects) } 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], algo = algo, - quick = !isFALSE(quick), # can be character or TRUE --> TRUE - length = length, classOptions = classOptions) # need classOptions + envirHash <- Map(objs = allObjsInSimList, xDataDotModDotObj = names(allObjsInSimList), + function(objs, xDataDotModDotObj) { + + if (is.list(objs)) { + out <- Map(obj = objs, moduleNam = names(objs), function(obj, moduleNam) { + # if (exists("aaaa", envir = .GlobalEnv)) browser() + if (!is.null(.objects[[xDataDotModDotObj]][[moduleNam]]) && length(obj)) { + digestEnviros(obj, .objects[[xDataDotModDotObj]][[moduleNam]], + allEnvsInSimList[[xDataDotModDotObj]][[moduleNam]], algo, quick, length, classOptions) + } + }) + } else { - list() + out <- digestEnviros(objs, .objects[[".xData"]], allEnvsInSimList[[".xData"]], algo, quick, length, classOptions) } + out }) - #names(envirHash) <- names(allObjsInSimList) - lens <- unlist(lapply(envirHash, function(x) length(x) > 0)) - envirHash <- envirHash[lens] + envirHash <- rmLength0Recursive(envirHash) + envirHash <- upgradeModsToXdata(envirHash, upgradeModsToXdata, moduleFunctionEnvir) - # demote .mods objects into .xData - eh <- envirHash[names(envirHash)[names(envirHash) %in% names(moduleEnvirs)]] - envirHash$.xData[names(eh)] <- eh - envirHash[names(eh)] <- NULL + if (FALSE) { + eh <- envirHash[names(envirHash)[names(envirHash) %in% names(moduleFunctionEnvir)]] + 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 @@ -125,6 +128,10 @@ setMethod( # i.e., if the same file is located in a different place, that is ok object@paths <- list() + # Remove event queue from digest. The queue will be put back into the sim at the end (.prepareOutput), + # but it doesn't matter what it is for digesting + object@events <- list() + # don't cache contents of output because file may already exist if (NROW(object@outputs)) { object@outputs$file <- basename(object@outputs$file) @@ -152,11 +159,11 @@ setMethod( object@depends@dependencies <- object@depends@dependencies[classOptions$modules] } + # Inputs if (NROW(object@inputs)) { # Only include objects that are in the `inputs` slot that this module uses if (length(curMod)) { # If it is a simInitAndSpades call, it doesn't have a curMod expectsInputs <- deps[[curMod]]@inputObjects$objectName - # if (is(expectsInputs, "try-error")) browser() object@inputs <- object@inputs[object@inputs$objectName %in% expectsInputs,] } if (NROW(object@inputs)) { # previous line may have removed row(s) from object@inputs, leaving potentially zero @@ -164,6 +171,7 @@ setMethod( } } + # Params # if this call is within a single module, only keep module-specific params if (length(curMod) > 0) { omitParams <- c(".showSimilar", ".useCache") @@ -173,7 +181,7 @@ setMethod( object@params <- lapply(object@params, function(x) .sortDotsUnderscoreFirst(x)) object@params <- .sortDotsUnderscoreFirst(object@params) - # Deal with globals + # globals if (!is.null(classOptions$.globals)) { object@params <- append(list(.globals = newGlobals), object@params) } @@ -182,28 +190,9 @@ setMethod( 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 - }) + obj <- rmDotUnderscoresInModules(obj, names) + } # outputs --> should not be treated like inputs; if they change, it is OK, so just outputs as a data.frame, @@ -258,7 +247,7 @@ setMethod( } # browser(expr = exists("._robustDigest_4")) obj -}) + }) if (!isGeneric(".tagsByClass")) { setGeneric(".tagsByClass", function(object) { @@ -309,7 +298,7 @@ setMethod( } } userTags -}) + }) if (!isGeneric(".cacheMessage")) { setGeneric(".cacheMessage", function(object, functionName, fromMemoise, verbose) { @@ -364,7 +353,7 @@ setMethod( } else { messageCache(.message$HangingIndent, "from ", cur$moduleName, " module", verbose = verbose) } -}) + }) if (!isGeneric(".checkCacheRepo")) { setGeneric(".checkCacheRepo", function(object, create = FALSE) { @@ -409,7 +398,7 @@ setMethod( } } checkPath(path = cachePath, create = create) -}) + }) if (!isGeneric(".addChangedAttr")) { setGeneric(".addChangedAttr", function(object, preDigest, origArguments, ...) { @@ -452,7 +441,8 @@ setMethod( stop("attributes on the cache object are not correct - 4") } - postDigest <- .robustDigest(object, .objects = dots$.objects, + if (exists("aaaa", envir = .GlobalEnv)) browser() + postDigest <- .robustDigest(object, .objects = dots[[.objectsArg]], length = dots$length, algo = dots$algo, quick = dots$quick, @@ -471,21 +461,33 @@ setMethod( if (length(preDigest[[whSimList]]$.list)) { out <- setdiffNamedRecursive(postDigest$.list[[whSimList2]], preDigest[[whSimList]]$.list[[whSimList2]]) + if (length(out) == 0) { + out <- Map(modNam = names(postDigest$.list[[whSimList2]]), function(modNam) { + list() + }) + } } else { out <- postDigest$.list[[whSimList2]] } - for (modNam in modules(object)) { + modulesInObject <- modules(object) + # if ("fireSense_dataPrepFit" %in% currentModule(object)) browser() + for (modNam in modulesInObject) { isModElement <- names(out) == modNam if (any(isModElement)) { - isDotObjects <- names(out[isModElement][[modNam]]) == ".objects" - if (any(!isDotObjects)) + isDotObjects <- names(out[isModElement][[modNam]]) == .objectsSlot + if (any(!isDotObjects)) # removes functions out[isModElement][[modNam]][!isDotObjects] <- NULL } } - changedObjs <- out[lengths(out) > 0] # remove empty elements + # remove empty elements, but keep module names with list + changedObjs <- out[lengths(out) > 0 | (names(out) %in% modulesInObject)] changed <- changedObjs + if (!any(modulesInObject %in% names(changed))) { # it needs to be nested list + currMod <- object@current[[2]] + changed <- append(changed, list(list()) |> setNames(currMod)) + } changed } else { character() @@ -497,7 +499,7 @@ setMethod( stop("attributes on the cache object are not correct - 5") object -}) + }) if (!isGeneric(".preDigestByClass")) { setGeneric(".preDigestByClass", function(object) { @@ -555,12 +557,21 @@ setMethod( signature = "simList", definition = function(object, cachePath, ...) { simFromCache <- object # rename for internal purposes + hasDotObjs <- !is.null(simFromCache@.xData[[dotObjs]]) + if (hasDotObjs %in% FALSE) { + messageColoured(colour = "red", "This object is using the old mod object structure; it must be \n", + "deleted. Rerunning it now ... ") + clearCache(x = cachePath, cacheId = cacheId(object), ask = FALSE) + return(invisible(reproducible:::.returnNothing)) + } + 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 (exists("aaaa", envir = .GlobalEnv)) browser() if (simListInput) { simPreOrigEnv <- simPre[[whSimList]]@.xData @@ -592,6 +603,7 @@ setMethod( envir = simPost[[i]]@.xData) } } else { + # Setup some things to use throughout currModules <- currentModule(simPre[[whSimList]]) @@ -626,92 +638,75 @@ setMethod( # 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) + # changedModEnv <- list() + # for (dotType in dotObjsAndMods) { + # if (!is.null(simFromCache@.xData[[dotType]])) + # changedModEnv[[dotType]] <- ls(simFromCache@.xData[[dotType]], all.names = TRUE) + # } + if (!is.null(simFromCache@.xData[[dotObjs]])) + changedModEnvObjs <- ls(simFromCache@.xData[[dotObjs]], all.names = TRUE) deps <- simPre[[whSimList]]@depends@dependencies namesAllMods <- names(deps) - if (!is.null(namesAllMods)) { # i.e., no modules exist in the simList + if (!is.null(namesAllMods)) { # i.e., are there modules 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)] + changedObjs <- attr(simFromCache, ".Cache")$changed + lsObjectEnv <- lsObjectsChanged(lsObjectEnv, changedObjs, + hasCurrModule, currModules, deps) + hasDotObjs <- !is.null(simFromCache@.xData[[dotObjs]]) + changedModEnvObjs <- lsModObjectsChanged(namesAllMods, changedObjs, hasDotObjs) - 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) + # if ("fireSense_dataPrepFit" %in% currModules) { + # aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + # browser() + # } + 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]]) + copyModuleSpecificFunsAndObjs(simPre[[whSimList]], simPost, 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]]) + copyModuleSpecificFunsAndObjs(simPre[[whSimList]], simPost, otherModule) }) } + # Deal with .mods objects - if (!is.null(simFromCache@.xData$.mods)) { + if (!is.null(simFromCache@.xData[[dotMods]])) { # 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) + modObjsInList <- as.list(simPre[[1]][[dotMods]][[modNam]], all.names = TRUE) + if (length(modObjsInList)) { + objs <- try( + setdiffNamedRecursive(modObjsInList, + changedModEnvObjs[[modNam]]) + ) + if (is(objs, "try-error")) browser() + if (length(objs)) + list2env(objs, simPost[[dotMods]][[modNam]]) + } } # Now changed objects if (length(unlist(changedModEnvObjs))) { Map(nam = names(changedModEnvObjs), objs = changedModEnvObjs, function(nam, objs) { - objNames <- names(objs$.objects) # used to be "names(...)" -- but don't want `._` objs + objNames <- names(objs[[.objectsSlot]]) # used to be "names(...)" -- but don't want `._` objs objNames <- grep("^._.+", objNames, value = TRUE, invert = TRUE) if (!is.null(objNames)) - list2env(mget(objNames, envir = simFromCache@.xData$.mods[[nam]][[".objects"]]), - envir = simPost@.xData$.mods[[nam]][[".objects"]]) + list2env(mget(objNames, envir = simFromCache@.xData[[dotObjs]][[nam]]), + envir = simPost@.xData[[dotObjs]][[nam]]) }) # override everything first -- this includes .objects -- take from Cache - # list2env(mget(changedModEnvObjs, envir = simFromCache@.xData$.mods), envir = simPost@.xData$.mods) + # list2env(mget(changedModEnvObjs, envir = simFromCache@.xData[[dotMods]]), envir = simPost@.xData[[dotMods]]) # BUT functions are so lightweight that they should always return current } } @@ -773,9 +768,9 @@ setMethod( 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) + # lsOrigModsEnv <- ls(simPreOrigEnv[[dotMods]], all.names = TRUE) + # keepFromModsOrig <- !(lsOrigModsEnv %in% ls(simPost@.xData[[dotMods]], all.names = TRUE)) + # list2env(mget(lsOrigModsEnv[keepFromModsOrig], envir = simPreOrigEnv[[dotMods]]), envir = simPost@.xData[[dotMods]]) if (exists("objectSynonyms", envir = simPost@.xData)) { objSyns <- lapply(attr(simPost$objectSynonyms, "bindings"), function(x) unname(unlist(x))) @@ -809,7 +804,7 @@ setMethod( } else { return(simFromCache) } -}) + }) #' Pre-digesting method for `simList` #' @@ -835,7 +830,7 @@ setMethod( definition = function(object) { obj <- ls(object@.xData, all.names = TRUE) return(obj) -}) + }) if (!isGeneric(".addTagsToOutput")) { setGeneric(".addTagsToOutput", function(object, outputObjects, FUN) { @@ -867,7 +862,7 @@ setMethod( # browser(expr = exists("._addTagsToOutput_2")) outputToSave <- object outputToSave@.xData <- new.env(parent = emptyenv()) - outputToSave@.xData$.mods <- new.env(parent = asNamespace("SpaDES.core")) + outputToSave@.xData[[dotMods]] <- new.env(parent = asNamespace("SpaDES.core")) outputToSave@.envir <- outputToSave@.xData # Some objects are conditionally produced from a module's outputObject @@ -878,8 +873,8 @@ setMethod( # Deal with .mods outputObjectsMods <- grep(".mods", outputObjects, value = TRUE) outputObjectsMods <- gsub("(.*)\\$", "", outputObjectsMods) - list2env(mget(outputObjectsMods, envir = object@.xData$.mods), - envir = outputToSave@.xData$.mods) + list2env(mget(outputObjectsMods, envir = object@.xData[[dotMods]]), + envir = outputToSave@.xData[[dotMods]]) setattr(outputToSave, "tags", attr(object, "tags")) setattr(outputToSave, "call", attr(object, "call")) @@ -905,7 +900,7 @@ setMethod( } outputToSave -}) + }) #' Find `simList` in a nested list @@ -971,8 +966,8 @@ objSize.simList <- function(x, quick = FALSE, recursive = FALSE, ...) { # if (!quick) attr(total, "objSize") <- list(sim = attr(aa, "objSize"), other = attr(otherParts, "objSize")) - # attr(total, "objSize") <- sum(unlist(attr(aa, "objSize")), unlist(attr(otherParts, "objSize"))) - # class(attr(total, "objSize")) <- "lobstr_bytes" + # attr(total, "objSize") <- sum(unlist(attr(aa, "objSize")), unlist(attr(otherParts, "objSize"))) + # class(attr(total, "objSize")) <- "lobstr_bytes" } # else { # total <- NA @@ -1014,16 +1009,16 @@ objSize.simList <- function(x, quick = FALSE, recursive = FALSE, ...) { 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) + modulesInSim <- ls(objTmp[[dotMods]]) for (mo in modulesInSim) { - try(rm(list = c("Par", "mod"), envir = objTmp$.mods[[mo]])) + try(rm(list = c("Par", "mod"), envir = objTmp[[dotMods]][[mo]])) } # .wrap the metadata ... i.e,. @depends objTmp <- .wrapOrUnwrapSimListAts(objTmp, .wrap) # 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) + objTmp[[dotMods]] <- .wrap(objTmp[[dotMods]], 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 @@ -1110,7 +1105,7 @@ wrapAndUnwrapDotMmoduleDeps <- function(deps, wrapOrUnwrap = .wrap) { 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, ...) + obj[[dotMods]] <- .unwrap(obj[[dotMods]], 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, @@ -1216,7 +1211,7 @@ setMethod( ask = ask, useCloud = useCloud, cloudFolderID = cloudFolderID, ...) -}) + }) if (!isGeneric("showCache")) { setGeneric("showCache", function(x, userTags = character(), @@ -1237,7 +1232,7 @@ setMethod( 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(), @@ -1258,5 +1253,243 @@ setMethod( definition = function(x, userTags, after = NULL, before = NULL, ...) { x <- x@paths$cachePath keepCache(x = x, userTags = userTags, after = after, before = before, - ...) -}) + ...) + }) + + +sortInner <- function(l, useNames = FALSE) { + l <- Map(inner = l, function(inner) { + if (is.list(inner) || is.character(inner)) { + ord1 <- .orderDotsUnderscoreFirst(inner) + if (!(identical(ord1, seq_len(length(inner))))) + inner <- inner[ord1] + } else { + en <- environmentName(inner) + ord1 <- .orderDotsUnderscoreFirst(en) + if (!(identical(ord1, seq_along(en)))) + inner <- inner[ord1] + } + inner + } + ) + # } + l +} + + +digestEnviros <- function(objs, .objects, envToLookIn, algo, quick, length, classOptions) { + dotUnderscoreObjs <- objs[startsWith(objs, "._")] + objs <- objs[!objs %in% c(dotUnderscoreObjs, modAndParAB)] + objs <- objs[objs %in% .objects] + if (length(objs) > 1) { + objs <- sort(objs, method = "radix") + } + out <- if (length(objs) > 0) { + a <- mget(objs, envir = envToLookIn) + nonZero <- lengths(a) > 0 + commonObjs <- intersect(.objects, names(a[nonZero])) + # nonZero <- unlist(lapply(a, function(x) length(x) > 0)) + .robustDigest(a[nonZero], algo = algo, .objects = commonObjs, + quick = !isFALSE(quick), # can be character or TRUE --> TRUE + length = length, classOptions = classOptions) # need classOptions + } else { + list() + } + out +} + + +rmLength0Recursive <- function(envirHash, recurse = 1) { + if (is.list(envirHash) && recurse > 0) { + out <- lapply(envirHash, rmLength0Recursive, recurse = 0) + out <- out[lengths(out) > 0] + } else { + lens <- lengths(envirHash) > 0 + # lens <- unlist(lapply(envirHash, function(x) length(x) > 0)) + out <- envirHash[lens] + } + out +} + + +# upgradeModsToXdata <- function(envirHash, moduleFunctionEnvir, recurse = 1) +upgradeModsToXdata <- function(envirHash, upgradeModsToXdata, moduleFunctionEnvir, recurse = 1) { + if (is.list(envirHash) && recurse > 0) { + eh <- lapply(envirHash, upgradeModsToXdata, moduleFunctionEnvir = moduleFunctionEnvir, recurse = 0) + if (length(eh)) { + en2Nams <- unlist(lapply(eh, names)) + envirHashNew <- mapply(USE.NAMES = FALSE, nam = names(en2Nams), val = en2Nams, function(nam, val) { + if (identical(nam, .moduleObjectsNam)) { + list(list(envirHash[[nam]][[val]]) |> setNames(.objectsSlot)) |> setNames(val) + } else { + envirHash[[nam]][val] + } + }) + nehn <- names(envirHashNew) + dups <- duplicated(nehn) + if (any(dups)) { + wh <- which(nehn %in% nehn[dups]) + val <- nehn[dups] + envirHashNew <- unlist(envirHashNew[wh], recursive = FALSE) + names(envirHashNew) <- gsub(paste0(val, "."), "", x = names(envirHashNew)) + envirHashNew <- list(envirHashNew) |> setNames(val) + } + envirHash$.xData <- append(envirHash$.xData, envirHashNew) + if (any(names(en2Nams) %in% names(envirHash))) + envirHash[names(en2Nams)] <- NULL + eh <- envirHash + } + } else { + eh <- envirHash[names(envirHash)[names(envirHash) %in% names(moduleFunctionEnvir)]] + } + eh +} + + + + +copyModuleSpecificFunsAndObjs <- function(simPreWhSimList, simPost, currModule) { + for (dotType in dotObjsAndMods) { # need functions + currMods <- simPreWhSimList@.xData[[dotType]][[currModule]] + objsInModuleActive <- ls(currMods, all.names = TRUE) + dontCopyObjs <- c(.objectsSlot, "mod", "Par") # take these from the Cached copy (made 3 lines above) + objsInModuleActive <- setdiff(objsInModuleActive, dontCopyObjs) + if (length(objsInModuleActive)) + list2env(mget(objsInModuleActive, envir = simPreWhSimList@.xData[[dotType]][[currModule]]), + envir = simPost@.xData[[dotType]][[currModule]]) + } +} + + +rmDotUnderscoresInModules <- function(obj, names) { + objNames <- names(obj$.list[[1]]) + dotUnderscoreObjs <- objNames[startsWith(objNames, "._")] + obj$.list[[1]][dotUnderscoreObjs] <- NULL + + 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 + }) + obj +} + + +buildDotObjectsList <- function(object, .objects) { + # 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[[dotMods]][[mod]], all.names = TRUE)) + objects1ByModObjectWhole <- lapply(objectsMods, function(mod) ls(envir = object@.xData[[dotObjs]][[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])) # these are e.g., module::function + 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) + + # depending on how .objects came into this function, it may still have list(.xData = ..., moduleName = ...) + mods <- unlist(unname(modules(object))) + modNamesInDotObjs <- intersect(mods, names(.objects)) + if (length(modNamesInDotObjs)) { + .objects3 <- Map(dotType = dotObjsAndMods, function(dotType) { + Map(modNam = modNamesInDotObjs, function(modNam) { + intersect(.objects[[modNam]], names(object@.xData[[dotType]][[modNam]])) + }) + }) + objects1ByModWhole <- .objects3[[dotMods]] + objects1ByModObjectWhole <- .objects3[[dotObjs]] + .objects <- .objects[".xData"] # they are now in objects1ByModWhole and objects1ByModObjectsWhole + } + + # Now add correct names to create length 3 .objects + if (length(objects1ByModWhole)) + .objects <- suppressWarnings(modifyList2(.objects, list(objects1ByModWhole) |> setNames(.moduleFunctionsNam))) + if (length(objects1ByModObjectWhole)) + .objects <- suppressWarnings(append(.objects, list(objects1ByModObjectWhole) |> setNames(.moduleObjectsNam))) + + .objects +} + +# changedFromCreatesOutputs <- function(hasCurrModule, deps, currModules, simFromCache) { +lsObjectsChanged <- function(lsObjectEnv, changedObjs, hasCurrModule, + currModules, deps) { + 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(changedObjs)] + + expectsInputs <- if (length(hasCurrModule)) { + deps[[hasCurrModule]]@inputObjects$objectName + } else { + aa <- lapply(deps, function(dep) + dep@inputObjects$objectName) + unique(unlist(aa)) + } + + dotObjects <- startsWith(lsObjectEnv, ".") + dotObjectsChanged <- dotObjects %in% TRUE & lsObjectEnv %in% names(changedObjs) + lsObjectEnv[lsObjectEnv %in% changedOutputs | lsObjectEnv %in% expectsInputs | + dotObjectsChanged %in% TRUE] +} + +# } + +lsModObjectsChanged <- function(namesAllMods, changedObjs, hasDotObjs) { + changedModEnvObjs <- character() + if (hasDotObjs) { + # privateObjectsInModules <- attr(simFromCache, ".Cache")$changed + # objsWithChangeInners <- intersect(namesAllMods, names(privateObjectsInModules)) + # changedModEnvObjs <- privateObjectsInModules[objsWithChangeInners] + objsWithChangeInners <- intersect(namesAllMods, names(changedObjs)) # this is the whole "module" level; not individual objs + changedModEnvObjs <- changedObjs[objsWithChangeInners] + } + changedModEnvObjs +} + + +#' Convenience wrapper around `clearCache` for SpaDES events +#' +#' This will clear only the event- and module-level caching that is triggered +#' using a module parameter, `.useCache`. +#' +#' @inheritParams clearCache +#' @export +#' @returns A list of individual `clearCache` outputs, one for each event that was +#' cleared. +clearCacheEventsOnly <- function(ask = TRUE, + x = getOption("reproducible.cachePath"), + verbose = getOption("reproducible.verbose")) { + rr <- lapply(unique(showCache(x)[grepl("function", tagKey) & + (grepl(".inputObjects", tagValue) | + grepl("doEvent", tagValue)), + ]$cacheId), function(y) clearCache(cacheId = y, ask = ask)) +} diff --git a/R/copy.R b/R/copy.R index 3fd93dd8..b4e11fd3 100644 --- a/R/copy.R +++ b/R/copy.R @@ -61,17 +61,20 @@ setMethod("Copy", #sim_@.xData <- new.env(parent = asNamespace("SpaDES.core")) #sim_@.xData <- new.env(parent = as.environment("package:SpaDES.core")) sim_@.xData <- new.env(parent = emptyenv()) - sim_@.xData$.mods <- new.env(parent = asNamespace("SpaDES.core")) + sim_@.xData[[dotMods]] <- new.env(parent = asNamespace("SpaDES.core")) + # Setup dotObjs later because it is not vectorized over module attr(sim_@.xData, "name") <- "sim" # # set up mod environments, including .objects - for (modNam in names(object@.xData$.mods)) { - sim_ <- newEnvsByModule(sim_, modNam) - } + for (dotType in dotObjsAndMods) + for (modNam in names(object@.xData[[dotType]])) { + sim_ <- newEnvsByModule(sim_, modNam) + } if (objects == 2) { - dotObjsNotDotMods <- grep("\\.mods", ls(object@.xData, pattern = "^\\.", all.names = TRUE), + dotObjsNotDotMods <- grep(paste0("\\", dotMods, "|", "\\", dotObjs), # "\\.mods", + ls(object@.xData, pattern = "^\\.", all.names = TRUE), invert = TRUE, value = TRUE) list2env(Copy(mget(dotObjsNotDotMods, envir = object@.xData)), envir = sim_@.xData) @@ -79,31 +82,31 @@ setMethod("Copy", if (objects > 0) { # browser(expr = exists("._Copy_6")) - objNames <- ls(object@.xData$.mods, all.names = TRUE) + # # Make sure that the file-backed objects get a copy too -- use Copy -- makes a list + if (objects == 1) { + # Copy the whole environment, recursively through environments + sim_@.xData <- Copy(object@.xData, ...) # filebackedDir = filebackedDir) + } + + objNames <- ls(object@.xData[[dotObjs]], all.names = TRUE) if (isTRUE(is.character(modules))) { objNames <- objNames[match(modules, objNames)] } names(objNames) <- objNames isEnv <- unlist(lapply(objNames, function(obj) { - is.environment(get(obj, envir = object@.xData$.mods)) + is.environment(get(obj, envir = object@.xData[[dotObjs]])) })) - # # Make sure that the file-backed objects get a copy too -- use Copy -- makes a list - - if (objects == 1) { - # Copy the whole environment, recursively through environments - sim_@.xData <- Copy(object@.xData, ...) # filebackedDir = filebackedDir) - } # This chunk makes the environment of each function in a module, # the module itself. This is unique to functions in `simList` objs # i.e., can't rely on generic reproducible::Copy lapply(objNames[isEnv], function(en) { - list2env(as.list(object@.xData$.mods[[en]], all.names = TRUE), - envir = sim_@.xData$.mods[[en]]) - isFn <- unlist(lapply(ls(sim_@.xData$.mods[[en]]), function(obj) { - if (is.function(get(obj, envir = sim_@.xData$.mods[[en]]))) { - environment(sim_@.xData$.mods[[en]][[obj]]) <- sim_@.xData$.mods[[en]] + list2env(as.list(object@.xData[[dotObjs]][[en]], all.names = TRUE), + envir = sim_@.xData[[dotObjs]][[en]]) + isFn <- unlist(lapply(ls(sim_@.xData[[dotObjs]][[en]]), function(obj) { + if (is.function(get(obj, envir = sim_@.xData[[dotObjs]][[en]]))) { + environment(sim_@.xData[[dotObjs]][[en]][[obj]]) <- sim_@.xData[[dotObjs]][[en]] } } )) @@ -115,11 +118,17 @@ setMethod("Copy", modsToCopy <- intersect(modules, modsToCopy) } lapply(modsToCopy, function(mod) { - if (exists(mod, envir = sim_@.xData$.mods, inherits = FALSE)) { - rm(list = ".objects", envir = sim_@.xData$.mods[[mod]], inherits = FALSE) - sim_@.xData$.mods[[mod]]$.objects <- new.env(parent = emptyenv()) - list2env(as.list(object@.xData$.mods[[mod]]$.objects, all.names = TRUE), - envir = sim_@.xData$.mods[[mod]]$.objects) + if (exists(mod, envir = sim_@.xData[[dotObjs]], inherits = FALSE)) { + # rm(list = ".objects", envir = sim_@.xData[[dotMods]][[mod]], inherits = FALSE) + # sim_@.xData[[dotMods]][[mod]]$.objects <- new.env(parent = emptyenv()) + # list2env(as.list(object@.xData[[dotMods]][[mod]]$.objects, all.names = TRUE), + # envir = sim_@.xData[[dotMods]][[mod]]$.objects) + rm(list = mod, envir = sim_@.xData[[dotObjs]], inherits = FALSE) + sim_ <- setupModObjsEnv(sim_, moduleName = mod) + # rm(list = ".objects", envir = sim_@.xData[[dotMods]][[mod]], inherits = FALSE) + # sim_@.xData[[dotMods]][[mod]]$.objects <- new.env(parent = emptyenv()) + list2env(as.list(object@.xData[[dotObjs]][[mod]], all.names = TRUE), + envir = sim_@.xData[[dotObjs]][[mod]]) } }) diff --git a/R/modActiveBinding.R b/R/modActiveBinding.R index 63571771..0c2316bb 100644 --- a/R/modActiveBinding.R +++ b/R/modActiveBinding.R @@ -42,8 +42,10 @@ activeModBindingFunction <- function(value) { sim <- try(get("sim", simEnv, inherits = FALSE), silent = TRUE) if (!is(sim, "try-error")) { mod <- currentModule(sim) - if (length(mod) && !is.null(sim@.xData$.mods[[mod]])) - ret <- get(".objects", envir = sim@.xData$.mods[[mod]], inherits = FALSE) + if (length(mod) && !is.null(sim@.xData[[dotObjs]][[mod]])) { + ret <- get(mod, envir = sim@.xData[[dotObjs]], inherits = FALSE) + # ret <- get(".objects", envir = sim@.xData[[dotObjs]][[mod]], inherits = FALSE) + } } } } else { From 6d755a3b45492db8eabdd93b2f0fa11d38c87374 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Tue, 27 May 2025 18:09:19 -0700 Subject: [PATCH 105/128] reexports --- R/reexports.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/reexports.R b/R/reexports.R index 6ff765f1..7e8ca5fb 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -25,6 +25,7 @@ layerNamesDelimiter <- getFromNamespace("layerNamesDelimiter", "reproducible") .updateTagsRepo <- getFromNamespace(".updateTagsRepo", "reproducible") .addTagsRepo <- getFromNamespace(".addTagsRepo", "reproducible") ._prepInputsMetadata <- getFromNamespace("._prepInputsMetadata", "reproducible") +.txtNoPrefix <- getFromNamespace(".txtNoPrefix", "reproducible") makeAbsolute <- getFromNamespace("makeAbsolute", "reproducible") From 628904a19379e29223cb839d5876dc463181fd83 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:05:39 -0700 Subject: [PATCH 106/128] redoc --- man/Copy.Rd | 4 +++ man/SpaDES.core-package.Rd | 6 ++-- man/addChangedAttr.Rd | 13 ++++++- man/addTagsToOutput.Rd | 12 ++++++- man/cacheMessage.Rd | 18 ++++++++-- man/checkCacheRepo.Rd | 9 +++-- man/clearCache.Rd | 63 +++++++++++++++++++++++++++++++++ man/clearCacheEventsOnly.Rd | 21 ++++++++++- man/createDESCRIPTIONandDocs.Rd | 6 ++++ man/dealWithClass.Rd | 33 +++++++++++++++++ man/loadSimList.Rd | 6 ++++ man/makeMemoisable.Rd | 6 +++- man/objSize.simList.Rd | 11 ++++++ man/preDigestByClass.Rd | 7 ++-- man/prepareOutput.Rd | 12 +++++-- man/robustDigest.Rd | 31 ++++++++++++++-- man/tagsByClass.Rd | 7 ++-- 17 files changed, 246 insertions(+), 19 deletions(-) diff --git a/man/Copy.Rd b/man/Copy.Rd index 379c01e9..1fde21da 100644 --- a/man/Copy.Rd +++ b/man/Copy.Rd @@ -7,6 +7,8 @@ \S4method{Copy}{simList}(object, objects, queues, modules, ...) } \arguments{ +\item{object}{An R object (likely containing environments) or an environment.} + \item{objects}{Whether the objects contained within the \code{simList} environment should be copied. Default \code{TRUE}, which may be slow.} @@ -14,6 +16,8 @@ should be copied. Default \code{TRUE}, which may be slow.} be deep copied via \code{data.table::copy()}} \item{modules}{Logical. Should list of modules be copied.} + +\item{...}{Only used for custom Methods} } \value{ a copy of \code{object} diff --git a/man/SpaDES.core-package.Rd b/man/SpaDES.core-package.Rd index fd5ec1cc..ce58ec98 100644 --- a/man/SpaDES.core-package.Rd +++ b/man/SpaDES.core-package.Rd @@ -366,9 +366,9 @@ See example in \code{\link[=spades]{spades()}}, achieved by using \code{cache = \tabular{ll}{ \code{\link[reproducible:Cache]{reproducible::Cache()}} \tab Caches a function, but often accessed as argument in \code{\link[=spades]{spades()}}\cr -\code{\link[reproducible:showCache]{reproducible::showCache()}} \tab Shows information about the objects in the cache\cr -\code{\link[reproducible:clearCache]{reproducible::clearCache()}} \tab Removes objects from the cache\cr -\code{\link[reproducible:keepCache]{reproducible::keepCache()}} \tab Keeps only the objects described\cr +\code{\link[reproducible:viewCache]{reproducible::showCache()}} \tab Shows information about the objects in the cache\cr +\code{\link[reproducible:viewCache]{reproducible::clearCache()}} \tab Removes objects from the cache\cr +\code{\link[reproducible:viewCache]{reproducible::keepCache()}} \tab Keeps only the objects described\cr } A module developer can build caching into their module by creating cached versions of their diff --git a/man/addChangedAttr.Rd b/man/addChangedAttr.Rd index d32a975e..5a9dde31 100644 --- a/man/addChangedAttr.Rd +++ b/man/addChangedAttr.Rd @@ -6,6 +6,17 @@ \usage{ \S4method{.addChangedAttr}{simList}(object, preDigest, origArguments, ...) } +\arguments{ +\item{object}{Any R object returned from a function} + +\item{preDigest}{The full, element by element hash of the input arguments to that same function, +e.g., from \code{.robustDigest}} + +\item{origArguments}{These are the actual arguments (i.e., the values, not the names) that +were the source for \code{preDigest}} + +\item{...}{Anything passed to methods.} +} \value{ returns the object with attribute added } @@ -17,5 +28,5 @@ When this function is subsequently called again, only these changed objects will be returned. All other \code{simList} objects will remain unchanged. } \seealso{ -\link[reproducible:.addChangedAttr]{reproducible::.addChangedAttr} +\link[reproducible:exportedMethods]{reproducible::.addChangedAttr} } diff --git a/man/addTagsToOutput.Rd b/man/addTagsToOutput.Rd index 72b55419..4c997b19 100644 --- a/man/addTagsToOutput.Rd +++ b/man/addTagsToOutput.Rd @@ -6,11 +6,21 @@ \usage{ \S4method{.addTagsToOutput}{simList}(object, outputObjects, FUN, preDigestByClass) } +\arguments{ +\item{object}{Any R object returned from a function} + +\item{outputObjects}{Optional character vector indicating which objects to +return. This is only relevant for list, environment (or similar) objects} + +\item{FUN}{A function} + +\item{preDigestByClass}{A list, usually from \code{.preDigestByClass}} +} \value{ modified \code{object}, with attributes added } \description{ -See \code{\link[reproducible:.addTagsToOutput]{reproducible::.addTagsToOutput()}}. +See \code{\link[reproducible:exportedMethods]{reproducible::.addTagsToOutput()}}. } \author{ Eliot McIntire diff --git a/man/cacheMessage.Rd b/man/cacheMessage.Rd index 0fe08767..371e8ecd 100644 --- a/man/cacheMessage.Rd +++ b/man/cacheMessage.Rd @@ -11,9 +11,23 @@ verbose = getOption("reproducible.verbose") ) } +\arguments{ +\item{object}{Any R object returned from a function} + +\item{functionName}{A character string indicating the function name} + +\item{fromMemoise}{Logical. If \code{TRUE}, the message will be about +recovery from memoised copy} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} +} \description{ -See \code{\link[reproducible:.cacheMessage]{reproducible::.cacheMessage()}}. +See \code{\link[reproducible:exportedMethods]{reproducible::.cacheMessage()}}. } \seealso{ -\link[reproducible:.cacheMessage]{reproducible::.cacheMessage} +\link[reproducible:exportedMethods]{reproducible::.cacheMessage} } diff --git a/man/checkCacheRepo.Rd b/man/checkCacheRepo.Rd index 6f66db30..6eeccd93 100644 --- a/man/checkCacheRepo.Rd +++ b/man/checkCacheRepo.Rd @@ -6,12 +6,17 @@ \usage{ \S4method{.checkCacheRepo}{list}(object, create = FALSE) } +\arguments{ +\item{object}{Any R object returned from a function} + +\item{create}{Logical. If TRUE, then it will create the path for cache.} +} \value{ character string representing a directory path to the cache repo } \description{ -See \code{\link[reproducible:.checkCacheRepo]{reproducible::.checkCacheRepo()}}. +See \code{\link[reproducible:exportedMethods]{reproducible::.checkCacheRepo()}}. } \seealso{ -\link[reproducible:.checkCacheRepo]{reproducible::.checkCacheRepo} +\link[reproducible:exportedMethods]{reproducible::.checkCacheRepo} } diff --git a/man/clearCache.Rd b/man/clearCache.Rd index 835eb52c..90f7a662 100644 --- a/man/clearCache.Rd +++ b/man/clearCache.Rd @@ -48,10 +48,73 @@ ) } \arguments{ +\item{x}{A simList or a directory containing a valid Cache repository. Note: +For compatibility with \code{Cache} argument, \code{cachePath} can also be +used instead of \code{x}, though \code{x} will take precedence.} + +\item{userTags}{Character vector. If used, this will be used in place of the +\code{after} and \code{before}. +Specifying one or more \code{userTag} here will clear all +objects that match those tags. +Matching is via regular expression, meaning partial matches +will work unless strict beginning (\code{^}) and end (\code{$}) of string +characters are used. +Matching will be against any of the 3 columns returned by \code{showCache()}, +i.e., \code{artifact}, \code{tagValue} or \code{tagName}. +Also, if \code{length(userTags) > 1}, then matching is by \code{and}. +For \code{or} matching, use \code{|} in a single character string. +See examples.} + +\item{after}{A time (POSIX, character understandable by data.table). +Objects cached after this time will be shown or deleted.} + +\item{before}{A time (POSIX, character understandable by data.table). +Objects cached before this time will be shown or deleted.} + +\item{fun}{An optional character vector describing the function name to extract. +Only functions with this/these functions will be returned.} + +\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. +Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, +this will also be dramatically faster than using \code{userTags}, for a large +cache.} + +\item{ask}{Logical. If \code{FALSE}, then it will not ask to confirm deletions using +\code{clearCache} or \code{keepCache}. Default is \code{TRUE}} + +\item{useCloud}{Logical. If \code{TRUE}, then every object that is deleted locally will +also be deleted in the \code{cloudFolderID}, if it is non-\code{NULL}} + +\item{cloudFolderID}{A googledrive dribble of a folder, e.g., using \code{drive_mkdir()}. +If left as \code{NULL}, the function will create a cloud folder with name from last +two folder levels of the \code{cachePath} path, : +\code{paste0(basename(dirname(cachePath)), "_", basename(cachePath))}. +This \code{cloudFolderID} will be added to \code{options("reproducible.cloudFolderID")}, +but this will not persist across sessions. If this is a character string, it will +treat this as a folder name to create or use on GoogleDrive.} + \item{drv}{an object that inherits from \code{DBIDriver}, or an existing \code{DBIConnection} object (in order to clone an existing connection).} \item{conn}{A \code{DBIConnection} object, as returned by \code{dbConnect()}.} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} + +\item{...}{Other arguments. Can be in the form of \code{tagKey = tagValue}, such as, +\code{class = "numeric"} to find all entries that are numerics in the cache. +Note: the special cases of \code{cacheId} and \code{fun} have their own +named arguments in these functions. +Also can be \code{regexp = xx}, where \code{xx} is \code{TRUE} if the user +is passing a regular expression. +Otherwise, \code{userTags} will need to be exact matches. Default is +missing, which is the same as \code{TRUE}. If there are errors due +to regular expression problem, try \code{FALSE}. For \code{cc}, it is +passed to \code{clearCache}, e.g., \code{ask}, \code{userTags}. For \code{showCache}, +it can also be \code{sorted = FALSE} to return the object unsorted.} } \value{ A \code{data.table} object showing the subset of items in the cache, located at \code{cachePath} diff --git a/man/clearCacheEventsOnly.Rd b/man/clearCacheEventsOnly.Rd index e1c3584c..7de3339f 100644 --- a/man/clearCacheEventsOnly.Rd +++ b/man/clearCacheEventsOnly.Rd @@ -5,11 +5,30 @@ \title{Convenience wrapper around \code{clearCache} for SpaDES events} \usage{ clearCacheEventsOnly( - ask, + ask = TRUE, x = getOption("reproducible.cachePath"), + dryRun = FALSE, verbose = getOption("reproducible.verbose") ) } +\arguments{ +\item{ask}{Logical. If \code{FALSE}, then it will not ask to confirm deletions using +\code{clearCache} or \code{keepCache}. Default is \code{TRUE}} + +\item{x}{A simList or a directory containing a valid Cache repository. Note: +For compatibility with \code{Cache} argument, \code{cachePath} can also be +used instead of \code{x}, though \code{x} will take precedence.} + +\item{dryRun}{logical. If \code{FALSE}, the default, then the function will deleted +entries in the Cache. If \code{TRUE}, the function will identify which events and .inputObjects +will be deleted, without deleting them.} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} +} \value{ A list of individual \code{clearCache} outputs, one for each event that was cleared. diff --git a/man/createDESCRIPTIONandDocs.Rd b/man/createDESCRIPTIONandDocs.Rd index b517cfd5..8b81e0b7 100644 --- a/man/createDESCRIPTIONandDocs.Rd +++ b/man/createDESCRIPTIONandDocs.Rd @@ -24,6 +24,12 @@ be imported. If \code{FALSE}, then only functions explicitly imported using \item{buildDocuments}{A logical. If \code{TRUE}, the default, then the documentation will be built, if any exists, using \code{roxygen2::roxygenise}.} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} } \value{ Invoked for its side effects. There will be a new or modified diff --git a/man/dealWithClass.Rd b/man/dealWithClass.Rd index 5768a6fc..8448bcb9 100644 --- a/man/dealWithClass.Rd +++ b/man/dealWithClass.Rd @@ -39,10 +39,43 @@ ) } \arguments{ +\item{obj}{Any arbitrary R object.} + +\item{cachePath}{A repository used for storing cached objects. +This is optional if \code{Cache} is used inside a SpaDES module.} + +\item{preDigest}{The list of \code{preDigest} that comes from \code{CacheDigest} of an object} + \item{drv}{an object that inherits from \code{DBIDriver}, or an existing \code{DBIConnection} object (in order to clone an existing connection).} \item{conn}{A \code{DBIConnection} object, as returned by \code{dbConnect()}.} + +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} + +\item{outputObjects}{Optional character vector indicating which objects to +return. This is only relevant for list, environment (or similar) objects} + +\item{cacheId}{An optional character vector describing the \code{cacheId}s to extract. +Only entries with this/these \code{cacheId}s will be returned. If \code{useDBI(FALSE)}, +this will also be dramatically faster than using \code{userTags}, for a large +cache.} + +\item{...}{Other arguments. Can be in the form of \code{tagKey = tagValue}, such as, +\code{class = "numeric"} to find all entries that are numerics in the cache. +Note: the special cases of \code{cacheId} and \code{fun} have their own +named arguments in these functions. +Also can be \code{regexp = xx}, where \code{xx} is \code{TRUE} if the user +is passing a regular expression. +Otherwise, \code{userTags} will need to be exact matches. Default is +missing, which is the same as \code{TRUE}. If there are errors due +to regular expression problem, try \code{FALSE}. For \code{cc}, it is +passed to \code{clearCache}, e.g., \code{ask}, \code{userTags}. For \code{showCache}, +it can also be \code{sorted = FALSE} to return the object unsorted.} } \value{ The same object as passed into the function, but dealt with so that it can be diff --git a/man/loadSimList.Rd b/man/loadSimList.Rd index d626e350..424681aa 100644 --- a/man/loadSimList.Rd +++ b/man/loadSimList.Rd @@ -36,6 +36,12 @@ incorrect paths in \code{Filenames(sim)} if the the \code{file} being read in is a different computer, path, or drive. This could be the output from \code{unzipSimList} (which is calls \code{loadSimList} internally, passing the unzipped filenames)} +\item{verbose}{Numeric, -1 silent (where possible), 0 being very quiet, +1 showing more messaging, 2 being more messaging, etc. +Default is 1. Above 3 will output much more information about the internals of +Caching, which may help diagnose Caching challenges. Can set globally with an +option, e.g., \verb{options('reproducible.verbose' = 0) to reduce to minimal}} + \item{zipfile}{Filename of a zipped \code{simList}} \item{load}{Logical. If \code{TRUE}, the default, then the \code{simList} will diff --git a/man/makeMemoisable.Rd b/man/makeMemoisable.Rd index 5344e35a..1380d0ee 100644 --- a/man/makeMemoisable.Rd +++ b/man/makeMemoisable.Rd @@ -9,6 +9,10 @@ \method{unmakeMemoisable}{simList_}(x) } +\arguments{ +\item{x}{An object to make memoisable. +See individual methods in other packages.} +} \value{ A \code{simList_} object or a \code{simList}, in the case of \code{unmakeMemoisable}. } @@ -18,5 +22,5 @@ memoise a \code{simList}. This method for \code{simList} converts the object to a \code{simList_} first. } \seealso{ -\code{\link[reproducible:makeMemoisable]{reproducible::makeMemoisable()}} +\code{\link[reproducible:exportedMethods]{reproducible::makeMemoisable()}} } diff --git a/man/objSize.simList.Rd b/man/objSize.simList.Rd index 5a157263..bcb91864 100644 --- a/man/objSize.simList.Rd +++ b/man/objSize.simList.Rd @@ -6,6 +6,17 @@ \usage{ \method{objSize}{simList}(x, quick = FALSE, recursive = FALSE, ...) } +\arguments{ +\item{x}{An object} + +\item{quick}{Logical. If \code{FALSE}, then an attribute, "objSize" will be added to +the returned value, with each of the elements' object size returned also.} + +\item{recursive}{Logical. If \code{TRUE}, then, in addition to evaluating the whole object, +it will also return the recursive sizes of the elements of a list or environment.} + +\item{...}{Additional arguments (currently unused), enables backwards compatible use.} +} \value{ an estimate of the size of the object, in bytes. } diff --git a/man/preDigestByClass.Rd b/man/preDigestByClass.Rd index 151cdbd0..0cbb7578 100644 --- a/man/preDigestByClass.Rd +++ b/man/preDigestByClass.Rd @@ -6,6 +6,9 @@ \usage{ \S4method{.preDigestByClass}{simList}(object) } +\arguments{ +\item{object}{Any R object returned from a function} +} \value{ character vector corresponding to the names of objects stored in the \code{.xData} slot } @@ -13,10 +16,10 @@ character vector corresponding to the names of objects stored in the \code{.xDat Takes a snapshot of \code{simList} objects. } \details{ -See \code{\link[reproducible:.preDigestByClass]{reproducible::.preDigestByClass()}}. +See \code{\link[reproducible:exportedMethods]{reproducible::.preDigestByClass()}}. } \seealso{ -\link[reproducible:.preDigestByClass]{reproducible::.preDigestByClass} +\link[reproducible:exportedMethods]{reproducible::.preDigestByClass} } \author{ Eliot McIntire diff --git a/man/prepareOutput.Rd b/man/prepareOutput.Rd index 1472009a..3ae71de5 100644 --- a/man/prepareOutput.Rd +++ b/man/prepareOutput.Rd @@ -6,12 +6,20 @@ \usage{ \S4method{.prepareOutput}{simList}(object, cachePath, ...) } +\arguments{ +\item{object}{Any R object returned from a function} + +\item{cachePath}{A repository used for storing cached objects. +This is optional if \code{Cache} is used inside a SpaDES module.} + +\item{...}{Anything passed to methods.} +} \value{ the modified \code{object} } \description{ -See \code{\link[reproducible:.prepareOutput]{reproducible::.prepareOutput()}}. +See \code{\link[reproducible:exportedMethods]{reproducible::.prepareOutput()}}. } \seealso{ -\link[reproducible:.prepareOutput]{reproducible::.prepareOutput} +\link[reproducible:exportedMethods]{reproducible::.prepareOutput} } diff --git a/man/robustDigest.Rd b/man/robustDigest.Rd index 99afa5a1..d1075263 100644 --- a/man/robustDigest.Rd +++ b/man/robustDigest.Rd @@ -7,18 +7,45 @@ \usage{ \S4method{.robustDigest}{simList}(object, .objects, length, algo = "xxhash64", quick, classOptions) } +\arguments{ +\item{object}{an object to digest.} + +\item{.objects}{Character vector of objects to be digested. This is only applicable +if there is a list, environment (or similar) with named objects +within it. Only this/these objects will be considered for caching, +i.e., only use a subset of +the list, environment or similar objects. In the case of nested list-type +objects, this will only be applied outermost first.} + +\item{length}{Numeric. If the element passed to Cache is a \code{Path} class +object (from e.g., \code{asPath(filename)}) or it is a \code{Raster} with +file-backing, then this will be +passed to \code{digest::digest}, essentially limiting the number of bytes +to digest (for speed). This will only be used if \code{quick = FALSE}. +Default is \code{getOption("reproducible.length")}, which is set to \code{Inf}.} + +\item{algo}{The digest algorithm to use. Default \code{xxhash64} (see \code{\link[digest:digest]{digest::digest()}} for others).} + +\item{quick}{Logical or character. If \code{TRUE}, +no disk-based information will be assessed, i.e., only +memory content. See Details section about \code{quick} in \code{\link[reproducible:Cache]{Cache()}}.} + +\item{classOptions}{Optional list. This will pass into \code{.robustDigest} for +specific classes. Should be options that the \code{.robustDigest} knows what +to do with.} +} \description{ This is intended to be used within the \code{Cache} function, but can be used to evaluate what a \code{simList} would look like once it is converted to a repeatably digestible object. } \details{ -See \code{\link[reproducible:.robustDigest]{reproducible::.robustDigest()}}. +See \code{\link[reproducible:robustDigest]{reproducible::.robustDigest()}}. This method strips out stuff from a \code{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. } \seealso{ -\code{\link[reproducible:.robustDigest]{reproducible::.robustDigest()}} +\code{\link[reproducible:robustDigest]{reproducible::.robustDigest()}} } \author{ Eliot McIntire diff --git a/man/tagsByClass.Rd b/man/tagsByClass.Rd index 1dd20e38..9079ca49 100644 --- a/man/tagsByClass.Rd +++ b/man/tagsByClass.Rd @@ -6,12 +6,15 @@ \usage{ \S4method{.tagsByClass}{simList}(object) } +\arguments{ +\item{object}{Any R object returned from a function} +} \description{ -See \code{\link[reproducible:.tagsByClass]{reproducible::.tagsByClass()}}. Adds current \code{moduleName}, +See \code{\link[reproducible:exportedMethods]{reproducible::.tagsByClass()}}. Adds current \code{moduleName}, \code{eventType}, \code{eventTime}, and \verb{function:spades} as \code{userTags}. } \seealso{ -\link[reproducible:.tagsByClass]{reproducible::.tagsByClass} +\link[reproducible:exportedMethods]{reproducible::.tagsByClass} } \author{ Eliot McIntire From 1adb051c2b2fed5e8769f1bfabed690a75914571 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:06:10 -0700 Subject: [PATCH 107/128] clearCacheEventsOnly --- R/cache.R | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/R/cache.R b/R/cache.R index d3b88238..9598a69f 100644 --- a/R/cache.R +++ b/R/cache.R @@ -1481,15 +1481,31 @@ lsModObjectsChanged <- function(namesAllMods, changedObjs, hasDotObjs) { #' This will clear only the event- and module-level caching that is triggered #' using a module parameter, `.useCache`. #' -#' @inheritParams clearCache +#' @inheritParams reproducible::clearCache +#' @param dryRun logical. If `FALSE`, the default, then the function will deleted +#' entries in the Cache. If `TRUE`, the function will identify which events and .inputObjects +#' will be deleted, without deleting them. #' @export #' @returns A list of individual `clearCache` outputs, one for each event that was #' cleared. clearCacheEventsOnly <- function(ask = TRUE, - x = getOption("reproducible.cachePath"), + x = getOption("reproducible.cachePath"), dryRun = FALSE, verbose = getOption("reproducible.verbose")) { - rr <- lapply(unique(showCache(x)[grepl("function", tagKey) & - (grepl(".inputObjects", tagValue) | - grepl("doEvent", tagValue)), - ]$cacheId), function(y) clearCache(cacheId = y, ask = ask)) + sc <- showCache(x, verbose = verbose) + grepDoEventOrDotInputObjects <- quote(grepl("function", tagKey) & (grepl(".inputObjects", tagValue) | + grepl("doEvent", tagValue))) + cacheIds <- unique(sc[eval(grepDoEventOrDotInputObjects) + ]$cacheId) + if (isTRUE(dryRun)) + messageVerbose(verbose = verbose, "dryRun = TRUE, no clearing...") + + rr <- lapply(cacheIds, function(y) { + df <- sc[cacheId == y & eval(grepDoEventOrDotInputObjects)] + mess <- paste0(df$tagValue) + if (isTRUE(dryRun)) + mess <- paste0("Would remove: ", mess) + messageVerbose(verbose = verbose, mess) + if (isFALSE(dryRun)) + clearCache(cacheId = y, ask = ask, verbose = verbose - 1) + }) } From a7edfcf76ad43ad4373f42a5fc0e43f49c90f284 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:16:34 -0700 Subject: [PATCH 108/128] redoc --- ...NY-ANY-method.Rd => sub-simList-character-ANY-method.Rd} | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) rename man/{sub-simList-character-ANY-ANY-method.Rd => sub-simList-character-ANY-method.Rd} (85%) diff --git a/man/sub-simList-character-ANY-ANY-method.Rd b/man/sub-simList-character-ANY-method.Rd similarity index 85% rename from man/sub-simList-character-ANY-ANY-method.Rd rename to man/sub-simList-character-ANY-method.Rd index e87e6bff..2a5fa6a3 100644 --- a/man/sub-simList-character-ANY-ANY-method.Rd +++ b/man/sub-simList-character-ANY-method.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/simList-accessors.R -\name{[,simList,character,ANY,ANY-method} -\alias{[,simList,character,ANY,ANY-method} +\name{[,simList,character,ANY-method} +\alias{[,simList,character,ANY-method} \title{Extract an intact \code{simList} but with subset of objects} \usage{ -\S4method{[}{simList,character,ANY,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{simList,character,ANY}(x, i, j, ..., drop = TRUE) } \arguments{ \item{x}{A \code{simList}} From d0877511412aec4cb6c4d2477a4f265e0eb4a35a Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:16:51 -0700 Subject: [PATCH 109/128] minor --- R/cache.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cache.R b/R/cache.R index 9598a69f..865161ed 100644 --- a/R/cache.R +++ b/R/cache.R @@ -484,7 +484,7 @@ setMethod( changedObjs <- out[lengths(out) > 0 | (names(out) %in% modulesInObject)] changed <- changedObjs - if (!any(modulesInObject %in% names(changed))) { # it needs to be nested list + if (!any(modulesInObject %in% names(changed)) && NROW(object@current)) { # NROW object@current is for Caching of sim, pre-module running currMod <- object@current[[2]] changed <- append(changed, list(list()) |> setNames(currMod)) } From 2e90707cdd79d3260b261e9ff3907ac085b93a31 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:17:30 -0700 Subject: [PATCH 110/128] nestedSimList additions --- R/simulation-simInit.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 9959cbd4..6637b3d2 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -377,14 +377,18 @@ setMethod( # ._startClockTime <- dots[[._txtStartClockTime]] dots[[._txtStartClockTime]] <- NULL dotNames <- setdiff(...names(), ._txtStartClockTime) + + + # loggingMessage helpers + ._simNestingLocal <- simNestingSetup(...) # checks in call stack for "sim" + assign(._txtSimNesting, ._simNestingLocal) + # create <- List object for the simulation sim <- new("simList") sim@.xData[[._txtStartClockTime]] <- get(._txtStartClockTime, inherits = FALSE) sim$._simInitElapsedTime <- 0 # loggingMessage helpers - # assign(._txtSimNesting, simNestingSetup(...)) - ._simNestingLocal <- simNestingSetup(...) sim[[._txtSimNesting]] <- ._simNestingLocal opt <- options("encoding" = "UTF-8") From 8ed65d887c07c642a85b12c78577fb6eb28ec6ff Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:17:44 -0700 Subject: [PATCH 111/128] loadOrder additions --- R/simulation-simInit.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 6637b3d2..fe93aa81 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -641,6 +641,8 @@ setMethod( ## check user-supplied load order & init dependencies sim@.xData$._ranInitDuringSimInit <- character() + missingInLoadOrder <- setdiff(sim@modules, loadOrder) + if (!all(length(loadOrder), all(sim@modules %in% loadOrder), all(loadOrder %in% sim@modules))) { @@ -648,7 +650,17 @@ setMethod( sim <- resolveDepsRunInitIfPoss(sim, modules, paths, params, objects, inputs, outputs) if (length(sim@completed)) sim@.xData$._ranInitDuringSimInit <- setdiff(completed(sim)$module, .coreModules()) - loadOrder <- unlist(unname(sim@modules)) + loadOrderPoss <- unlist(unname(sim@modules)) + if (length(missingInLoadOrder)) { + if (any(match(loadOrder, loadOrderPoss) != seq_along(loadOrder))) { + warning("loadOrder argument is used, but does not have all the modules in it; ", + "setting modules in loadOrder first, with remaining modules place after... ", + "this may be incorrect behaviour and should likely be changed") + modsAfter <- setdiff(loadOrderPoss, loadOrder) + loadOrderPoss <- c(loadOrder, modsAfter) + } + } + loadOrder <- loadOrderPoss } mBase <- basename2(unlist(sim@modules)) From 11404e5ea46ca1ec7febea161f5ccfe97080c32c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:18:12 -0700 Subject: [PATCH 112/128] minor --- R/simulation-simInit.R | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index fe93aa81..a938ae63 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -874,9 +874,9 @@ setMethod( notOlderThan, ...) { namesMatchCall <- names(match.call()) namesMatchCall <- setdiff(namesMatchCall, ...names()) - - li <- lapply(namesMatchCall[-1], function(x) eval(parse(text = x))) - names(li) <- namesMatchCall[-1] + li <- Map(x = namesMatchCall[-1], function(x) eval(parse(text = x))) + # li <- lapply(namesMatchCall[-1], function(x) eval(parse(text = x))) + # names(li) <- namesMatchCall[-1] # find the simInit call that was responsible for this, get the objects # in the environment of the parents of that call, and pass them to new # environment. @@ -921,9 +921,8 @@ setMethod( notOlderThan, ...) { namesMatchCall <- names(match.call()) namesMatchCall <- setdiff(namesMatchCall, ...names()) - - li <- lapply(namesMatchCall[-1], function(x) eval(parse(text = x))) - names(li) <- namesMatchCall[-1] + li <- Map(x = namesMatchCall[-1], function(x) eval(parse(text = x))) + # names(li) <- namesMatchCall[-1] li$modules <- as.list(modules) li <- .fillInSimInit(li, namesMatchCall) @@ -965,9 +964,7 @@ setMethod( namesMatchCall <- names(match.call()) namesMatchCall <- setdiff(namesMatchCall, ...names()) - li <- lapply(namesMatchCall[-1], function(x) eval(parse(text = x))) - names(li) <- namesMatchCall[-1] - + li <- Map(x = namesMatchCall[-1], function(x) eval(parse(text = x))) li <- .fillInSimInit(li, namesMatchCall) expectedClasses <- c("list", From 915d145f14a29dbf8d007d642ef6dd05d255718f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:19:05 -0700 Subject: [PATCH 113/128] more nesting --- R/simulation-simInit.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index a938ae63..33b5fa6e 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1286,8 +1286,9 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out # loggingMessage helpers simNestingRevert <- sim[[._txtSimNesting]] on.exit(sim[[._txtSimNesting]] <- simNestingRevert, add = TRUE) - sim[[._txtSimNesting]] <- simNestingOverride(sim, mBase) - ._simNestingLocal <- sim[[._txtSimNesting]] + sim[[._txtSimNesting]] <- simNestingOverride(sim, sim@current$moduleName) + assign(._txtSimNesting, sim[[._txtSimNesting]]) + # ._simNesting <- sim[[._txtSimNesting]] allObjsProvided <- sim@depends@dependencies[[i]]@inputObjects[["objectName"]] %in% sim$.userSuppliedObjNames From 7b726b797309cd94d7c2be5d634f8b40f4584595 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:19:22 -0700 Subject: [PATCH 114/128] more dotObjs --- R/simulation-simInit.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 33b5fa6e..8c1bf6bc 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1329,11 +1329,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out moduleSpecificInputObjects <- sim@depends@dependencies[[i]]@inputObjects[["objectName"]] moduleSpecificInputObjects <- na.omit(moduleSpecificInputObjects) moduleSpecificInputObjects <- c(moduleSpecificInputObjects, m) - moduleSpecificInputObjects <- c(moduleSpecificInputObjects, paste0(".mods$", m)) - # excludeSuppliedElsewhere <- Map(x = moduleSpecificInputObjects, function(x) suppliedElsewhere(x, sim = sim, where = "init")) - # excludeSuppliedElsewhere <- - # names(excludeSuppliedElsewhere[unlist(excludeSuppliedElsewhere)]) - # moduleSpecificInputObjects <- setdiff(moduleSpecificInputObjects, excludeSuppliedElsewhere) + moduleSpecificInputObjects <- c(moduleSpecificInputObjects, paste0(dotMods, "$", m), paste0(dotObjs, "$", m)) # ensure backwards compatibility with non-namespaced modules if (.isNamespaced(sim, mBase)) { From 70584e4f3ad68961bb53d297eb7013a829cc0045 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:19:53 -0700 Subject: [PATCH 115/128] objectSynonym and Caching --- R/simulation-simInit.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 8c1bf6bc..09e16e2c 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1354,15 +1354,14 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out ## This next line will make the Caching sensitive to userSuppliedObjs ## (which are already in the simList) or objects supplied by another module inSimList <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = c("sim", "i", "c")) - # inCyclic <- suppliedElsewhere(moduleSpecificInputObjects, sim, where = "c") if (any(inSimList)) { objectsToEvaluateForCaching <- c(objectsToEvaluateForCaching, + # objSynName, moduleSpecificInputObjects[inSimList]) } + moduleSpecificInputObjects <- c(moduleSpecificInputObjects, objSynName) + - #sim <- Cache(FUN = do.call, .inputObjects, args, # remove the do.call - # showSimilar <- isTRUE(sim@params[[mBase]][[".showSimilar"]]) - # browser(expr = exists("._runModuleInputObjects_3")) showSimilar <- if (is.null(sim@params[[mBase]][[".showSimilar"]]) || isTRUE(is.na(sim@params[[mBase]][[".showSimilar"]]))) { isTRUE(getOption("reproducible.showSimilar", FALSE)) @@ -1376,7 +1375,6 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out modParams <- sim@params[[mBase]] paramsDontCacheOnActual <- names(sim@params[[mBase]]) %in% paramsDontCacheOn - # simParamsDontCacheOn <- modParams[paramsDontCacheOnActual] paramsWoKnowns <- modParams[!paramsDontCacheOnActual] # nextEvent <- NULL From a7e34b19d7f90cae0d1359be6b904944362f4968 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:20:07 -0700 Subject: [PATCH 116/128] change .functionName for Cache of .inputObjects --- R/simulation-simInit.R | 42 ++++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 09e16e2c..eca8076e 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1389,20 +1389,34 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out # if (getOption("spades.useBox", FALSE) && FALSE) # do.call(box::use, lapply(pkgs, as.name)) debugForCache <- debugToVerbose(debug) - # if (identical(mBase, "mpbRedTopSpread")) browser() - sim <- Cache(.inputObjects, sim, - .objects = objectsToEvaluateForCaching, - notOlderThan = notOlderThan, - outputObjects = moduleSpecificInputObjects, - quick = getOption("reproducible.quick", FALSE), - cachePath = sim@paths$cachePath, - classOptions = list(events = FALSE, current = FALSE, completed = FALSE, simtimes = FALSE, - params = paramsWoKnowns, - # .globals = globsWoKnowns, - modules = mBase), - showSimilar = showSimilar, - userTags = c(paste0("module:", mBase), - "eventType:.inputObjects"), verbose = debugForCache) + # if (!file.exists("/home/emcintir/GitHub/FireSenseTesting/inputs/rstLCC2011_FireSenseTestingdf7443ce0c5d1a0c7169884pix_propFlam.tif")) + # browser() + if (any(mBase %in% getOption("spades.debugModule"))) { + browser() + } + + # if (isTRUE("Biomass_borealDataPrep" %in% mBase)) { + # aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + # browser() + # } + # if (isTRUE(mBase %in% "fireSense_dataPrepPredict")) browser() + # aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + sim <- .inputObjects(sim) |> + Cache( + .objects = objectsToEvaluateForCaching, + notOlderThan = notOlderThan, + outputObjects = moduleSpecificInputObjects, + quick = getOption("reproducible.quick", FALSE), + cachePath = sim@paths$cachePath, + classOptions = list(events = FALSE, current = FALSE, completed = FALSE, simtimes = FALSE, + params = paramsWoKnowns, + # .globals = globsWoKnowns, + modules = mBase), + showSimilar = showSimilar, + .functionName = paste0(".inputObjects_", mBase), + userTags = c(paste0("module:", mBase), + "eventType:.inputObjects"), + verbose = debugForCache) } if (allowSequentialCaching) { sim <- allowSequentialCachingUpdateTags(sim, cacheIt) From b93b74c3a81c9911866750dfe1debc04814a587f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:25:22 -0700 Subject: [PATCH 117/128] printDebugPrint --- R/simulation-simInit.R | 1 + R/simulation-spades.R | 1 + 2 files changed, 2 insertions(+) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index eca8076e..56bdad6d 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1444,6 +1444,7 @@ simInitAndSpades <- function(times, params, modules, objects, paths, inputs, out if (!(FALSE %in% debug || any(is.na(debug)))) { sim <- objectsCreatedPost(sim, objsIsNullBefore) } + printDebugPrint() # this is getOption("spades.debugPrint") } } else { message( diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 5fb9dcc5..6e7f41db 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1443,6 +1443,7 @@ setMethod( if (debugToVerbose(debug)) { sim <- objectsCreatedPost(sim, objsIsNullBefore) } + printDebugPrint() # this is getOption("spades.debugPrint") ## Test for memory leaks if (getOption("spades.testMemoryLeaks", TRUE)) { From 8a33b2f263af6a168801b7641672531785429e6b Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:25:38 -0700 Subject: [PATCH 118/128] doCallSafe --- R/simulation-simInit.R | 55 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/R/simulation-simInit.R b/R/simulation-simInit.R index 56bdad6d..87c1d76e 100644 --- a/R/simulation-simInit.R +++ b/R/simulation-simInit.R @@ -1119,9 +1119,62 @@ spades2 <- function(l) { #' @rdname simInitAndSpades #' @param l A list of arguments to passed to `simInitAndSpades`. simInitAndSpades2 <- function(l) { - do.call(simInitAndSpades, l) + doCallSafe(simInitAndSpades, l) } + + +#' Memory safe alternative to `do.call` +#' +#' `doCallSafe` is an alternative implementation for `do.call` that does not +#' evaluate the `args` prior to running. This means that R does not become unresponsive +#' when there are large objects in the `args`. This should be used *always* instead +#' of `do.call`, whenever there are possibly large objects within the `args`. This is +#' a verbatim copy from package `Gmisc` at +#' \url{https://search.r-project.org/CRAN/refmans/Gmisc/html/fastDoCall.html} +#' +#' @returns Same as `do.call`, but without the memory inefficiency. +#' +#' @export +#' @rdname do.call +#' @inheritParams base::do.call +doCallSafe <- function (what, args, quote = FALSE, envir = parent.frame()) { + # Copied directly from: https://search.r-project.org/CRAN/refmans/Gmisc/html/fastDoCall.html + if (quote) { + args <- lapply(args, enquote) + } + if (is.null(names(args)) || is.data.frame(args)) { + argn <- args + args <- list() + } + else { + argn <- lapply(names(args)[names(args) != ""], as.name) + names(argn) <- names(args)[names(args) != ""] + argn <- c(argn, args[names(args) == ""]) + args <- args[names(args) != ""] + } + if ("character" %in% class(what)) { + if (is.character(what)) { + fn <- strsplit(what, "[:]{2,3}")[[1]] + what <- if (length(fn) == 1) { + get(fn[[1]], envir = envir, mode = "function") + } + else { + get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function") + } + } + call <- as.call(c(list(what), argn)) + } + else if ("function" %in% class(what)) { + f_name <- deparse(substitute(what)) + call <- as.call(c(list(as.name(f_name)), argn)) + args[[f_name]] <- what + } + else if ("name" %in% class(what)) { + call <- as.call(c(list(what, argn))) + } + eval(call, envir = args, enclos = envir) +} #' Call `simInit` and `spades` together #' #' These functions are convenience wrappers that may allow for more efficient caching. From 1ee357d5d12ff4cc5dc3b4dabbc6d82e87ed410c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:26:41 -0700 Subject: [PATCH 119/128] more nestedSim --- R/simulation-spades.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 6e7f41db..1a661141 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -134,10 +134,10 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, cur <- sim@current # loggingMessage helpers - simNestingRevert <- sim[["._simNesting"]] - on.exit(sim[["._simNesting"]] <- simNestingRevert, add = TRUE) - sim[["._simNesting"]] <- simNestingOverride(sim, sim@current$moduleName) - ._simNesting <- sim[["._simNesting"]] + simNestingRevert <- sim[[._txtSimNesting]] + on.exit(sim[[._txtSimNesting]] <- simNestingRevert, add = TRUE) + sim[[._txtSimNesting]] <- simNestingOverride(sim, sim@current$moduleName) + ._simNesting <- sim[[._txtSimNesting]] curModuleName <- cur[["moduleName"]] if (length(cur) == 0) { @@ -319,7 +319,7 @@ doEvent <- function(sim, debug = FALSE, notOlderThan, if (!isNamespace(tryCatch(asNamespace(.moduleNameNoUnderscore(curModuleName)), silent = TRUE, error = function(x) FALSE) )) - stop("The module named ", curModuleName, " just deleted the object named 'mod' from ", + warning("The module named ", curModuleName, " just deleted the object named 'mod' from ", "sim$", curModuleName, ". ", "Please remove the section of code that does this in the event named: ", cur[["eventType"]]) @@ -867,7 +867,8 @@ setMethod( # loggingMessage helpers ._simNesting <- simNestingSetup(...) - sim[["._simNesting"]] <- ._simNesting + # sim[[._txtSimNesting]] <- ._simNesting + sim[[._txtSimNesting]] <- ._simNesting opt <- options("encoding" = "UTF-8") if (isTRUE(getOption("spades.allowSequentialCaching"))) { From 9f00e3b4862480b1ce5fc58bda08371497f84701 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:28:32 -0700 Subject: [PATCH 120/128] deleted the recoverMode temp dir often; bug identified by @tati-micheletti --- R/simulation-spades.R | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 1a661141..8eef2a9e 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1133,6 +1133,12 @@ setMethod( ## RecoverMode Step 3 -- Initiate the RMO (recovery mode object) if (recoverMode > 0) { + thisSpadesCallRandomStr <- basename(tempfile(pattern = "rmo")) + on.exit({ + toDel <- dir(dotRMOFilepath(thisSpadesCallRandomStr), full.names = TRUE) + if (length(toDel) > 0) + unlink(toDel) + }, add = TRUE) # for file-backed files) rmo <- NULL # The recovery mode object allObjNames <- outputObjectNames(sim) if (is.null(allObjNames)) recoverMode <- 0 @@ -1559,7 +1565,7 @@ recoverModePre <- function(sim, rmo = NULL, allObjNames = NULL, recoverMode) { newList <- list(if (any(objsInSimListAndModule)) { # files may disappear for one reason or another; this will fail, silently try(Copy(mget(ls(sim)[objsInSimListAndModule], envir = sim@.xData), - filebackedDir = file.path(getOption("spades.scratchPath"), "._rmo"))) + filebackedDir = dotRMOFilepath(thisSpadesCallRandomStr, sim@events))) } else { list() }) @@ -1578,7 +1584,9 @@ recoverModePre <- function(sim, rmo = NULL, allObjNames = NULL, recoverMode) { mess2 <- capture.output(type = "message", rmo$recoverableModObjs <- append(list(if (length(objsInModObjects)) { Copy(mget(objsInModObjects, envir = modEnv), - filebackedDir = file.path(getOption("spades.scratchPath"), "._rmo")) + # filebackedDir = file.path(getOption("spades.scratchPath"), "._rmo")) + filebackedDir = dotRMOFilepath(thisSpadesCallRandomStr, sim@events)) + } else { list() }), rmo$recoverableModObjs) @@ -2527,3 +2535,12 @@ recoverModeTypo <- function() { warning("Please set options('recoveryMode') with a 'y', not options('recoverMode')") } } +dotRMOFilepath <- function(thisSpadesCallRandomStr, events) { + sub <- if (missing(events)) + sub <- "" + else + paste(events[[1]][["moduleName"]], events[[1]][["eventType"]], + sep = "_", round(events[[1]][["eventTime"]])) + file.path(getOption("spades.scratchPath"), "._rmo", thisSpadesCallRandomStr, sub) +} + From f295fba6701471caacad5ab44da03425ceae3178 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:28:51 -0700 Subject: [PATCH 121/128] printDebugPrint --- R/simulation-spades.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 8eef2a9e..47290671 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -2544,3 +2544,9 @@ dotRMOFilepath <- function(thisSpadesCallRandomStr, events) { file.path(getOption("spades.scratchPath"), "._rmo", thisSpadesCallRandomStr, sub) } +printDebugPrint <- function(envir = parent.frame()) { + if (!is.null(getOption("spades.debugPrint"))) { + print(getOption("spades.debugPrint")) + print(eval(getOption("spades.debugPrint"), envir = envir)) + } +} From 848d8a0005d79804a8ec235b190a4c1eed0296b8 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:30:39 -0700 Subject: [PATCH 122/128] Commented out Cache fixPointers; not used yet --- R/simulation-spades.R | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 47290671..532fa73f 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -2535,6 +2535,41 @@ recoverModeTypo <- function() { warning("Please set options('recoveryMode') with a 'y', not options('recoverMode')") } } + + + +# fixPointers <- function(sim, cachePath = getOption("reproducible.cachePath"), +# verbose = getOption("reproducible.verbose")) { +# lsSim <- ls(sim) +# a <- Map(x = lsSim, function(x) if (isS4(sim[[x]])) {# This is a fast way to filter out non terra objects +# if (is(sim[[x]], "SpatRaster") || +# is(sim[[x]], "SpatVector") || +# is(sim[[x]], "SpatExtent")) { +# rr <- try(sim[[x]]@pntr$size(), silent = TRUE) +# !is.null(rr) && is(rr, "try-error") +# } +# } else {FALSE}) +# +# a <- a[unlist(a)] +# if (length(a)) { +# opt <- options(reproducible.useMemoise = FALSE) +# on.exit(options(opt)) +# +# failedNams <- names(a) +# for (nam in failedNams) { +# cid <- cacheId(sim[[nam]]) +# if (!is.null(cid)) { +# sim[[nam]] <- loadFromCache(cachePath, cid, verbose = verbose - 1) +# messageCache("Pointer to ", nam, " was corrupt: fixed from Cached object", verbose = verbose) +# } +# } +# } +# sim +# } +# + + + dotRMOFilepath <- function(thisSpadesCallRandomStr, events) { sub <- if (missing(events)) sub <- "" From 0d05de3c903bbe1425d52e6af81a39519d13f461 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:31:39 -0700 Subject: [PATCH 123/128] dotObjs more --- R/simulation-spades.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 532fa73f..2f3b6eef 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1363,9 +1363,11 @@ setMethod( if (cacheIt) { # means that a module or event is to be cached fns <- setdiff(ls(fnEnv, all.names = TRUE), c(".inputObjects", "mod", "Par", ".objects")) # .inputObjects is not run in `spades`; mod is same as .objects + objs <- setdiff(ls(sim@.xData[[dotObjs]][[cur[["moduleName"]]]], all.names = TRUE), c(".inputObjects", "mod", "Par", ".objects")) # .inputObjects is not run in `spades`; mod is same as .objects moduleSpecificObjects <- c(ls(sim@.xData, all.names = TRUE, pattern = cur[["moduleName"]]), # functions in the main .xData that are prefixed with moduleName paste0(attr(fnEnv, "name"), ":", fns), # functions in the namespaced location + paste0(attr(fnEnv, "name"), ":", objs), # objects in the namespaced location na.omit(expectsInputs)) # objects that should exist at the time of calling the module #fnsWOhidden <- paste0(cur[["moduleName"]], ":", From 7f11635d89985d37e70d42bc432edb5b86adf211 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:32:00 -0700 Subject: [PATCH 124/128] objSyn for Cache of .runEvent --- R/simulation-spades.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 2f3b6eef..f1a3b024 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1372,7 +1372,10 @@ setMethod( #fnsWOhidden <- paste0(cur[["moduleName"]], ":", # grep("^\\._", fns, value = TRUE, invert = TRUE)) - moduleSpecificOutputObjects <- c(createsOutputs, paste0(".mods$", cur[["moduleName"]])) + moduleSpecificOutputObjects <- c(createsOutputs, paste0(dotMods, "$", cur[["moduleName"]]), + paste0(dotObjs, "$", cur[["moduleName"]]), + objSynName + ) # globalParams <- sim@params[[".globals"]] modParamsFull <- sim@params[[cur[["moduleName"]]]] paramsDontCacheOnActual <- names(modParamsFull) %in% paramsDontCacheOn From 64e64695ec538c9b7e65aa55b00e74553c8b77ee Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:32:14 -0700 Subject: [PATCH 125/128] change Cache .functionName for modCall --- R/simulation-spades.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index f1a3b024..9a95c1aa 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1393,20 +1393,21 @@ setMethod( fnCallAsExpr <- if (cacheIt) { # means that a module or event is to be cached modCall <- get(moduleCall, envir = fnEnv) - if (any(cur[["moduleName"]] %in% getOption("spades.debugModule"))) { - browser() - } - # if (isTRUE(cur$moduleName %in% "randomLandscapes")) browser() - expression(Cache(FUN = modCall, - sim = sim, - eventTime = cur[["eventTime"]], eventType = cur[["eventType"]], + # if (isTRUE(cur$moduleName %in% "fireSense_dataPrepFit")) browser() + + expression(Cache(FUN = + modCall( + sim = sim, + eventTime = cur[["eventTime"]], eventType = cur[["eventType"]]), + # debugCache = "quick", .objects = moduleSpecificObjects, notOlderThan = notOlderThan, outputObjects = moduleSpecificOutputObjects, classOptions = classOptions, showSimilar = showSimilar, cachePath = sim@paths[["cachePath"]], - .functionName = moduleCall, verbose = verbose, + .functionName = paste0(moduleCall, "::", cur[["eventType"]]), + verbose = verbose, userTags = c(paste0("module:", cur[["moduleName"]]), paste0("eventType:", cur[["eventType"]]), paste0("eventTime:", time(sim))))) From 4e05c1aba118196bb0ed702903c6d737df596aa7 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:32:31 -0700 Subject: [PATCH 126/128] option spades.debugModule --- R/simulation-spades.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 9a95c1aa..3279e593 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -1420,6 +1420,10 @@ setMethod( objsIsNullBefore <- objsAreNull(sim) } + if (any(cur[["moduleName"]] %in% getOption("spades.debugModule"))) { + # aaaa <<- 1; on.exit(rm(aaaa, envir = .GlobalEnv)) + browser() + } if (.pkgEnv[["spades.browserOnError"]]) { sim <- .runEventWithBrowser(sim, fnCallAsExpr, moduleCall, fnEnv, cur) } else { From d186a8daebfb8c1b504feffd353bccbda1b87812 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:32:58 -0700 Subject: [PATCH 127/128] loggingMessage -- changes to deal with nested sim --- R/simulation-spades.R | 92 ++++++++++++++++++++++--------------------- 1 file changed, 48 insertions(+), 44 deletions(-) diff --git a/R/simulation-spades.R b/R/simulation-spades.R index 3279e593..f6ab3574 100644 --- a/R/simulation-spades.R +++ b/R/simulation-spades.R @@ -2020,57 +2020,61 @@ updateParamSlotInAllModules <- function(paramsList, newParamValues, paramSlot, loggingMessagePrefixLength <- 15 loggingMessage <- function(mess, suffix = NULL, prefix = NULL) { - st <- Sys.time() - stForm1 <- "%h%d" - stForm2 <- paste(stForm1, "%H:%M:%S") - numCharsMax <- max(0, getOption("spades.messagingNumCharsModule", 21) - loggingMessagePrefixLength) - middleFix <- "" - noNew <- FALSE - if (numCharsMax > 0) { - sim2 <- list() # don't put a `sim` here because whereInStack will find this one - while (!is(sim2, "simList")) { - simEnv <- try(whereInStack("sim"), silent = TRUE) - if (is(simEnv, "try-error")) - break - sim <- get0("sim", envir = simEnv, inherits = FALSE) - if (is(sim, "simList")) - sim2 <- sim - } + if (!isTRUE(any(grepl(.txtNoPrefix, mess)))) { + st <- Sys.time() + stForm1 <- "%h%d" + stForm2 <- paste(stForm1, "%H:%M:%S") + numCharsMax <- max(0, getOption("spades.messagingNumCharsModule", 21) - loggingMessagePrefixLength) + middleFix <- "" + noNew <- FALSE + if (numCharsMax > 0) { + sim2 <- list() # don't put a `sim` here because whereInStack will find this one + while (!is(sim2, "simList")) { + simEnv <- try(whereInStack("sim"), silent = TRUE) + if (is(simEnv, "try-error")) + break + sim <- get0("sim", envir = simEnv, inherits = FALSE) + if (is(sim, "simList")) + sim2 <- sim + } - if (!is(sim, "try-error") && !is.null(sim)) { - # If this is a nested spades call, will have time already at start - if (startsWith(mess, strftime(st, format = "%h%d"))) { - noNew <- TRUE - } else { - middleFix <- paste(sim[["._simNesting"]], collapse = "/") + if (!is(sim, "try-error") && !is.null(sim)) { + # If this is a nested spades call, will have time already at start + if (startsWith(mess, strftime(st, format = "%h%d"))) { + noNew <- TRUE + } else { + middleFix <- paste(sim[[._txtSimNesting]], collapse = "/") + } } } - } - prependTime <- strftime(st, format = stForm2) - - # need to remove final \n, but strsplit on any internal \n - slashN <- gregexpr("\n", mess)[[1]] - if (isTRUE(slashN[1] > 0)) { - # Eliot -- I tried various ways of doing this ... they are similar execution time; this is simplest - len <- length(slashN) - mess <- gsub(pattern = "\\n$", replacement = "", mess) - if (len > 1) { - mess <- strsplit(mess, "\n")[[1]] - mess[-len] <- paste0(mess[-len], "\n") + prependTime <- strftime(st, format = stForm2) + + # need to remove final \n, but strsplit on any internal \n + slashN <- gregexpr("\n", mess)[[1]] + if (isTRUE(slashN[1] > 0)) { + # Eliot -- I tried various ways of doing this ... they are similar execution time; this is simplest + len <- length(slashN) + mess <- gsub(pattern = "\\n$", replacement = "", mess) + if (len > 1) { + mess <- strsplit(mess, "\n")[[1]] + mess[-len] <- paste0(mess[-len], "\n") + } } - } - # Prepend the middle - if (isTRUE(any(grepl("\b", mess)))) { - # noNew <- TRUE - mess <- gsub(" {2,100}", " ", mess) # get rid of multi-space -- but only if \b because could be indent - } else { - messPoss <- paste0(middleFix, " ", mess) - if (!isTRUE(noNew)) { - # Prepend the time - mess <- paste0(prependTime, " ", messPoss) + # Prepend the middle + if (isTRUE(any(grepl("\b", mess)))) { + # noNew <- TRUE + mess <- gsub(" {2,100}", " ", mess) # get rid of multi-space -- but only if \b because could be indent + } else { + messPoss <- paste0(middleFix, " ", mess) + if (!isTRUE(noNew)) { + # Prepend the time + mess <- paste0(prependTime, " ", messPoss) + } } + } else { + mess <- gsub(.txtNoPrefix, "", mess) } mess From a9ac3af06b5702b33e6c58b2c843380b7197d710 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 29 May 2025 10:58:27 -0700 Subject: [PATCH 128/128] test-cache for caching simInitAndSpades specifically --- .gitignore | 1 + tests/testthat/test-cache.R | 61 +++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/.gitignore b/.gitignore index 16eab5e3..3426055a 100644 --- a/.gitignore +++ b/.gitignore @@ -43,3 +43,4 @@ revdep/.cache.rds .timings.rds timings.rds +.Rprofile diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index bbb0137f..c3974879 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -694,3 +694,64 @@ test_that("cache of terra objects in the depends", { expect_false(is(err, "simpleError")) } }) + + + + +test_that("caching simInitAndSpades specifically", { + skip_on_cran() # too long + testInit(sampleModReqdPkgs) + + set.seed(42) + + times <- list(start = 0.0, end = 1, timeunit = "year") + params <- list( + # .globals = list(burnStats = "npixelsburned", stackName = "landscape"), + randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA, .seed = list("init" = 321)), + caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA, torus = TRUE), + fireSpread = list(.plotInitialTime = NA, .plotInterval = NA) + ) + modules <- list("randomLandscapes", #"caribouMovement", + "fireSpread") + + fns <- c(simInitAndSpades, simInit) + for (fn in fns) { + paths <- list(modulePath = getSampleModules(tmpdir)) + fileNames <- file.path(paths$modulePath, modules, paste0(modules, ".R")) + mySimEvent <- list() + for (i in 1:3) { + if (identical(i, 3L)) { + cat(append = TRUE, sep = "\n", fill = FALSE, file = fileNames[1], + "newFun <- function(sim) return(invisible(sim))") + } + mySimEvent[[i]] <- fn(modules = modules, paths = paths, times = times) |> + reproducible::Cache() + if (identical(i, 2L)) + expect_identical(cacheId(mySimEvent[[1]]), cacheId(mySimEvent[[2]])) + if (identical(i, 3L)) + expect_false(identical(cacheId(mySimEvent[[1]]), cacheId(mySimEvent[[3]]))) + } + + } + + + fns <- c(simInitAndSpades2, simInit2) + for (fn in fns) { + paths <- list(modulePath = getSampleModules(tmpdir)) + fileNames <- file.path(paths$modulePath, modules, paste0(modules, ".R")) + mySimEvent <- list() + for (i in 1:3) { + if (identical(i, 3L)) { + cat(append = TRUE, sep = "\n", fill = FALSE, file = fileNames[1], + "newFun <- function(sim) return(invisible(sim))") + } + mySimEvent[[i]] <- do.call(fn, list(l = list(modules = modules, paths = paths, times = times))) |> + reproducible::Cache() + if (identical(i, 2L)) + expect_identical(cacheId(mySimEvent[[1]]), cacheId(mySimEvent[[2]])) + if (identical(i, 3L)) + expect_false(identical(cacheId(mySimEvent[[1]]), cacheId(mySimEvent[[3]]))) + } + + } +})