Fixing previous 🐛 introduced through controls revamping

R/bdproto-biodiversitydistribution.R

@@ -45,7 +45,7 @@ BiodiversityDistribution <- bdproto(
     pio <- ifelse(is.Waiver(self$priors),
                   '<Default>', paste0('Priors specified (',self$priors$length(), ')') )
     bv <- ifelse(is.Waiver(self$control), '',
-                 paste0( "\n  control:   <", name_atomic(
+                 paste0( "\n  control:        <", name_atomic(
                    paste0( self$control$type, " - ", self$control$method)
                  ), ">" ) )
     li <- ifelse(is.Waiver(self$limits), '',
@@ -247,7 +247,7 @@ BiodiversityDistribution <- bdproto(
     assertthat::assert_that(missing(x) || is.Raster(x),
                             all(is.numeric(value)))
     # Check type of control
-    type <- match.arg(type, c("bias", "extrapolation"), several.ok = FALSE)
+    type <- match.arg(type, c("bias"), several.ok = FALSE)
     if(type == "bias"){
       if(missing(x)) {
         assertthat::assert_that(method == "proximity",
@@ -256,17 +256,15 @@ BiodiversityDistribution <- bdproto(
       }
       bdproto(NULL, self, control = list(type = type, layer = x,
                                          method = method, bias_value = value) )
-    } else if(type == "extrapolation"){
-      bdproto(NULL, self, control = list(type = type, layer = x, method = method, value = value) )
     }
   },
   # Get bias control (print name)
   get_control = function(self, type = "bias"){
     # Check type of control
-    type <- match.arg(type, c("bias", "extrapolation"), several.ok = FALSE)
+    type <- match.arg(type, c("bias"), several.ok = FALSE)
     control <- self$control
     if(is.Waiver(control)) return( control )
-    if(control$type == "bias" && type == "bias") names( control )
+    if(control$type == "bias" && type == "bias") return( control )
   },
   # Remove bias controls
   rm_control = function(self){

tests/testthat/test_controls.R

@@ -1,6 +1,6 @@
 # ---- #
 # Train a full distribution model with glm base model
-test_that('Test controls', {
+test_that('Test controls and limits', {
 
   skip_on_travis()
   skip_on_cran()
@@ -31,6 +31,7 @@ test_that('Test controls', {
   zones <- terra::as.factor( predictors$koeppen_50km )
   y <- x |> add_control_extrapolation(layer = zones, method = "zones")
   expect_false(y$get_limits() |> is.Waiver())
+  expect_length(y$get_limits(), 4) # Those are saved in limits in the object
 
   # Add mcp limits
   y <- x |> add_control_extrapolation(method = "mcp")
@@ -72,4 +73,19 @@ test_that('Test controls', {
   # Create a scenario object and reuse limits
   expect_no_error( scenario(mod, reuse_limits = TRUE) )
 
+  # --- #
+  # Bias control checks
+  x <- x$rm_limits()
+  x <- x |> add_control_bias(layer = predictors$hmi_mean_50km)
+  # Train with bias
+  expect_no_error(
+    suppressWarnings(
+      mod <- train(x |> engine_glm(), "test", inference_only = FALSE, only_linear = TRUE,
+                   varsel = "none", verbose = FALSE)
+    )
+  )
+  expect_length( x$get_control(), 4 )
+  settings <- mod$settings
+  expect_equal(settings$get("bias_variable"), "hmi_mean_50km")
 })
+