From 49ff1eeabad6c2f878cc748f17585529beb27083 Mon Sep 17 00:00:00 2001 From: Simon Rolph Date: Thu, 4 Apr 2024 17:26:23 +0100 Subject: [PATCH] Hashing for environment and target suitability and realisation. Updated tests to correspond. --- R/SimulationObjectClass.R | 5 +-- R/sim_state_env_byod.R | 4 +-- R/sim_state_target_realise_binomial.R | 1 + R/sim_state_target_realise_fun.R | 6 +++- R/sim_state_target_realise_threshold.R | 34 ++++++++----------- R/sim_state_target_suitability_fun.R | 6 +++- R/sim_state_target_suitability_uniform.R | 30 ++++++++--------- R/util.R | 23 +++++++++++++ tests/testthat/test-hashing.R | 43 ++++++++++++++++++++++++ tests/testthat/test-simulation_basic.R | 3 +- 10 files changed, 109 insertions(+), 46 deletions(-) create mode 100644 tests/testthat/test-hashing.R diff --git a/R/SimulationObjectClass.R b/R/SimulationObjectClass.R index 82b23dd..6813fda 100644 --- a/R/SimulationObjectClass.R +++ b/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) ) } diff --git a/R/sim_state_env_byod.R b/R/sim_state_env_byod.R index 56c5a7b..3443501 100644 --- a/R/sim_state_env_byod.R +++ b/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) diff --git a/R/sim_state_target_realise_binomial.R b/R/sim_state_target_realise_binomial.R index 9aa9bc4..9f4a498 100644 --- a/R/sim_state_target_realise_binomial.R +++ b/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) diff --git a/R/sim_state_target_realise_fun.R b/R/sim_state_target_realise_fun.R index 1719f18..095a78a 100644 --- a/R/sim_state_target_realise_fun.R +++ b/R/sim_state_target_realise_fun.R @@ -8,7 +8,7 @@ #' \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) @@ -16,7 +16,11 @@ sim_state_target_realise_fun <- function(simulation_object, fun, ...) { 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 } diff --git a/R/sim_state_target_realise_threshold.R b/R/sim_state_target_realise_threshold.R index bdc5c50..945f22c 100644 --- a/R/sim_state_target_realise_threshold.R +++ b/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) } diff --git a/R/sim_state_target_suitability_fun.R b/R/sim_state_target_suitability_fun.R index 96e250a..47aa6ee 100644 --- a/R/sim_state_target_suitability_fun.R +++ b/R/sim_state_target_suitability_fun.R @@ -8,7 +8,7 @@ #' \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) @@ -16,7 +16,11 @@ sim_state_target_suitability_fun <- function(simulation_object, fun, ...) { 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 } diff --git a/R/sim_state_target_suitability_uniform.R b/R/sim_state_target_suitability_uniform.R index 82b10ca..e393b32 100644 --- a/R/sim_state_target_suitability_uniform.R +++ b/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) } diff --git a/R/util.R b/R/util.R index deb4b57..50d2bc0 100644 --- a/R/util.R +++ b/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) +} diff --git a/tests/testthat/test-hashing.R b/tests/testthat/test-hashing.R new file mode 100644 index 0000000..43737e9 --- /dev/null +++ b/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) +}) + diff --git a/tests/testthat/test-simulation_basic.R b/tests/testthat/test-simulation_basic.R index 4ecef1f..95d4675 100644 --- a/tests/testthat/test-simulation_basic.R +++ b/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)