diff --git a/R/SimulationObjectClass.R b/R/SimulationObjectClass.R index 4daa387..82b23dd 100644 --- a/R/SimulationObjectClass.R +++ b/R/SimulationObjectClass.R @@ -7,12 +7,26 @@ 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, @@ -20,6 +34,7 @@ SimulationObject <- function(background, state_env = NULL, state_target_suitabil state_target_realised = state_target_realised, effort = effort, detect = detect, - report = report + report = report, + hash = hash ) } diff --git a/R/sim_detect_equal.R b/R/sim_detect_equal.R index 97a091b..112b0b2 100644 --- a/R/sim_detect_equal.R +++ b/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 diff --git a/R/sim_detect_fun.R b/R/sim_detect_fun.R index 6dea162..9299614 100644 --- a/R/sim_detect_fun.R +++ b/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, ...) diff --git a/R/sim_effort_fun.R b/R/sim_effort_fun.R index 58cd4b8..1bbd84f 100644 --- a/R/sim_effort_fun.R +++ b/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, ...) diff --git a/R/sim_effort_uniform.R b/R/sim_effort_uniform.R index a003738..0d597d0 100644 --- a/R/sim_effort_uniform.R +++ b/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 diff --git a/R/sim_report_equal.R b/R/sim_report_equal.R index fbb78aa..792b0b0 100644 --- a/R/sim_report_equal.R +++ b/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 diff --git a/R/sim_report_fun.R b/R/sim_report_fun.R index ee8fef7..34635b2 100644 --- a/R/sim_report_fun.R +++ b/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, ...) diff --git a/R/sim_state_env_byod.R b/R/sim_state_env_byod.R index 653c969..0dacef6 100644 --- a/R/sim_state_env_byod.R +++ b/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) diff --git a/R/sim_state_env_gradient.R b/R/sim_state_env_gradient.R index 12ec98d..966c590 100644 --- a/R/sim_state_env_gradient.R +++ b/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) } diff --git a/R/sim_state_env_uniform.R b/R/sim_state_env_uniform.R index 358f795..4180d98 100644 --- a/R/sim_state_env_uniform.R +++ b/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) } diff --git a/R/sim_state_target_realise_binomial.R b/R/sim_state_target_realise_binomial.R index ec1a161..9aa9bc4 100644 --- a/R/sim_state_target_realise_binomial.R +++ b/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 diff --git a/R/sim_state_target_realise_fun.R b/R/sim_state_target_realise_fun.R index b5225c6..1719f18 100644 --- a/R/sim_state_target_realise_fun.R +++ b/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, ...) diff --git a/R/sim_state_target_realise_threshold.R b/R/sim_state_target_realise_threshold.R index 995aa88..bdc5c50 100644 --- a/R/sim_state_target_realise_threshold.R +++ b/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 diff --git a/R/sim_state_target_suitability_fun.R b/R/sim_state_target_suitability_fun.R index f575548..96e250a 100644 --- a/R/sim_state_target_suitability_fun.R +++ b/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, ...) diff --git a/R/sim_state_target_suitability_uniform.R b/R/sim_state_target_suitability_uniform.R index 6824d9d..82b10ca 100644 --- a/R/sim_state_target_suitability_uniform.R +++ b/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 diff --git a/R/sim_state_target_suitability_virtualspecies.R b/R/sim_state_target_suitability_virtualspecies.R index 57ae122..25e6552 100644 --- a/R/sim_state_target_suitability_virtualspecies.R +++ b/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 diff --git a/R/util.R b/R/util.R index 7f35d5f..deb4b57 100644 --- a/R/util.R +++ b/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 +} diff --git a/tests/testthat/test-simulation_basic.R b/tests/testthat/test-simulation_basic.R index a29847f..4c78677 100644 --- a/tests/testthat/test-simulation_basic.R +++ b/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)