Hashing for environment and target suitability and realisation. Updat…

…ed tests to correspond.

R/SimulationObjectClass.R

@@ -24,9 +24,6 @@ SimulationObject <- function(background, state_env = NULL, state_target_suitabil
       report = report,
       hash = NULL)
 
-  #generate a hash
-  hash <- digest::digest(read_sim_obj_rasters(tmp))
-
   new("SimulationObject",
       background = background,
       state_env = state_env,
@@ -35,6 +32,6 @@ SimulationObject <- function(background, state_env = NULL, state_target_suitabil
       effort = effort,
       detect = detect,
       report = report,
-      hash = hash
+      hash = hash_sim_obj(tmp)
   )
 }

R/sim_state_env_byod.R

@@ -33,9 +33,7 @@ sim_state_env_byod <- function(simulation_object,filename = NULL, spatraster) {
   simulation_object_original@state_env <- spatraster
 
   #create hash, having set the hash to NULL
-  tmp <- read_sim_obj_rasters(simulation_object_original)
-  tmp@hash <- NULL
-  simulation_object_original@hash <- digest::digest(tmp)
+  simulation_object_original@hash <- hash_sim_obj(simulation_object_original)
 
   # Return the updated simulation_object
   return(simulation_object_original)

R/sim_state_target_realise_binomial.R

@@ -7,6 +7,7 @@
 #' sim_state_target_binary(simulation_object)
 #' }
 sim_state_target_realise_binomial <- function(simulation_object) {
+  #TODO
   simulation_object_original <- simulation_object
   simulation_object <- read_sim_obj_rasters(simulation_object)
 

R/sim_state_target_realise_fun.R

@@ -8,15 +8,19 @@
 #' \dontrun{
 #' sim_state_target_realise_fun(simulation_object, fun, ...)
 #' }
-sim_state_target_realise_fun <- function(simulation_object, fun, ...) {
+sim_state_target_realise_fun <- function(simulation_object, filename=NULL, fun, ...) {
   simulation_object_original <- simulation_object
   simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   realised <- fun(simulation_object, ...)
 
   # validity checks
+  if(!is.null(filename)){
+    realised <- write_raster_return_filename(realised,filename)
+  }
 
   simulation_object_original@state_target_realised <- realised
+  simulation_object_original@hash <- hash_sim_obj(simulation_object_original)
   simulation_object_original
 }

R/sim_state_target_realise_threshold.R

@@ -8,29 +8,23 @@
 #' sim_state_target_realised_threshold(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
+  threshold_fun<- function(simulation_object,threshold){
+    state_target <- binary_state_target <- simulation_object@state_target_suitability
+    for (i in 1:dim(state_target)[3]){
+      # Get the probability values from the state target
+      prob_values <- terra::values(state_target[[i]])
 
-  for (i in 1:dim(state_target)[3]){
-    # Get the probability values from the state target
-    prob_values <- terra::values(state_target[[i]])
+      # Simulate binary values from the binomial distribution based on the probability values
+      binary_values <- as.numeric(prob_values >= threshold)
 
-    # Simulate binary values from the binomial distribution based on the probability values
-    binary_values <- as.numeric(prob_values >= threshold)
-
-    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)
+      terra::values(binary_state_target[[i]]) <- binary_values
+    }
+    binary_state_target
   }
 
-  # Update the SimulationObject with the binary state_target
-  simulation_object_original@state_target_realised <- binary_state_target
-
-  simulation_object_original
+  sim_state_target_realise_fun(simulation_object,
+                               filename=filename,
+                               fun = threshold_fun,
+                               threshold=threshold)
 }

R/sim_state_target_suitability_fun.R

@@ -8,15 +8,19 @@
 #' \dontrun{
 #' sim_state_target_realise_fun(simulation_object, fun, ...)
 #' }
-sim_state_target_suitability_fun <- function(simulation_object, fun, ...) {
+sim_state_target_suitability_fun <- function(simulation_object,filename = NULL, fun, ...) {
   simulation_object_original <- simulation_object
   simulation_object <- read_sim_obj_rasters(simulation_object)
 
   # apply the function
   suitability <- fun(simulation_object, ...)
 
   # validity checks
+  if(!is.null(filename)){
+    suitability <- write_raster_return_filename(suitability,filename)
+  }
 
   simulation_object_original@state_target_suitability <- suitability
+  simulation_object_original@hash <- hash_sim_obj(simulation_object_original)
   simulation_object_original
 }

R/sim_state_target_suitability_uniform.R

@@ -9,25 +9,25 @@
 #' sim_state_target_suitability_uniform(simulation_object, 0.5)
 #' }
 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
+  uni_fun <- function(simulation_object,value,n_targets){
+    background <- simulation_object@background
 
-  sim_state <- rep(background[[1]],n_targets)
-  for(i in 1:n_targets){
-    terra::values(sim_state[[i]]) <- value
+    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)
+    sim_state
   }
 
-  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
+  simulation_object <- sim_state_target_suitability_fun(
+    simulation_object,
+    filename = filename,
+    fun = uni_fun,
+    value = value,
+    n_targets = n_targets)
 
   # Return the updated simulation_object
-  return(simulation_object_original)
+  return(simulation_object)
 }

R/util.R

@@ -36,3 +36,26 @@ write_raster_return_filename <- function(x, filename,overwrite=T, ...){
   writeRaster(x,filename,overwrite, ...)
   filename
 }
+
+
+
+hash_sim_obj <- function(sim_obj){
+  sim_obj <- read_sim_obj_rasters(sim_obj)
+  sim_obj@hash <- NULL
+
+  #get values from rasters
+  if(!is.null(sim_obj@background)){
+    sim_obj@background <- terra::values(sim_obj@background)
+  }
+  if(!is.null(sim_obj@state_env)){
+    sim_obj@state_env <- terra::values(sim_obj@state_env)
+  }
+  if(!is.null(sim_obj@state_target_suitability)){
+    sim_obj@state_target_suitability <- terra::values(sim_obj@state_target_suitability)
+  }
+  if(!is.null(sim_obj@state_target_realised)){
+    sim_obj@state_target_realised <- terra::values(sim_obj@state_target_realised)
+  }
+
+  digest::digest(sim_obj)
+}

tests/testthat/test-hashing.R

@@ -0,0 +1,43 @@
+library(STRIDER)
+
+# 1 Create the simulation object
+sim_obj1 <- SimulationObject(background = terra::rast(matrix(1,470,600)))
+sim_obj2 <- SimulationObject(background = terra::rast(matrix(1.0,470,600)))
+sim_obj3 <- SimulationObject(background = terra::rast(matrix(1,500,600)))
+
+test_that("Testing hashing at SimulationObject creation",{
+  expect_true(sim_obj1@hash == sim_obj2@hash)
+  expect_false(sim_obj2@hash == sim_obj3@hash)
+})
+
+# 2 Simulate a uniform state of the target across the background within the simulation object
+sim_obj1 <- sim_state_env_uniform(sim_obj1, value = 0.5000)
+sim_obj2 <- sim_state_env_uniform(sim_obj2, value = 0.5)
+sim_obj3 <- sim_state_env_uniform(sim_obj2, value = 0.6)
+
+test_that("Testing hashing at environment creation",{
+  expect_true(sim_obj1@hash == sim_obj2@hash)
+  expect_false(sim_obj2@hash == sim_obj3@hash)
+})
+
+# state suitability
+sim_obj1 <- sim_state_target_suitability_uniform(sim_obj1, value = 0.5000)
+sim_obj2 <- sim_state_target_suitability_uniform(sim_obj2, value = 0.5)
+sim_obj3 <- sim_state_target_suitability_uniform(sim_obj2, value = 0.6)
+
+test_that("Testing hashing at environment suitability simulation",{
+  expect_true(sim_obj1@hash == sim_obj2@hash)
+  expect_false(sim_obj2@hash == sim_obj3@hash)
+})
+
+
+# state suitability
+sim_obj1 <- sim_state_target_realise_threshold(sim_obj1, threshold = 0.5000)
+sim_obj2 <- sim_state_target_realise_threshold(sim_obj2, threshold = 0.5)
+sim_obj3 <- sim_state_target_realise_threshold(sim_obj2, threshold = 0.6)
+
+test_that("Testing hashing at environment suitability simulation",{
+  expect_true(sim_obj1@hash == sim_obj2@hash)
+  expect_false(sim_obj2@hash == sim_obj3@hash)
+})
+

tests/testthat/test-simulation_basic.R

@@ -9,12 +9,11 @@ sim_obj <- SimulationObject(background = background)
 # 2 Simulate a uniform state of the target across the background within the simulation object
 sim_obj <- sim_state_env_uniform(sim_obj, value = 0.6)
 
-
 # 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)
 
 # 2.5 realise the distribution
-sim_obj <- sim_state_target_realise_binomial(sim_obj)
+sim_obj <- sim_state_target_realise_threshold(sim_obj)
 
 # 3 Simulate effort across the landscape within the simulation object
 sim_obj <- sim_effort_uniform(sim_obj, n_samplers = 2, n_visits = 3, n_sample_units=2, replace = FALSE)