Merge branch 'PredictiveEcology:development' into development

Author: vanelslander-ecology

DESCRIPTION

@@ -2,8 +2,8 @@ Package: fireSenseUtils
 Type: Package
 Title: Utilities for Working With the 'fireSense' Group of 'SpaDES' Modules
 Description: Utilities for working with the 'fireSense' group of 'SpaDES' modules.
-Date: 2026-02-14
-Version: 0.0.9
+Date: 2026-02-18
+Version: 0.0.10
 Authors@R: c(
     person("Jean", "Marchal", email = "jean.d.marchal@gmail.com",
            role = c("aut")),

NAMESPACE

@@ -20,6 +20,7 @@ export(burnClassGenerator)
 export(burnClassPredict)
 export(burnClassSummary)
 export(burnProbFromClass)
+export(calcNonForestYoungAge)
 export(calcYoungAge)
 export(castCohortData)
 export(chk_duplicatedStartPixels)
@@ -33,6 +34,7 @@ export(dtReplaceNAwith0)
 export(extractSpecial)
 export(fireSenseCloudParameters)
 export(fireSenseCloudParametersMap)
+export(fireSenseCovariatesCreate)
 export(fuelClassPrep)
 export(getFirePoints_NFDB)
 export(getFirePoints_NFDB_V2)
@@ -62,6 +64,7 @@ export(plotCumulativeBurns)
 export(plotELFs)
 export(plotHistoricFires)
 export(predictIgnition)
+export(putBackIntoRaster)
 export(pw)
 export(rasterFireBufferDT)
 export(rasterFireSpreadPoints)
@@ -161,8 +164,8 @@ importFrom(purrr,map)
 importFrom(purrr,map2)
 importFrom(purrr,pmap)
 importFrom(purrr,transpose)
-importFrom(qs,qread)
-importFrom(qs,qsave)
+importFrom(qs2,qs_read)
+importFrom(qs2,qs_save)
 importFrom(quickPlot,Plot)
 importFrom(quickPlot,clearPlot)
 importFrom(quickPlot,dev)

R/DEoptim_fns.R

@@ -177,219 +177,7 @@ runDEoptim <- function(landscape,
     pkgsNeeded = neededPkgs, envir = environment()
   )
   cl <- control$cluster # This is to test whether it is actually closed
-  # on.exit(parallel::stopCluster(control$cluster), add = TRUE)
-
-  # control <- list(itermax = itermax, trace = trace, strategy = strategy)
-
-  # if (!is.null(initialpop)) {
-  #   control$initialpop <- initialpop
-  # }
-  #
-  # if (!is.null(NP)) {
-  #   control$NP <- NP
-  # }
-  # # if (is.null(cores)) cores <- "localhost"
-  # if (!is.null(cores)) {
-  #   logPath <- file.path(
-  #     logPath,
-  #     paste0(
-  #       "fireSense_SpreadFit_", format(Sys.time(), "%Y-%m-%d_%H%M%S"),
-  #       "_pid", Sys.getpid(), ".log"
-  #     )
-  #   )
-  #   message(paste0(
-  #     "Starting parallel model fitting for ",
-  #     "fireSense_SpreadFit. Log: ", logPath
-  #   ))
-  #
-  #   # Make sure logPath can be written in the workers -- need to create the dir
-  #
-  #   if (is.numeric(cores)) cores <- rep("localhost", cores)
-  #
-  #   ## Make cluster with just one worker per machine --> don't need to do these steps
-  #   #     multiple times per machine, if not all 'localhost'
-  #   revtunnel <- FALSE
-  #   neededPkgs <- c("kSamples", "magrittr", "raster", "data.table",
-  #                   "SpaDES.tools", "fireSenseUtils", "sf")
-  #
-  #   if (!identical("localhost", unique(cores))) {
-  #     repos <- c("https://predictiveecology.r-universe.dev", getOption("repos"))
-  #
-  #     aa <- Require::pkgDep(unique(c("dqrng", "PredictiveEcology/SpaDES.tools@development",
-  #                                    "PredictiveEcology/fireSenseUtils@development", "qs",
-  #                                    "RCurl", neededPkgs)), recursive = TRUE)
-  #     pkgsNeeded <- unique(Require::extractPkgName(unname(unlist(aa))))
-  #
-  #     revtunnel <- ifelse(all(cores == "localhost"), FALSE, TRUE)
-  #
-  #     coresUnique <- setdiff(unique(cores), "localhost")
-  #     message("copying packages to: ", paste(coresUnique, collapse = ", "))
-  #
-  #     # RscriptPath = "/usr/local/bin/Rscript"
-  #
-  #     # st <- system.time(
-  #     #   cl <- mirai::make_cluster(
-  #     #     n = length(coresUnique),
-  #     #     url = "tcp://localhost:5563",
-  #     #     remote = mirai::ssh_config(
-  #     #       remotes = paste0("ssh://", coresUnique),
-  #     #       tunnel = TRUE,
-  #     #       timeout = 1,
-  #     #       rscript = RscriptPath
-  #     #     )
-  #     #   )
-  #     # )
-  #     st <- system.time({
-  #       cl <- parallelly::makeClusterPSOCK(coresUnique, revtunnel = revtunnel, rscript_libs = libPath
-  #                                          # , rscript = c("nice", RscriptPath)
-  #       )
-  #     })
-  #     clusterExport(cl, list("libPath", "logPath", "repos", "pkgsNeeded"),
-  #                   envir = environment())
-  #
-  #     # Missing `dqrng` and `sitmo`
-  #     Require::Install(pkgsNeeded, libPaths = libPath)
-  #
-  #     parallel::clusterEvalQ(cl, {
-  #       # If this is first time that packages need to be installed for this user on this machine
-  #       #   there won't be a folder present that is writable
-  #       if (!dir.exists(libPath)) {
-  #         dir.create(libPath, recursive = TRUE)
-  #       }
-  #     })
-  #
-  #     message("Setting up packages on the cluster...")
-  #     out <- lapply(setdiff(unique(cores), "localhost"), function(ip) {
-  #       rsync <- Sys.which("rsync")
-  #       if (!nzchar(rsync)) stop()
-  #       system(paste0(rsync, " -aruv --update ", paste(file.path(libPath, pkgsNeeded), collapse = " "),
-  #                     " ", ip, ":", libPath))
-  #     })
-  #
-  #     parallel::clusterEvalQ(cl, {
-  #       # If this is first time that packages need to be installed for this user on this machine
-  #       #   there won't be a folder present that is writable
-  #       if (tryCatch(packageVersion("Require") < "1.0.1", error = function() TRUE))
-  #         install.packages("Require", lib = libPath)
-  #       library(Require, lib.loc = libPath)
-  #       dir.create(dirname(logPath), recursive = TRUE)
-  #       out <- Require::Install(pkgsNeeded, libPaths = libPath)
-  #     })
-  #
-  #     GDALversions <- parallel::clusterEvalQ(cl, {
-  #       .libPaths(libPath)
-  #       return(sf::sf_extSoftVersion()["GDAL"])
-  #     })
-  #
-  #     stopifnot(length(unique(sf::sf_extSoftVersion()["GDAL"], GDALversions)) == 1)
-  #     parallel::stopCluster(cl)
-  #
-  #     ## Now make full cluster with one worker per core listed in "cores"
-  #     message("Starting ", paste(paste(names(table(cores))), "x", table(cores),
-  #                                collapse = ", "), " clusters")
-  #     message("Starting main parallel cluster ...")
-  #     # sshCores <- paste0("ssh//", grep('localhost', cores, invert = TRUE, value = TRUE))
-  #     # nonsshCores <- grep('localhost', cores, value = TRUE)
-  #     # coresForMirai <- c(nonsshCores, sshCores)
-  #
-  #     st <- system.time({
-  #       # cl <- mirai::make_cluster(
-  #       #   length(coresForMirai),
-  #       #   # url = "tcp://localhost:5555",
-  #       #   remote = ssh_config(
-  #       #     remotes = coresForMirai,
-  #       #     # tunnel = TRUE,
-  #       #     timeout = 1,
-  #       #     rscript = RscriptPath
-  #       #   )
-  #       # )
-  #
-  #       cl <- parallelly::makeClusterPSOCK(cores,
-  #                                          revtunnel = revtunnel,
-  #                                          outfile = logPath, rscript_libs = libPath
-  #                                          # , rscript = c("nice", RscriptPath)
-  #       )
-  #     })
-  #
-  #     on.exit(stopCluster(cl))
-  #     message(
-  #       "it took ", round(st[3], 2), "s to start ",
-  #       paste(paste(names(table(cores))), "x", table(cores), collapse = ", "), " threads"
-  #     )
-  #     message("Moving objects to each node in cluster")
-  #
-  #     stMoveObjects <- try({
-  #       system.time({
-  #         objsToCopy <- mget(unlist(objsNeeded))
-  #         objsToCopy <- lapply(objsToCopy, FUN = function(x) {
-  #           if (inherits(x, "SpatRaster")) {
-  #             x <- terra::wrap(x)
-  #           } else {
-  #             x
-  #           }
-  #           x
-  #         })
-  #         filenameForTransfer <- normalizePath(tempfile(fileext = ".qs"), mustWork = FALSE, winslash = "/")
-  #         dir.create(dirname(filenameForTransfer), recursive = TRUE, showWarnings = FALSE) # during development, this was deleted accidentally
-  #         qs::qsave(objsToCopy, file = filenameForTransfer)
-  #         stExport <- system.time({
-  #           outExp <- clusterExport(cl, varlist = "filenameForTransfer", envir = environment())
-  #         })
-  #         out11 <- clusterEvalQ(cl, {
-  #           dir.create(dirname(filenameForTransfer), recursive = TRUE, showWarnings = FALSE)
-  #         })
-  #         out <- lapply(setdiff(unique(cores), "localhost"), function(ip) {
-  #           rsync <- Sys.which("rsync")
-  #           st1 <- system.time(system(paste0(rsync, " -av ",
-  #                                            filenameForTransfer, " ", ip, ":",
-  #                                            filenameForTransfer)))
-  #         })
-  #         out <- clusterEvalQ(cl, {
-  #           out <- qs::qread(file = filenameForTransfer)
-  #           out <- lapply(out, FUN = function(x) {
-  #             if (inherits(x, "PackedSpatRaster")) {
-  #               x <- terra::unwrap(x)
-  #             } else {
-  #               x
-  #             }
-  #             x
-  #           })
-  #           list2env(out, envir = .GlobalEnv)
-  #         })
-  #         # Delete the file
-  #         out <- clusterEvalQ(cl, {
-  #           if (dir.exists(dirname(filenameForTransfer))) {
-  #             try(unlink(dirname(filenameForTransfer), recursive = TRUE), silent = TRUE)
-  #           }
-  #         })
-  #       })
-  #     })
-  #
-  #     if (is(stMoveObjects, "try-error")) {
-  #       message("The attempt to move objects to cluster using rsync and qs failed; trying clusterExport")
-  #       stMoveObjects <- system.time(clusterExport(cl, objsNeeded, envir = environment()))
-  #       list2env(mget(unlist(objsNeeded), envir = environment()), envir = .GlobalEnv)
-  #     }
-  #     message("it took ", round(stMoveObjects[3], 2), "s to move objects to nodes")
-  #     message("loading packages in cluster nodes")
-  #
-  #     clusterExport(cl, "neededPkgs", envir = environment())
-  #     stPackages <- system.time(parallel::clusterEvalQ(
-  #       cl,
-  #       {
-  #         for (i in neededPkgs) {
-  #           library(i, character.only = TRUE)
-  #         }
-  #         message("loading ", i, " at ", Sys.time())
-  #       }
-  #     ))
-  #     message("it took ", round(stPackages[3], 2), "s to load packages")
-  #
-  #     control$cluster <- cl
-  #   } else {
-  #     list2env(mget(unlist(objsNeeded), envir = environment()), envir = .GlobalEnv)
-  #   }
-  # }
+  
   #####################################################################
   # DEOptim call
   #####################################################################
@@ -467,21 +255,8 @@ visualizeDE <- function(DE, cachePath, titles, lower, upper) {
       geom_histogram(bins = 15) + coord_cartesian(xlim = c(lower[p],upper[p])) +
       ggtitle(p) + xlab(NULL) +
       theme_minimal()
-    # geom_smooth(se = TRUE) +
-    # geom_ribbon(aes(ymin = lower95, ymax = upper95)) +
-    # facet_wrap(facets = "variable", scales = "free")
   })
   invisible(ggpubr::ggarrange(plotlist = ff))
-  #
-  #
-  #
-  #   aa <- as.data.table(t(DE$member$pop))
-  #   melt(aa, id.vars = )
-  #   aa[, pars := paste0("par", 1:NROW(aa))]
-  #   dim1 <- floor(sqrt(NROW(aa)))
-  #   dim2 <- NROW(aa) / dim1
-  #   par(mfrow = c(dim1, dim2))
-  #   aa[, hist(t(.SD), main = as.character(.BY))[[2]], by = pars]
 }
 
 #' Iterative `DEoptim` Runner with Caching and Visualization

R/ELFs.R

@@ -128,14 +128,7 @@ makeELFs <- function(x, desiredBuffer = 20000,
 
   ELFs <- bufferOut(spatRasSeg = out3, mask = hf,
                     desiredBuffer = desiredBuffer,
-                    useCache = useCache) |>
-    reproducible::Cache(omitArgs = c("spatRasSeg", "mask"),
-                        .cacheExtra = list(x = digNFP,
-                                           attr(out2, "tags")#,
-                                           #attr(out, "tags")
-                        ),
-                        useCache = useCache)
-
+                    useCache = useCache) 
   # ELFs <- bufferOut(spatRasSeg = out3, mask = out$rasWhole[[1]],
   #                   desiredBuffer = desiredBuffer,
   #                   useCache = useCache) |>
@@ -165,7 +158,17 @@ makeELFs <- function(x, desiredBuffer = 20000,
     ELFs <- Reduce(rbind, allVec)
 
   }
-
+  
+  # ELFs2 <- Map(e = ELFs, function(e) {
+  #   ff <- Filenames(e)
+  #   nzff <- nzchar(ff)
+  #   if (any(nzff)) {
+  #     whnzff <- which(nzff)
+  #     e[whnzff] <- Map(r = e[whnzff], function(r) {r[] <- terra::values(r, mat = FALSE); r})
+  #   }
+  #   e
+  # })
+  
   ELFs
 }
 
@@ -300,21 +303,20 @@ bufferOut <- function(v, spatRasSeg, spatRas, mask, field = "FRU", desiredBuffer
   }
 
   ll <- moveSliversToOtherELFs(lostPixels, lp, ca, i, r)
-  ll3 <- ll
+  # ll3 <- ll
   destinationPath <- unique(dirname(Filenames(spatRasSeg)))
   ELFpath <- file.path(destinationPath, "ELFs_final")
   unlink(ELFpath, recursive = TRUE)
   dir.create(ELFpath, recursive = TRUE, showWarnings = FALSE)
   message("Writing ELF rasters to disk")
-  for (i in seq_along(ll)) {
-    for (j in seq_along(i)) {
-      fn <- file.path(ELFpath, paste0(names(ll[[i]][[j]]), ".tif"))
+  rr <- Map(out = ll, namOut = names(ll), function(out, namOut) {
+    Map(inner = out, nam = names(out), function(inner, nam) {
+      fn <- file.path(ELFpath, paste0(namOut, "_", nam, ".tif"))
       unlink(fn)
-      ll[[i]][[j]] <- terra::writeRaster(ll[[i]][[j]], filename = fn, overwrite = TRUE)
-    }
-  }
-
-  list(rasCentered = ll$r, rasWhole = ll$ca)
+      terra::writeRaster(inner, filename = fn, overwrite = TRUE)
+    })
+  })
+  list(rasCentered = rr$r, rasWhole = rr$ca)
 }
 
 segregateKeepNames <- function(ecopR, omitClasses, classes = NULL) {
@@ -369,7 +371,16 @@ split_poly <- function(sf_poly, n_areas) {
   equal_areas$area <- sf::st_area(equal_areas)
   if (wasTerra)
     equal_areas <- terra::vect(equal_areas)
-  return(equal_areas)
+  
+  # Put them in xmin to xmax, ymin to ymax order
+  mins <- Map(ind = seq(NROW(equal_areas)), function(ind) {
+    cbind(xmin = terra::xmin(equal_areas[ind, ]), ymin = terra::ymin(equal_areas[ind, ]))
+  }) |> do.call(args = _, rbind)
+  ord <- order(mins[, "xmin"], mins[, "ymin"])
+  equal_areas <- equal_areas[ord, ]
+  equal_areas[, "id"] <- seq(NROW(equal_areas))
+  
+  return(equal_areas[ord, ])
 }
 
 mergeAndSplitRas <- function(ecopRseg, ecopLCC, maxArea = 2.4e+11,
@@ -424,6 +435,7 @@ mergeAndSplitRas <- function(ecopRseg, ecopLCC, maxArea = 2.4e+11,
 
 moveSliversToOtherELFs <- function(lostPixels, lp, ca, i, r) {
 
+  message("moving slivers to neighbouring ELF")
   if (NROW(unlist(lostPixels))) {
     if (is.null(names(lostPixels))) {
       hasNames <- FALSE
@@ -484,7 +496,6 @@ moveSliversToOtherELFs <- function(lostPixels, lp, ca, i, r) {
         a[lostPixels[[lp]]$pixelID] <- newVals
         # a[a[] == 0] <- NA
         a <- terra::trim(a)
-        # if (is(a, "try-error")) browser()
         a <- terra::project(a, terra::crs(r[[addTo]]), method = "near")
         bb <- terra::resample(a, r[[addTo]], method = "near")
         whVals <- which(terra::values(bb) > 0)