Fixed problem with not creating original version of sim object at sta…

…rt of many functions. Attempted to set up to work with targets pipelines but encountered issues with pointers and such. Attempted hashed workaround to improve dependencie tracking but not resolved.

R/SimulationObjectClass.R

@@ -7,19 +7,34 @@ setClass("SimulationObject",
            state_target_realised = "ANY",
            effort = "ANY",
            detect = "ANY",
-           report = "ANY"
+           report = "ANY",
+           hash = "ANY"
          )
 )
 
 # Create a constructor for the SimulationObject class
 SimulationObject <- function(background, state_env = NULL, state_target_suitability = NULL, state_target_realised= NULL, effort = NULL, detect = NULL, report = NULL) {
+  tmp <- new("SimulationObject",
+      background = background,
+      state_env = state_env,
+      state_target_suitability = state_target_suitability,
+      state_target_realised = state_target_realised,
+      effort = effort,
+      detect = detect,
+      report = report,
+      hash = NULL)
+
+  #generate a hash
+  hash <- digest::digest(read_sim_obj_rasters(tmp))
+
   new("SimulationObject",
       background = background,
       state_env = state_env,
       state_target_suitability = state_target_suitability,
       state_target_realised = state_target_realised,
       effort = effort,
       detect = detect,
-      report = report
+      report = report,
+      hash = hash
   )
 }

R/sim_detect_equal.R

@@ -8,7 +8,8 @@
 #' sim_detect_equal()
 #' }
 sim_detect_equal <- function(simulation_object, prob = 0.5) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   background <- simulation_object@background
   state_env <- simulation_object@state_env

R/sim_detect_fun.R

@@ -9,7 +9,8 @@
 #' sim_effort_fun(simulation_object, fun, ...)
 #' }
 sim_detect_fun <- function(simulation_object, fun, ...) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   detections <- fun(simulation_object, ...)

R/sim_effort_fun.R

@@ -9,7 +9,8 @@
 #' sim_effort_fun(simulation_object, fun, ...)
 #' }
 sim_effort_fun <- function(simulation_object, fun, ...) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   effort <- fun(simulation_object, ...)

R/sim_effort_uniform.R

@@ -11,8 +11,8 @@
 #' sim_effort_uniform(simulation_object, 100, 20,1 FALSE)
 #' }
 sim_effort_uniform <- function(simulation_object, n_samplers = 1, n_visits = 1, n_sample_units=1, replace = FALSE) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
-
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   #which cells are visited
   state_target <- simulation_object@state_target_suitability

R/sim_report_equal.R

@@ -9,7 +9,9 @@
 #' sim_report_equal(simulation_object, 0.5, "iRecord")
 #' }
 sim_report_equal <- function(simulation_object, prob = 1, platform = "iRecord") {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+
   detect <- simulation_object@detect
 
   reports <- detect

R/sim_report_fun.R

@@ -9,7 +9,8 @@
 #' sim_report_fun(simulation_object, fun, ...)
 #' }
 sim_report_fun <- function(simulation_object, fun, ...) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   report <- fun(simulation_object, ...)

R/sim_state_env_byod.R

@@ -7,10 +7,11 @@
 #' \dontrun{
 #' sim_state_env_uniform(simulation_object, 0)
 #' }
-sim_state_env_byod <- function(simulation_object, spatraster) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
-  background <- simulation_object@background
+sim_state_env_byod <- function(simulation_object,filename = NULL, spatraster) {
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
+  background <- simulation_object@background
   #check that it is a SpatRaster
   if(class(spatraster) != "SpatRaster"){
     stop(paste0("Your provided layers are of class ",class(spatraster), "whereas SpatRaster is required"))
@@ -24,7 +25,19 @@ sim_state_env_byod <- function(simulation_object, spatraster) {
     stop(paste0("@background has ",ncol(background)," columns whereas your provided SpatRaster has ",ncol(spatraster)," columns. Number of columns must be equal"))
   }
 
+  #save raster and return filename if filename isn't null
+  if(!is.null(filename)){
+    spatraster <- write_raster_return_filename(spatraster,filename)
+  }
+
   simulation_object_original@state_env <- spatraster
+  print(simulation_object_original)
+
+  #create hash, having set the hash to NULL
+  tmp <- read_sim_obj_rasters(simulation_object_original)
+  print(tmp)
+  tmp@hash <- NULL
+  simulation_object_original@hash <- digest::digest(tmp)
 
   # Return the updated simulation_object
   return(simulation_object_original)

R/sim_state_env_gradient.R

@@ -8,16 +8,21 @@
 #' \dontrun{
 #' sim_state_env_gradient(simulation_object, 0, 1)
 #' }
-sim_state_env_gradient <- function(simulation_object, from = 0, to = 1) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
-  background <- simulation_object@background
+sim_state_env_gradient <- function(simulation_object, filename=NULL, from = 0, to = 1) {
 
+  #create the gradient spatraster
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+  background <- simulation_object@background
   sim_state <- background[[1]]
   terra::values(sim_state) <- rep(seq(from = from, to = to, length.out = dim(background)[2]), dim(background)[1])
   names(sim_state) <- "env"
 
-  simulation_object_original@state_env <- sim_state
+  #use byod function to add it to the simulation object
+  simulation_object <- sim_state_env_byod(
+    simulation_object = simulation_object,
+    filename = filename,
+    spatraster =  sim_state)
 
   # Return the updated simulation_object
-  return(simulation_object_original)
+  return(simulation_object)
 }

R/sim_state_env_uniform.R

@@ -7,16 +7,20 @@
 #' \dontrun{
 #' sim_state_env_uniform(simulation_object, 0)
 #' }
-sim_state_env_uniform <- function(simulation_object, value = 0) {
-  simulation_object_original <- simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
-  background <- simulation_object@background
+sim_state_env_uniform <- function(simulation_object,filename=NULL, value = 0) {
 
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+  background <- simulation_object@background
   sim_state <- background[[1]]
   terra::values(sim_state) <- value
   names(sim_state) <- "env"
 
-  simulation_object_original@state_env <- sim_state
+  #use byod function to add it to the simulation object
+  simulation_object <- sim_state_env_byod(
+    simulation_object = simulation_object,
+    filename = filename,
+    spatraster =sim_state)
 
   # Return the updated simulation_object
-  return(simulation_object_original)
+  return(simulation_object)
 }

R/sim_state_target_realise_binomial.R

@@ -7,7 +7,8 @@
 #' sim_state_target_binary(simulation_object)
 #' }
 sim_state_target_realise_binomial <- function(simulation_object) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   state_target <- simulation_object@state_target_suitability
   binary_state_target <- state_target

R/sim_state_target_realise_fun.R

@@ -9,7 +9,9 @@
 #' sim_state_target_realise_fun(simulation_object, fun, ...)
 #' }
 sim_state_target_realise_fun <- function(simulation_object, fun, ...) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+
   # apply the function
   realised <- fun(simulation_object, ...)
 

R/sim_state_target_realise_threshold.R

@@ -7,8 +7,10 @@
 #' \dontrun{
 #' sim_state_target_realised_threshold(simulation_object)
 #' }
-sim_state_target_realise_threshold <- function(simulation_object,threshold = 0.5) {
-  simulation_object_original <-simulation_object <- read_sim_obj_rasters(simulation_object)
+sim_state_target_realise_threshold <- function(simulation_object,filename=NULL,threshold = 0.5) {
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+
   state_target <- simulation_object@state_target_suitability
   binary_state_target <- state_target
 
@@ -22,6 +24,11 @@ sim_state_target_realise_threshold <- function(simulation_object,threshold = 0.5
     terra::values(binary_state_target[[i]]) <- binary_values
   }
 
+  #save raster and return filename if filename isn't null
+  if(!is.null(filename)){
+    binary_state_target <- write_raster_return_filename(binary_state_target,filename)
+  }
+
   # Update the SimulationObject with the binary state_target
   simulation_object_original@state_target_realised <- binary_state_target
 

R/sim_state_target_suitability_fun.R

@@ -9,7 +9,8 @@
 #' sim_state_target_realise_fun(simulation_object, fun, ...)
 #' }
 sim_state_target_suitability_fun <- function(simulation_object, fun, ...) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   suitability <- fun(simulation_object, ...)

R/sim_state_target_suitability_uniform.R

@@ -8,17 +8,24 @@
 #' \dontrun{
 #' sim_state_target_suitability_uniform(simulation_object, 0.5)
 #' }
-sim_state_target_suitability_uniform <- function(simulation_object, value = 0.5,n_targets=1) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+sim_state_target_suitability_uniform <- function(simulation_object, filename=NULL, value = 0.5,n_targets=1) {
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
+
   background <- simulation_object@background
 
   sim_state <- rep(background[[1]],n_targets)
   for(i in 1:n_targets){
     terra::values(sim_state[[i]]) <- value
-
   }
 
   names(sim_state) <- paste0("target_",1:n_targets)
+
+  #save raster and return filename if filename isn't null
+  if(!is.null(filename)){
+    sim_state <- write_raster_return_filename(sim_state,filename)
+  }
+
   simulation_object_original@state_target_suitability <- sim_state
 
   # Return the updated simulation_object

R/sim_state_target_suitability_virtualspecies.R

@@ -5,7 +5,8 @@
 #' @param params list of vectors providing parameters to be passed to each NMLR function call
 #' @return An updated simulation object with the newly calculated state of the target in the correct slot
 sim_state_target_suitability_virtualspecies <- function(simulation_object, n_targets = 1, params = NULL) {
-  simulation_object_original <- simulation_object <- read_sim_obj_rasters(simulation_object)
+  simulation_object_original <- simulation_object
+  simulation_object <- read_sim_obj_rasters(simulation_object)
 
   background <- simulation_object@background
   environment <- simulation_object@state_env

R/util.R

@@ -26,3 +26,13 @@ read_sim_obj_rasters <- function(sim_obj){
   #return the object
   sim_obj
 }
+
+#' Write the raster and return the filename
+#' @param x a SpatRaster
+#' @param filename The file name
+#' @param overwrite whether to overwrite existing file or not
+#' @noRd
+write_raster_return_filename <- function(x, filename,overwrite=T, ...){
+  writeRaster(x,filename,overwrite, ...)
+  filename
+}

tests/testthat/test-simulation_basic.R

@@ -1,12 +1,14 @@
 library(STRIDER)
 
 # Create the background
-background <- terra::rast(matrix(0,1000,600))
+background <- terra::rast(matrix(0,440,700))
 
 # 1 Create the simulation object
-sim_obj <- SimulationObject(background = background)
+sim_obj1 <- SimulationObject(background = background)
+
+sim_obj1 <- sim_state_env_gradient(sim_obj1)
+sim_obj1@hash
 
-sim_obj <- sim_state_env_gradient(sim_obj)
 
 # 2 Simulate a uniform state of the target across the background within the simulation object
 sim_obj <- sim_state_target_suitability_uniform(sim_obj, value= 0.5,n_targets = 2)