Merge pull request #8 from BiologicalRecordsCentre/metadata

Plotting function for simualtionobject class, new and improve roxygen…

DESCRIPTION

@@ -13,7 +13,7 @@ Suggests:
     rmarkdown,
     testthat (>= 3.0.0)
 VignetteBuilder: knitr
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
 Imports:
     terra,
     sf

R/SimulationObjectClass.R

@@ -38,3 +38,39 @@ SimulationObject <- function(background, state_env = NULL, state_target_suitabil
       hash = hash_sim_obj(tmp)
   )
 }
+
+setMethod("plot", "SimulationObject", function(x) {
+  x <- read_sim_obj_rasters(x)
+
+  if(!is.null(x@state_env)){
+    plot(x@state_env,
+         main = paste("@state_env ",names(x@state_env)))
+  }
+
+  if(!is.null(x@state_target_suitability)){
+    plot(x@state_target_suitability,
+         main = paste("@state_target_suitability ",names(x@state_target_suitability)))
+  }
+
+  if(!is.null(x@state_target_realised)){
+    plot(x@state_target_realised,
+         main = paste("@state_target_realised ",names(x@state_target_realised)))
+  }
+
+  if(!is.null(x@effort)){
+    plot(x@background, main="@effort",legend = F,col = "white")
+    plot(x@effort$geometry,add=T)
+  }
+
+  if(!is.null(x@detect)){
+    plot(x@background, main="@detect",legend = F,col = "white")
+    plot(x@detect[x@detect$state_detected>0,c("geometry","state_detected")],col = "blue",add=T,pch=19)
+    plot(x@detect[x@detect$state_detected==0,c("geometry","state_detected")],col = "red",pch = 4,add=T)
+  }
+
+  if(!is.null(x@report)){
+    plot(x@background, main="@report",legend = F,col = "white")
+    plot(x@report[x@report$reported==T,c("geometry")],col = "blue",add=T,pch=19)
+    plot(x@detect[x@report$reported==F,c("geometry")],col = "red",pch = 4,add=T)
+  }
+})

R/basic_functions.R

@@ -1,3 +1,15 @@
+#' Create a Gradient SpatRaster for Environmental State
+#'
+#' @param simulation_object A SimulationObject containing the background layer.
+#' @param from The starting value of the gradient. Default is 0.
+#' @param to The ending value of the gradient. Default is 1.
+#'
+#' @return A SpatRaster representing the gradient environmental state.
+#' @examples
+#' \dontrun{
+#' sim_state <- state_env_gradient(simulation_object, from = 0, to = 1)
+#' }
+#' @export
 state_env_gradient <- function(simulation_object, from = 0, to = 1) {
   #create the gradient spatraster
   background <- simulation_object@background
@@ -7,6 +19,17 @@ state_env_gradient <- function(simulation_object, from = 0, to = 1) {
   sim_state
 }
 
+#' Create a Uniform SpatRaster for Environmental State
+#'
+#' @param simulation_object A SimulationObject containing the background layer.
+#' @param value The value to fill the raster with. Default is 1.
+#'
+#' @return A SpatRaster representing the uniform environmental state.
+#' @examples
+#' \dontrun{
+#' sim_state <- state_env_uniform(simulation_object, value = 1)
+#' }
+#' @export
 state_env_uniform <- function(simulation_object, value = 1) {
   #create the gradient spatraster
   background <- simulation_object@background
@@ -16,7 +39,18 @@ state_env_uniform <- function(simulation_object, value = 1) {
   sim_state
 }
 
-
+#' Create a Uniform Suitability SpatRaster for Target State
+#'
+#' @param simulation_object A SimulationObject containing the background layer.
+#' @param value The value to fill the raster with. Default is 0.5.
+#' @param n_targets The number of target layers. Default is 1.
+#'
+#' @return A SpatRaster representing the uniform suitability for target state.
+#' @examples
+#' \dontrun{
+#' sim_state <- state_target_suitability_uniform(simulation_object, value = 0.5, n_targets = 2)
+#' }
+#' @export
 state_target_suitability_uniform <- function(simulation_object,value = 0.5,n_targets=1){
   background <- simulation_object@background
 
@@ -28,6 +62,18 @@ state_target_suitability_uniform <- function(simulation_object,value = 0.5,n_tar
   sim_state
 }
 
+#' Create Virtual Species Suitability SpatRaster for Target State
+#'
+#' @param simulation_object A SimulationObject containing the background and environmental layers.
+#' @param n_targets The number of target layers. Default is 1.
+#' @param params A list of parameters for generating virtual species. Default is NULL.
+#'
+#' @return A SimulationObject with updated target suitability layers.
+#' @examples
+#' \dontrun{
+#' sim_object <- state_target_suitability_virtsp(simulation_object, n_targets = 2)
+#' }
+#' @export
 state_target_suitability_virtsp <- function(simulation_object, n_targets = 1, params = NULL) {
   simulation_object_original <- simulation_object
   simulation_object <- read_sim_obj_rasters(simulation_object)
@@ -77,7 +123,16 @@ state_target_suitability_virtsp <- function(simulation_object, n_targets = 1, pa
   return(simulation_object_original)
 }
 
-
+#' Realize Target Suitability Using Binomial Distribution
+#'
+#' @param simulation_object A SimulationObject containing the target suitability layers.
+#'
+#' @return A SpatRaster with realized target states as binary values.
+#' @examples
+#' \dontrun{
+#' binary_state <- state_target_realise_binomial(simulation_object)
+#' }
+#' @export
 state_target_realise_binomial <- function(simulation_object){
   state_target <- binary_state_target <- simulation_object@state_target_suitability
   for (i in 1:dim(state_target)[3]){
@@ -92,7 +147,17 @@ state_target_realise_binomial <- function(simulation_object){
   binary_state_target
 }
 
-
+#' Realize Target Suitability Using Threshold
+#'
+#' @param simulation_object A SimulationObject containing the target suitability layers.
+#' @param threshold A numeric value specifying the threshold for realization.
+#'
+#' @return A SpatRaster with realized target states as binary values based on the threshold.
+#' @examples
+#' \dontrun{
+#' binary_state <- state_target_realise_threshold(simulation_object, threshold = 0.5)
+#' }
+#' @export
 state_target_realise_threshold <- function(simulation_object,threshold){
   state_target <- binary_state_target <- simulation_object@state_target_suitability
   for (i in 1:dim(state_target)[3]){
@@ -108,14 +173,39 @@ state_target_realise_threshold <- function(simulation_object,threshold){
 }
 
 
-
-effort_uniform <- function(simulation_object, n_samplers = 1, n_visits = 1, n_sample_units=1, replace = FALSE) {
+#' Generate Sampling Effort Points
+#'
+#' @param simulation_object A SimulationObject containing the target suitability layers.
+#' @param n_samplers The number of samplers. Default is 1.
+#' @param n_visits The number of visits per sampler. Default is 1.
+#' @param n_sample_units The number of sample units per visit. Default is 1.
+#' @param replace A logical value indicating whether sampling with replacement is allowed. Default is FALSE.
+#' @param prob_raster A SpatRaster providing the probability of sampling each cell. Default is NULL.
+#'
+#' @return An sf object containing the sampling effort points.
+#' @examples
+#' \dontrun{
+#' effort <- effort_basic(simulation_object, n_samplers = 2, n_visits = 3)
+#' }
+#' @export
+effort_basic <- function(simulation_object, n_samplers = 1, n_visits = 1, n_sample_units=1, replace = FALSE,prob_raster = NULL) {
 
   #which cells are visited
   state_target <- simulation_object@state_target_suitability
-  visited_cells <- rep(sample(terra::cells(state_target), size = n_samplers*n_visits, replace = replace),each = n_sample_units)
 
-  # capture data
+  if (is.null(prob_raster)){
+    prob <- NULL
+  } else {
+    prob <- terra::values(prob_raster)
+  }
+  visited_cells <- rep(sample(terra::cells(state_target),
+                              size = n_samplers*n_visits,
+                              replace = replace,
+                              prob = prob
+                              ),
+                       each = n_sample_units)
+
+  # capture sampling meta data (who, when, etc.)
   sim_effort_points <- as.data.frame(terra::xyFromCell(state_target, visited_cells))
   sim_effort_points$sampler <- rep(1:n_samplers,each = n_visits*n_sample_units)
   sim_effort_points$visit <- rep(1:n_visits,n_samplers,each = n_sample_units)
@@ -125,22 +215,23 @@ effort_uniform <- function(simulation_object, n_samplers = 1, n_visits = 1, n_sa
 
   effort_sf <- sf::st_as_sf(sim_effort_points, coords = c("x", "y"), crs = terra::crs(state_target))
 
-  #get values from env, suitability, realised
-  extracted_values <- terra::extract(simulation_object@state_env,effort_sf$cell_id)
-  effort_sf[,names(extracted_values)] <- extracted_values
-  extracted_values <- terra::extract(simulation_object@state_target_suitability,effort_sf$cell_id)
-  effort_sf[,paste0("suit_",names(extracted_values))] <- extracted_values
-  extracted_values <- terra::extract(simulation_object@state_target_realised,effort_sf$cell_id)
-  effort_sf[,paste0("real_",names(extracted_values))] <- extracted_values
-
   effort_sf
-
 }
 
 
 
-
-detect_equal <- function(simulation_object, prob = 0.5) {
+#' Detect Presence/Absence Based on Equal Probability
+#'
+#' @param simulation_object A SimulationObject containing the realized target states and sampling effort points.
+#' @param prob The detection probability. Default is 1.
+#'
+#' @return A data frame containing the detection results.
+#' @examples
+#' \dontrun{
+#' detections <- detect_equal(simulation_object, prob = 0.8)
+#' }
+#' @export
+detect_equal <- function(simulation_object, prob = 1) {
 
   background <- simulation_object@background
   state_env <- simulation_object@state_env
@@ -164,11 +255,14 @@ detect_equal <- function(simulation_object, prob = 0.5) {
     detections$state_realised <- unname(terra::extract(state_target[[i]], effort,ID=F,raw=T))
 
     #detect based probability value provided as argument
-    detections$detected <- detections$state_realised * (runif(nrow(detections)) < prob)
+    detections$detection_ability <- runif(nrow(detections)) < prob
+
+    #recorded presence/absense
+    detections$state_detected <- detections$detection_ability * detections$state_realised
 
-    #in this basic example all are identified correctly
-    detections$identified_as <- detections$target
-    detections$identified_correct <- detections$identified_as==detections$target
+    #in this basic example all are identified correctly (ignore for now)
+    # detections$identified_as <- detections$target
+    # detections$identified_correct <- detections$identified_as==detections$target
 
     detections_all <- rbind(detections_all, detections)
   }
@@ -177,15 +271,23 @@ detect_equal <- function(simulation_object, prob = 0.5) {
   detections_all
 }
 
-
-report_equal <- function(simulation_object, prob = 1, platform = "iRecord") {
+#' Report Detections Based on Reporting Probability
+#'
+#' @param simulation_object A SimulationObject containing the detection results.
+#' @param prob The reporting probability. Default is 1.
+#' @param platform The platform used for reporting. Default is "None".
+#'
+#' @return A data frame containing the reporting results.
+#' @examples
+#' \dontrun{
+#' reports <- report_equal(simulation_object, prob = 0.8, platform = "Online")
+#' }
+#' @export
+report_equal <- function(simulation_object, prob = 1, platform = "None") {
   detect <- simulation_object@detect
 
   reports <- detect
   reports$reported <- runif(nrow(reports)) < prob
-
-  reports$reported[reports$detected == FALSE] <- FALSE
-
   reports$platform <- platform
 
   reports

R/sim_effort.R

@@ -1,32 +1,47 @@
-#' Defines effort using a custom function
+#' Defines effort using a built-in function, a custom function, or sf POINTS
 #'
-#' @param simulation_object a SimulationObject
-#' @param fun a function that takes the simulation object and returns a simulation object with  data in effort slot
-#' @param ... other parameters for the user supplied function fun
-#' @return A SimulationObject with a state_target_realised
+#' This function applies a user-supplied function to a SimulationObject to define effort.
+#'
+#' @param simulation_object A SimulationObject containing simulation data.
+#' @param fun A function that takes the simulation_object and additional parameters, and returns a modified simulation_object with effort data.
+#' @param sf Optional; if provided, skips applying 'fun' and directly uses this Spatial*DataFrame (sf) for effort calculation.
+#' @param ... Additional parameters passed to the user-supplied function 'fun'.
+#' @return A SimulationObject with updated effort information.
 #' @examples
 #' \dontrun{
 #' sim_effort(simulation_object, fun, ...)
 #' }
-sim_effort <- function(simulation_object, fun, ...) {
+#' @export
+sim_effort <- function(simulation_object, fun, sf=NULL, ...) {
   simulation_object_original <- simulation_object
   simulation_object <- read_sim_obj_rasters(simulation_object)
 
-  if(is.character(fun)){
-    if(!(fun %in% c("uniform"))){
-      stop("Provided function must be 'uniform'")
+  if (is.null(sf)){
+    if(is.character(fun)){
+      if(!(fun %in% c("basic"))){
+        stop("Provided function must be 'basic'")
+      }
+      fun <- get(paste0("effort_",fun))
     }
-    fun <- get(paste0("effort_",fun))
+    # apply the function
+    effort_sf <- fun(simulation_object, ...)
+  } else {
+    effort_sf <- sf
   }
 
-  # apply the function
-  effort <- fun(simulation_object, ...)
+  #get values from env, suitability, realised
+  extracted_values <- terra::extract(simulation_object@state_env,effort_sf)
+  effort_sf[,names(extracted_values)] <- extracted_values
+  extracted_values <- terra::extract(simulation_object@state_target_suitability,effort_sf)
+  effort_sf[,paste0("suit_",names(extracted_values))] <- extracted_values
+  extracted_values <- terra::extract(simulation_object@state_target_realised,effort_sf)
+  effort_sf[,paste0("real_",names(extracted_values))] <- extracted_values
 
   # validity checks
   fun_args <- as.list(match.call())
   simulation_object_original@metadata[["effort"]] <- fun_args[3:length(fun_args)]
 
-  simulation_object_original@effort <- effort
+  simulation_object_original@effort <- effort_sf
   simulation_object_original@hash <- hash_sim_obj(simulation_object_original)
   simulation_object_original
 }

R/sim_state_env.R

@@ -1,14 +1,36 @@
-#' The state of the environment
+#' Define the state of the environment
+#'
+#' This function updates the state environment of a given simulation object by
+#' either using a provided SpatRaster, a predefined function (`gradient` or `uniform`),
+#' or a user-defined function. The updated simulation object with the new state environment
+#' and metadata is returned.
+#'
+#' @param simulation_object An object representing the simulation. The object should contain
+#'                          a `background` slot and a `state_env` slot.
+#' @param fun A character string specifying the name of a predefined function            (`"gradient"` or `"uniform"`) or a user-defined function.
+#' @param filename A character string specifying the filename to save the resultant SpatRaster. If `NULL`, the SpatRaster is not saved to a file.
+#' @param spatraster A `SpatRaster` object to be used directly as the state environment. If provided, it overrides the `fun` parameter.
+#' @param ... Additional arguments to be passed to the function specified in `fun`.
 #'
-#' @param simulation_object an R object of class 'SimulationObject' containing all the necessary information for the simulation
-#' @param fun either a function to be used, or a name of a provided function
-#' @param filename a file name and path to save the spatraster
-#' @param spatraster a SpatRaster to be used as the environment
 #' @return An updated simulation object with the newly added state of the environment in the correct slot
+#'
+#' @details
+#' - If a `spatraster` is provided, the function checks that its dimensions match
+#'   those of the simulation object's background.
+#' - If `fun` is provided as a character string, it must be either `"gradient"` or `"uniform"`.
+#' - If `fun` is provided as a user-defined function, it will be applied to the simulation object.
+#' - If `filename` is provided, the resultant SpatRaster is saved, and the filename is returned.
+#'
 #' @examples
 #' \dontrun{
-#' sim_state_env(simulation_object, fun = "uniform",value=1)
+#' sim_obj <- sim_state_env(sim_obj, fun = "uniform", value = 0.5)
+#' sim_obj <- sim_state_env(sim_obj, fun = "gradient", from = 0, to = 1)
+#' sim_obj <- sim_state_env(sim_obj, spatraster = my_spatraster)
+#' sim_obj <- sim_state_env(sim_obj, fun = my_custom_function)
+#' sim_obj <- sim_state_env(sim_obj, fun = "uniform", filename = "output.tif")
 #' }
+#'
+#' @export
 sim_state_env <- function(simulation_object, fun= NULL, filename = NULL, spatraster=NULL, ...) {
 
   #load in rasters but create a copy with the original version