v4.2-3-5 fixed bugs with categorical variables and missing values. pr…

…ojection are now calculated only for cells without any missing values
biomodhub · Jun 1, 2023 · cd2352d · cd2352d
1 parent 0aee6ad
commit cd2352d
Show file tree

Hide file tree

Showing 92 changed files with 146 additions and 116 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: biomod2
 Type: Package
 Title: Ensemble Platform for Species Distribution Modeling
-Version: 4.2-3-4
+Version: 4.2-3-5
 Date: 2023-05-22
 Authors@R: c(person("Wilfried", "Thuiller", role = c("aut")
                     , email = "[email protected]"),

diff --git a/R/BIOMOD_EnsembleForecasting.R b/R/BIOMOD_EnsembleForecasting.R
@@ -221,7 +221,7 @@
 ##' plot(myBiomodEMProj)
 ##' 
 ##' 
-##' @importFrom terra rast `add<-` wrap writeRaster
+##' @importFrom terra rast `add<-` wrap writeRaster mask
 ##' 
 ##' 
 ##' @export
@@ -309,7 +309,7 @@ BIOMOD_EnsembleForecasting <- function(bm.em,
 
     # remove tmp directory
     unlink(file.path(bm.em@dir.name, bm.em@sp.name, paste0("proj_", tmp_dir))
-    , recursive = TRUE, force = TRUE)
+           , recursive = TRUE, force = TRUE)
   }
   if (!proj_is_raster) {
     formal_pred <- tapply(X = formal_pred$pred, INDEX = list(formal_pred$points, formal_pred$full.name), FUN = mean)
@@ -603,6 +603,8 @@ BIOMOD_EnsembleForecasting <- function(bm.em,
 
     if (inherits(new.env, 'SpatRaster')) {
       .fun_testIfIn(TRUE, "names(new.env)", names(new.env), bm.em@expl.var.names)
+      new.env.mask <- .get_data_mask(new.env, value.out = 1)
+      new.env <- mask(new.env, new.env.mask)
     } else {
       .fun_testIfIn(TRUE, "colnames(new.env)", colnames(new.env), bm.em@expl.var.names)
     }

diff --git a/R/BIOMOD_Projection.R b/R/BIOMOD_Projection.R
@@ -188,7 +188,7 @@
 ##' @importFrom foreach foreach %dopar% 
 ## @importFrom doParallel registerDoParallel
 ##' @importFrom terra rast subset nlyr writeRaster terraOptions wrap unwrap
-##'  mem_info app is.factor
+##'  mem_info app is.factor mask
 ##' @importFrom utils capture.output
 ##' @importFrom abind asub
 ##' 
@@ -517,7 +517,7 @@ BIOMOD_Projection <- function(bm.mod,
     # conversion into SpatRaster
     if (any(raster::is.factor(new.env))) {
       new.env <- .categorical_stack_to_terra(raster::stack(new.env),
-                                            expected_levels = head(get_formal_data(bm.mod, subinfo = "expl.var"))
+                                             expected_levels = head(get_formal_data(bm.mod, subinfo = "expl.var"))
       )
     } else {
       new.env <- rast(new.env)
@@ -526,6 +526,8 @@ BIOMOD_Projection <- function(bm.mod,
 
   if (inherits(new.env, 'SpatRaster')) {
     .fun_testIfIn(TRUE, "names(new.env)", names(new.env), bm.mod@expl.var.names)
+    new.env.mask <- .get_data_mask(new.env, value.out = 1)
+    new.env <- mask(new.env, new.env.mask)
   } else {
     .fun_testIfIn(TRUE, "colnames(new.env)", colnames(new.env), bm.mod@expl.var.names)
   }

diff --git a/R/bm_PseudoAbsences.R b/R/bm_PseudoAbsences.R
@@ -631,12 +631,9 @@ setMethod('bm_PseudoAbsences_random', signature(expl.var = "SpatRaster"),
             } else {
               cat("\n   > Pseudo absences are selected in explanatory variables")
               # create a mask containing all not already sampled points (presences and absences)
-              mask.env <- mask.out <- subset(expl.var, 1)
-              ## the area we want to sample
-              mask.env <- classify(mask.env, matrix(c(-Inf, Inf, -1), 
-                                                    ncol = 3, byrow = TRUE)) 
-              mask.out[] <- NA
 
+              ## the area we want to sample
+              mask.out <- mask.env <- .get_data_mask(expl.var, value.out = -1)
               # add presences and true absences in our mask
               in.cells <- cellFromXY(mask.env, crds(resp.var))
               mask.env[in.cells] <- NA
@@ -940,16 +937,16 @@ setMethod('bm_PseudoAbsences_disk', signature(expl.var = "SpatRaster"),
 
               if (is.null(dist.max)) { 
                 dist.max <- Inf 
-                }
+              }
               mask.in <- classify(dist.mask, 
                                   matrix(c(-Inf, dist.min, NA,
-                                               dist.min, dist.max, 1, 
-                                               dist.max, Inf, NA),
+                                           dist.min, dist.max, 1, 
+                                           dist.max, Inf, NA),
                                          ncol = 3, byrow = TRUE))
               mask.in[cellFromXY(mask.in, pres.xy)] <- 1
               mask.in = expl.var * mask.in
               names(mask.in) = names(expl.var)
-
+              
               # 2. selecting randomly pseudo absences
               return(bm_PseudoAbsences_random(resp.var, expl.var = mask.in, nb.absences, nb.rep))
             }

diff --git a/R/bm_SampleFactorLevels.R b/R/bm_SampleFactorLevels.R
@@ -125,25 +125,33 @@ bm_SampleFactorLevels.SpatRaster <- function(expl.var, mask.out = NULL, mask.in
 
       ## get the factor levels on the full dataset
       fact.level.names <- cats(subset(expl.var, f))[[1]][,2]
-      fact.level <- fact.level.original <- seq_along(fact.level.names)
+      fact.level <- fact.level.original <- cats(subset(expl.var, f))[[1]][,1]
       cat("\n\t> fact.level for",  names(expl.var)[f], ":\t", paste(fact.level, fact.level.names, sep = ":", collapse = "\t"))
-
       ## mask containing points that have already been sampled ------------------------------------
       if (!is.null(mask.out))
       {
         ## check the factor levels that have already been sampled
         fact.levels.sampled <- 
           unique(na.omit(
-            values(mask(subset(expl.var, f), mask.out))
-            ))
+            values((mask(subset(expl.var, f), mask.out, maskvalues = c(1), inverse = TRUE)))
+          ))
         ## update levels names (lost during mask conversion)
         cat("\n\t - according to mask.out levels", fact.levels.sampled, "have already been sampled")
         ## update the list of factor levels to sample
         fact.level <- setdiff(fact.level, fact.levels.sampled)
       }
-
       ## if there still is some levels to sample --------------------------------------------------
+      ## take a random value of them in the full dataset 
+      if (length(fact.level) > 0) {
+        cat("\n\t - levels", fact.level, "will be sampled in the original raster")
+        selected.cells <- c(selected.cells, sapply(fact.level, function(fl) {
+          ind = which(subset(expl.var, f)[] == fl)
+          if (length(ind) > 0) {
+            return(sample(ind, 1))
+          }
+        }))
       }
+
       return(unlist(selected.cells))
     })))
     return(unique(fact.level.cells))

diff --git a/docs/404.html b/docs/404.html
diff --git a/docs/articles/index.html b/docs/articles/index.html
diff --git a/docs/articles/news.html b/docs/articles/news.html
diff --git a/docs/authors.html b/docs/authors.html
diff --git a/docs/index.html b/docs/index.html
diff --git a/docs/reference/BIOMOD.ensemble.models.out.html b/docs/reference/BIOMOD.ensemble.models.out.html
diff --git a/docs/reference/BIOMOD.formated.data.PA.html b/docs/reference/BIOMOD.formated.data.PA.html
diff --git a/docs/reference/BIOMOD.formated.data.html b/docs/reference/BIOMOD.formated.data.html
diff --git a/docs/reference/BIOMOD.models.options.html b/docs/reference/BIOMOD.models.options.html
diff --git a/docs/reference/BIOMOD.models.out.html b/docs/reference/BIOMOD.models.out.html
diff --git a/docs/reference/BIOMOD.projection.out.html b/docs/reference/BIOMOD.projection.out.html
diff --git a/docs/reference/BIOMOD.stored.data.html b/docs/reference/BIOMOD.stored.data.html
diff --git a/docs/reference/BIOMOD_ConvertOldRun-deprecated.html b/docs/reference/BIOMOD_ConvertOldRun-deprecated.html
diff --git a/docs/reference/BIOMOD_CrossValidation-deprecated.html b/docs/reference/BIOMOD_CrossValidation-deprecated.html
diff --git a/docs/reference/BIOMOD_EnsembleForecasting.html b/docs/reference/BIOMOD_EnsembleForecasting.html
diff --git a/docs/reference/BIOMOD_EnsembleModeling.html b/docs/reference/BIOMOD_EnsembleModeling.html