Small bug fix for manually supplied thresholds to scenarios

Author: Martin-Jung

NEWS.md

@@ -6,6 +6,7 @@
 
 #### Minor improvements and bug fixes
 * IIASA internal functionalities such as preparation of GLOBIOM data have been transferred to [BNRTools](https://github.com/iiasa/BNRTools)
+* Small bug fixed related to manual provision of scenario thresholds.
 
 # ibis.iSDM 0.1.5
 

R/class-distributionmodel.R

@@ -271,8 +271,8 @@ DistributionModel <- R6::R6Class(
                     colNA = NA, col = ibis_colours[['sdm_colour']]
         )
       } else {
-        message(
-          paste0('No model predictions found.')
+        cli::cli_alert_warning(
+          paste0('No model predictions found in object.')
         )
       }
     },
@@ -309,7 +309,7 @@ DistributionModel <- R6::R6Class(
                     colNA = NA, col = col
         )
       } else {
-        message("No computed threshold was found!")
+        cli::cli_alert_warning("No computed threshold was found!")
         invisible(self)
       }
     },
@@ -381,6 +381,7 @@ DistributionModel <- R6::R6Class(
       assertthat::assert_that(is.character(what))
       # Get model
       obj <- self$get_data(x)
+      cli::cli_inform('Calculating partial dependence plots...')
       if( self$get_name() == 'GDB-Model'){
         # How many effects
         n <- length( stats::coef( obj ))
@@ -412,7 +413,6 @@ DistributionModel <- R6::R6Class(
         ggplot2::ggplot() +
           inlabru::gg(obj$summary.fixed, bar = TRUE)
       } else if( self$get_name() == 'BART-Model'){
-        message('Calculating partial dependence plots')
         self$partial(obj, x.var = what, ...)
       } else if( self$get_name() == 'BREG-Model'){
         if(what == "fixed") what <- "coefficients"

R/project.R

@@ -140,7 +140,6 @@ methods::setMethod(
       }
     }
 
-
     new_crs <- new_preds$get_projection()
     if(is.na(new_crs)) if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Scenario]','yellow','Missing projection of future predictors.')
 
@@ -254,12 +253,22 @@ methods::setMethod(
     # Get constraints, threshold values and other parameters
     scenario_threshold <- mod$get_threshold()
     if(!is.Waiver(scenario_threshold)){
-      # Not get the baseline raster
-      thresh_reference <- grep('threshold',fit$show_rasters(),value = T)[1] # Use the first one always
-      assertthat::assert_that(!is.na(thresh_reference))
-      baseline_threshold <- mod$get_model()$get_data(thresh_reference)
-
+      # If scenario threshold is numeric and not a raster, create a baseline
+      if(is.numeric(scenario_threshold) && !is.Raster(scenario_threshold)){
+        baseline_threshold <- try({
+          # Get prediction and threshold
+          threshold(fit$get_data(),method = 'fixed', value = scenario_threshold)
+        },silent = TRUE)
+        if(inherits(baseline_threshold, "try-error")) cli::cli_alert_danger("Set thresholds require a prediction first!")
+      } else {
+        # Assume an existing threshold exists
+        thresh_reference <- grep('threshold',fit$show_rasters(),value = T)[1] # Use the first one always
+        assertthat::assert_that(!is.na(thresh_reference))
+        baseline_threshold <- fit$get_data(thresh_reference)
+      }
+      # Correct CRS just in case
       if(is.na(terra::crs(baseline_threshold))) terra::crs(baseline_threshold) <- terra::crs( background )
+
       # Furthermore apply new limits also to existing predictions (again)
       if(!is.null( mod$get_limits() )){
         # Get Limit and settings from model
@@ -286,7 +295,6 @@ methods::setMethod(
         baseline_threshold <- terra::extend(baseline_threshold, template)
         baseline_threshold <- terra::crop(baseline_threshold, template)
       }
-
     } else {
       baseline_threshold <- new_waiver()
     }

R/threshold.R

@@ -297,7 +297,7 @@ methods::setMethod(
       # Specify by type:
       if(method == "fixed"){
         # Fixed threshold. Confirm to be set
-        assertthat::assert_that(is.numeric(value), msg = 'Fixed value is missing!')
+        assertthat::assert_that(is.numeric(value), msg = 'For method Fixed, a constant value needs to be supplied!')
         tr <- value
       } else if(method == "mtp"){
         assertthat::assert_that(!is.null(poi_pres),msg = "Threshold method requires supplied point data!")
@@ -431,8 +431,8 @@ methods::setMethod(
 #'
 #' @param obj A [BiodiversityScenario] object to which an existing threshold is
 #' to be added.
-#' @param value A [`numeric`] value specifying the specific threshold for scenarios
-#' (Default: \code{NULL} Grab from object).
+#' @param value A [`numeric`] value specifying
+#' the specific threshold for scenarios (Default: \code{NULL} grabs the value from \code{obj}).
 #' @param ... Any other parameter. Used to fetch value if set somehow.
 #'
 #' @rdname threshold
@@ -450,9 +450,6 @@ methods::setMethod(
                               msg = "Parameter value not found and other numeric values not found?")
     }
 
-    # Assert that predicted raster is present
-    assertthat::assert_that( is.Raster(obj$get_model()$get_data('prediction')) )
-
     # Make a clone copy of the object
     new <- obj$clone(deep = TRUE)