Small 🐛 fixes to ensemble learner and predictors

Author: Martin-Jung

NEWS.md

@@ -11,7 +11,7 @@
 * Small bug fixed related to manual provision of scenario thresholds.
 * `predictor_filter()` now also accepts [`SpatRaster`] objects as inputs.
 * Small fix so that bounding box extent is correctly printed #138
-* Small bug fix to `engine_gdb` in dev branch.
+* Small :bug: fixes to `engine_gdb` in dev branch.
 
 # ibis.iSDM 0.1.5
 

R/ensemble.R

@@ -252,16 +252,27 @@ methods::setMethod(
           # Ensure that predictions have unique names
           names(ras) <- paste0('model', 1:terra::nlyr(ras))
           ex <- terra::extract(ras, point, ID = FALSE)
-          ex <- cbind(point[,field_occurrence], ex)
-          fit <- stats::glm(
-            formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> stats::as.formula(),
-            family = stats::binomial(),data = ex
-          )
+          ex <- cbind(point[,field_occurrence] |> sf::st_drop_geometry(), ex)
+          vars <- names(ras)
+
+          # If any variable is fully NAs, remove
+          check <- apply(ex, 2, function(z) all(is.na(z)))
+          if(any(check)){
+            cli::cli_alert_warning(paste("Removing ", names(which(check)), "because there are only NA values..."))
+            ex <- ex[,which(!check)]
+            vars <- vars[vars %in% names(which(!check))]
+          }
+          fit <- try({
+              stats::glm(
+              formula = paste(field_occurrence, "~", paste0(vars, collapse = ' + ')) |> stats::as.formula(),
+              family = stats::binomial(),data = ex)
+            },silent = TRUE)
+          if(inherits(fit, 'try-error')) cli::cli_abort('SuperlearModel did not fit...', fit)
           # Now predict output with the meta-learner
-          new <- emptyraster(ras)
-          new[which(!is.na(ras[[1]])[])] <- terra::predict(
-            fit, ras, na.rm = FALSE, type = "response",
+          new <- terra::predict(
+            object = ras, model = fit, na.rm = FALSE, type = "response",
             cores = getOption('ibis.nthread'))
+          names(new) <- paste0('superlearner_lyr')
           attr(new, "superlearner.coefficients") <- stats::coef(fit)
           try({ rm(ex,fit) },silent = TRUE)
         }

R/utils-predictors.R

@@ -1198,6 +1198,7 @@ predictor_check <- function(env){
 
   # Check NaN
   check_nan <- apply(env, 2, function(z) all(is.nan(z)))
+  if(any(is.na(check_nan))) check_nan[is.na(check_nan)] <- FALSE
   if(any(check_nan)){
     if(getOption('ibis.setupmessages', default = TRUE)) {
       myLog('[Setup]','yellow', 'Excluded ', paste0(names(which(check_nan)),collapse = "; "),
@@ -1218,6 +1219,7 @@ predictor_check <- function(env){
 
   # Check variance
   check_var <- apply(env, 2, function(z) stats::var(z, na.rm = TRUE)) == 0
+  if(any(is.na(check_var))) check_var[is.na(check_var)] <- FALSE
   if(any(check_var)){
     if(getOption('ibis.setupmessages', default = TRUE)) {
       myLog('[Setup]','yellow', 'Excluded ', paste0(names(which(check_var)),collapse = "; "),

R/utils.R

@@ -322,7 +322,8 @@ thresholdval <- function(x, knot, sense = "gte") {
 #'
 #' @noRd
 scale_weight <- function(v, method = "scale"){
-  if(is.null(v)) return(1) # Return dummy 1 for equal weight
+  if(is.null(v)) return(NULL) # Return dummy 1 for equal weight
+  if(length(v)==0) return(NULL)
   assertthat::assert_that(
     length(v)>1,
     is.character(method)

tests/testthat/test_modelFits.R

@@ -118,6 +118,8 @@ test_that('Add further tests for model fits', {
   expect_s4_class(o, "SpatRaster")
   expect_length(names(o), 2) # Should be at maximum 2 layers
 
+
+
   # ----------- #
   # Partial stuff
   skip_if_not_installed("pdp")