Merge pull request #478 from biomodhub/devel_current

V4.2-6

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: biomod2
 Type: Package
 Title: Ensemble Platform for Species Distribution Modeling
-Version: 4.2-5-2
-Date: 2024-05-31
+Version: 4.2-6
+Date: 2024-06-18
 Authors@R: c(person("Wilfried", "Thuiller", role = c("aut")
                     , email = "[email protected]"),
              person("Damien", "Georges", role = c("aut")),

NAMESPACE

@@ -80,6 +80,7 @@ exportClasses(MARS_biomod2_model)
 exportClasses(MAXENT_biomod2_model)
 exportClasses(MAXNET_biomod2_model)
 exportClasses(RF_biomod2_model)
+exportClasses(RFd_biomod2_model)
 exportClasses(SRE_biomod2_model)
 exportClasses(XGBOOST_biomod2_model)
 exportClasses(biomod2_ensemble_model)
@@ -203,6 +204,7 @@ importFrom(stats,rnorm)
 importFrom(stats,runif)
 importFrom(stats,sd)
 importFrom(terra,`add<-`)
+importFrom(terra,aggregate)
 importFrom(terra,app)
 importFrom(terra,as.matrix)
 importFrom(terra,as.points)

R/BIOMOD_FormatingData.R

@@ -81,6 +81,8 @@
 ##' If pseudo-absence selection and \code{PA.strategy = 'disk'}, a \code{numeric} defining the 
 ##' maximal distance to presence points used to make the \code{disk} pseudo-absence selection 
 ##' (in meters, see Details)
+##' @param PA.fact.aggr (\emph{optional, default} \code{NULL}) \cr
+##' If \code{strategy = 'random'} or \code{strategy = 'disk'}, a \code{integer} defining the factor of aggregation to reduce the resolution
 ##' @param PA.user.table (\emph{optional, default} \code{NULL}) \cr 
 ##' If pseudo-absence selection and \code{PA.strategy = 'user.defined'}, a \code{matrix} or 
 ##' \code{data.frame} with as many rows as \code{resp.var} values, as many columns as 
@@ -93,6 +95,8 @@
 ##' @param filter.raster (\emph{optional, default} \code{FALSE}) \cr 
 ##' If \code{expl.var} is of raster type, a \code{logical} value defining whether \code{resp.var} 
 ##' is to be filtered when several points occur in the same raster cell
+##' @param seed.val (\emph{optional, default} \code{NULL}) \cr 
+##' An \code{integer} value corresponding to the new seed value to be set
 ##' 
 ##' 
 ##' @return 
@@ -344,9 +348,11 @@ BIOMOD_FormatingData <- function(resp.name,
                                  PA.dist.min = 0,
                                  PA.dist.max = NULL,
                                  PA.sre.quant = 0.025,
+                                 PA.fact.aggr = NULL,
                                  PA.user.table = NULL,
                                  na.rm = TRUE,
-                                 filter.raster = FALSE)
+                                 filter.raster = FALSE,
+                                 seed.val = NULL)
 {
   .bm_cat(paste0(resp.name, " Data Formating"))
 
@@ -391,9 +397,11 @@ BIOMOD_FormatingData <- function(resp.name,
                                    PA.dist.min = PA.dist.min,
                                    PA.dist.max = PA.dist.max,
                                    PA.sre.quant = PA.sre.quant,
+                                   PA.fact.aggr = PA.fact.aggr,
                                    PA.user.table = PA.user.table,
                                    na.rm = na.rm,
-                                   filter.raster = filter.raster)
+                                   filter.raster = filter.raster,
+                                   seed.val)
   }
   .bm_cat("Done")
   return(out)

R/BIOMOD_Modeling.R

@@ -16,7 +16,7 @@
 ##' (\emph{a random number by default})
 ##' @param models a \code{vector} containing model names to be computed, must be among 
 ##' \code{ANN}, \code{CTA}, \code{FDA}, \code{GAM}, \code{GBM}, \code{GLM}, \code{MARS}, 
-##' \code{MAXENT}, \code{MAXNET}, \code{RF}, \code{SRE}, \code{XGBOOST}
+##' \code{MAXENT}, \code{MAXNET}, \code{RF}, \code{RFd}, \code{SRE}, \code{XGBOOST}
 ##' @param models.pa (\emph{optional, default} \code{NULL}) \cr 
 ##' A \code{list} containing for each model a \code{vector} defining which pseudo-absence datasets 
 ##' are to be used, must be among \code{colnames([email protected])}
@@ -139,6 +139,7 @@
 ##'     (\url{https://biodiversityinformatics.amnh.org/open_source/maxent/})
 ##'     \item \code{MAXNET} : Maximum Entropy (\code{\link[maxnet]{maxnet}})
 ##'     \item \code{RF} : Random Forest (\code{\link[randomForest]{randomForest}})
+##'     \item \code{RFd} : Random Forest downsampled (\code{\link[randomForest]{randomForest}})
 ##'     \item \code{SRE} : Surface Range Envelop or usually called BIOCLIM (\code{\link{bm_SRE}})
 ##'     \item \code{XGBOOST} : eXtreme Gradient Boosting Training (\code{\link[xgboost]{xgboost}})
 ##'   }}
@@ -622,7 +623,7 @@ BIOMOD_Modeling <- function(bm.format,
   models.switch.off <- NULL
 
   ## check if model is supported
-  avail.models.list <- c('ANN', 'CTA', 'FDA', 'GAM', 'GBM', 'GLM', 'MARS', 'MAXENT', 'MAXNET', 'RF', 'SRE', 'XGBOOST')
+  avail.models.list <- c('ANN', 'CTA', 'FDA', 'GAM', 'GBM', 'GLM', 'MARS', 'MAXENT', 'MAXNET', 'RF','RFd', 'SRE', 'XGBOOST')
   .fun_testIfIn(TRUE, "models", models, avail.models.list)
 
   ## Specific case of one variable with GBM / MAXNET

R/biomod2-package.R

@@ -10,7 +10,8 @@
   {
     RFver <- read.dcf(file = system.file("DESCRIPTION", package = pkgname), fields = "Version")
     mess <- paste(pkgname, RFver, "loaded.\n")
-    mess <- paste(mess, "/!\\ New set up for modeling options. We apologize for the trouble ^[*.*]^")
+    mess <- paste(mess, "/!\\ Be careful : note that some BigBoss options have been changed between biomod2 v4.2-6 and previous versions./!\\ 
+                  \n\n Please welcome a new model : RFd. This is a random forest model with a automatic down sampling to make your life easier.\n")
     packageStartupMessage(mess)
 
     toLoad <- unique(ModelsTable$package[-which(ModelsTable$package %in% c("MAXENT", "biomod2"))])

R/biomod2_classes_0.R

@@ -75,7 +75,7 @@ setGeneric("BIOMOD.options.default", def = function(mod, typ, pkg, fun) { standa
 .BIOMOD.options.default.check.args <- function(mod, typ, pkg, fun)
 {
   ## check if model is supported
-  avail.models.list <- c('ANN', 'CTA', 'FDA', 'GAM', 'GBM', 'GLM', 'MARS', 'MAXENT', 'MAXNET', 'RF', 'SRE', 'XGBOOST')
+  avail.models.list <- c('ANN', 'CTA', 'FDA', 'GAM', 'GBM', 'GLM', 'MARS', 'MAXENT', 'MAXNET', 'RF','RFd', 'SRE', 'XGBOOST')
   .fun_testIfIn(TRUE, "mod", mod, avail.models.list)
 
   ## check if type is supported
@@ -305,6 +305,16 @@ setGeneric("BIOMOD.options.dataset",
     }
   }
   if (strategy == "user.defined" && !is.null(user.val)) {
+
+    if ("for_all_datasets" %in% names(user.val)){
+      if (length(names(user.val)) > 1 ){
+        user.val <- user.val["for_all_datasets"]
+        cat("\n\t\t> Only the options defined for 'for_all_datasets' will be taken into account")
+      }
+      user.val <- rep(user.val, length(expected_CVnames))
+      names(user.val) <- expected_CVnames
+    }
+
     .fun_testIfIn(TRUE, "names(user.val)", names(user.val), expected_CVnames)
     if (length(names(user.val)) != length(expected_CVnames)) {
       warning(paste0("Options will be changed only for a subset of datasets ("
@@ -316,7 +326,8 @@ setGeneric("BIOMOD.options.dataset",
   }
 
   return(list(strategy = strategy,
-              expected_CVnames = expected_CVnames))
+              expected_CVnames = expected_CVnames,
+              user.val = user.val))
 }
 
 # .BIOMOD.options.dataset.test <- function(bm.opt)
@@ -445,6 +456,11 @@ setMethod('BIOMOD.options.dataset', signature(strategy = 'character'),
               argstmp$mtry = 1
               argstmp$type <- "classification"
             }
+            if (mod == "RFd") {
+              argstmp[["x"]] = NULL
+              argstmp$mtry = 1
+              argstmp$type <- "classification"
+            }
             if (mod == "XGBOOST") { argstmp$nrounds = 4 }
 
             argstmp[["..."]] = NULL

R/biomod2_classes_1.R

@@ -1321,6 +1321,8 @@ setMethod('summary', signature(object = 'BIOMOD.formated.data'),
 ##' If pseudo-absence selection and \code{PA.strategy = 'disk'}, a \code{numeric} defining the 
 ##' maximal distance to presence points used to make the \code{disk} pseudo-absence selection 
 ##' (in meters, see Details)
+##' @param PA.fact.aggr (\emph{optional, default} \code{NULL}) \cr
+##' If \code{strategy = 'random'} or \code{strategy = 'disk'}, a \code{integer} defining the factor of aggregation to reduce the resolution
 ##' @param PA.user.table (\emph{optional, default} \code{NULL}) \cr 
 ##' If pseudo-absence selection and \code{PA.strategy = 'user.defined'}, a \code{matrix} or 
 ##' \code{data.frame} with as many rows as \code{resp.var} values, as many columns as 
@@ -1333,6 +1335,8 @@ setMethod('summary', signature(object = 'BIOMOD.formated.data'),
 ##' @param filter.raster (\emph{optional, default} \code{FALSE}) \cr 
 ##' If \code{env} is of raster type, a \code{logical} value defining whether \code{sp} 
 ##' is to be filtered when several points occur in the same raster cell
+##' @param seed.val (\emph{optional, default} \code{NULL}) \cr 
+##' An \code{integer} value corresponding to the new seed value to be set
 ##' 
 ##' @slot dir.name a \code{character} corresponding to the modeling folder
 ##' @slot sp.name a \code{character} corresponding to the species name
@@ -1443,15 +1447,17 @@ setMethod('BIOMOD.formated.data.PA', signature(sp = 'numeric', env = 'data.frame
                    , eval.sp = NULL, eval.env = NULL, eval.xy = NULL
                    , PA.nb.rep = 1, PA.strategy = 'random', PA.nb.absences = NULL
                    , PA.dist.min = 0, PA.dist.max = NULL
-                   , PA.sre.quant = 0.025, PA.user.table = NULL
-                   , na.rm = TRUE, filter.raster = FALSE) {
+                   , PA.sre.quant = 0.025, PA.fact.aggr = NULL
+                   , PA.user.table = NULL
+                   , na.rm = TRUE, filter.raster = FALSE, seed.val = NULL) {
             .BIOMOD.formated.data.PA(sp, env, xy, dir.name, sp.name
                                      , eval.sp, eval.env, eval.xy
                                      , PA.nb.rep, PA.strategy, PA.nb.absences
                                      , PA.dist.min, PA.dist.max
-                                     , PA.sre.quant, PA.user.table
+                                     , PA.sre.quant, PA.fact.aggr, PA.user.table
                                      , na.rm
-                                     , filter.raster = filter.raster)
+                                     , filter.raster = filter.raster
+                                     , seed.val)
           })
 
 ### BIOMOD.formated.data.PA(sp = numeric, env = SpatRaster) -------------------
@@ -1465,24 +1471,27 @@ setMethod('BIOMOD.formated.data.PA', signature(sp = 'numeric', env = 'SpatRaster
                    , eval.sp = NULL, eval.env = NULL, eval.xy = NULL
                    , PA.nb.rep = 1, PA.strategy = 'random', PA.nb.absences = NULL
                    , PA.dist.min = 0, PA.dist.max = NULL
-                   , PA.sre.quant = 0.025, PA.user.table = NULL
-                   , na.rm = TRUE, filter.raster = FALSE) {
+                   , PA.sre.quant = 0.025, PA.fact.aggr = NULL
+                   , PA.user.table = NULL
+                   , na.rm = TRUE, filter.raster = FALSE, seed.val = NULL) {
             .BIOMOD.formated.data.PA(sp, env, xy, dir.name, sp.name
                                      , eval.sp, eval.env, eval.xy
                                      , PA.nb.rep, PA.strategy, PA.nb.absences
                                      , PA.dist.min, PA.dist.max
-                                     , PA.sre.quant, PA.user.table
+                                     , PA.sre.quant, PA.fact.aggr, PA.user.table
                                      , na.rm
-                                     , filter.raster = filter.raster)
+                                     , filter.raster = filter.raster
+                                     , seed.val)
           })
 
 ### .BIOMOD.formated.data.PA ---------------------------------------------------
 .BIOMOD.formated.data.PA <-  function(sp, env, xy, dir.name, sp.name
                                       , eval.sp = NULL, eval.env = NULL, eval.xy = NULL
                                       , PA.nb.rep = 1, PA.strategy = 'random', PA.nb.absences = NULL
                                       , PA.dist.min = 0, PA.dist.max = NULL
-                                      , PA.sre.quant = 0.025, PA.user.table = NULL
-                                      , na.rm = TRUE, filter.raster = FALSE)
+                                      , PA.sre.quant = 0.025, PA.fact.aggr = NULL
+                                      , PA.user.table = NULL
+                                      , na.rm = TRUE, filter.raster = FALSE, seed.val = NULL)
 {
   args <- .BIOMOD.formated.data.check.args(sp, env, xy, eval.sp, eval.env, eval.xy, filter.raster)
   for (argi in names(args)) { assign(x = argi, value = args[[argi]]) }
@@ -1529,7 +1538,10 @@ setMethod('BIOMOD.formated.data.PA', signature(sp = 'numeric', env = 'SpatRaster
                                    sre.quant = PA.sre.quant,
                                    dist.min = PA.dist.min,
                                    dist.max = PA.dist.max,
-                                   user.table = PA.user.table)
+                                   fact.aggr = PA.fact.aggr,
+                                   user.table = PA.user.table,
+                                   seed.val = seed.val)
+
 
   if (!is.null(pa.data.tmp)) {
     ## Keep same env variable for eval than calib (+ check for factor)
@@ -1581,15 +1593,15 @@ setMethod('BIOMOD.formated.data.PA', signature(sp = 'numeric', env = 'SpatRaster
 
     rm(list = 'BFD')
   } else {
-    cat("\n   ! PA selection not done", fill = .Options$width)
-    BFDP <- BIOMOD.formated.data(sp = as.vector(values(sp)[,1]),
-                                 env = env,
-                                 xy = xy,
-                                 dir.name = dir.name,
-                                 sp.name = sp.name, 
-                                 eval.sp = eval.sp,
-                                 eval.env = eval.env,
-                                 eval.xy = eval.xy)
+    stop("\n   ! PA selection not done : \n The PA selection is not possible with the parameters selected." )
+    # BFDP <- BIOMOD.formated.data(sp = as.vector(values(sp)[,1]),
+    #                              env = env,
+    #                              xy = xy,
+    #                              dir.name = dir.name,
+    #                              sp.name = sp.name, 
+    #                              eval.sp = eval.sp,
+    #                              eval.env = eval.env,
+    #                              eval.xy = eval.xy)
   }
   rm(list = "pa.data.tmp" )
   return(BFDP)

R/biomod2_classes_4.R

@@ -76,6 +76,7 @@ NULL
 ##' @aliases MAXENT_biomod2_model-class
 ##' @aliases MAXNET_biomod2_model-class
 ##' @aliases RF_biomod2_model-class
+##' @aliases RFd_biomod2_model-class
 ##' @aliases SRE_biomod2_model-class
 ##' @aliases XGBOOST_biomod2_model-class
 ##' @author Damien Georges
@@ -117,6 +118,7 @@ NULL
 ##'   \item \code{MAXNET_biomod2_model} : \code{model_class} is 
 ##'   \code{MAXNET}
 ##'   \item \code{RF_biomod2_model} : \code{model_class} is \code{RF}
+##'   \item \code{RFd_biomod2_model} : \code{model_class} is \code{RFd}
 ##'   \item \code{SRE_biomod2_model} : \code{model_class} is \code{SRE}
 ##' }
 ##' 
@@ -138,6 +140,7 @@ NULL
 ##' showClass("MAXENT_biomod2_model")
 ##' showClass("MAXNET_biomod2_model")
 ##' showClass("RF_biomod2_model")
+##' showClass("RFd_biomod2_model")
 ##' showClass("SRE_biomod2_model")
 ##' 
 NULL
@@ -275,6 +278,8 @@ setMethod('predict', signature(object = 'biomod2_model'),
 ##' @aliases predict2.MAXNET_biomod2_model.data.frame
 ##' @aliases predict2.RF_biomod2_model.SpatRaster
 ##' @aliases predict2.RF_biomod2_model.data.frame
+##' @aliases predict2.RFd_biomod2_model.SpatRaster
+##' @aliases predict2.RFd_biomod2_model.data.frame
 ##' @aliases predict2.SRE_biomod2_model.SpatRaster
 ##' @aliases predict2.SRE_biomod2_model.data.frame
 ##' @author Remi Patin
@@ -1112,6 +1117,81 @@ setMethod('predict2', signature(object = 'RF_biomod2_model', newdata = "data.fra
           }
 )
 
+#----------------------------------------------------------------------------- #
+## 8.10_bis RFd_biomod2_model -----------------------------------------------------
+#----------------------------------------------------------------------------- #
+##' @name RFd_biomod2_model-class
+##' @rdname biomod2_model
+##' @export
+
+setClass('RFd_biomod2_model',
+         representation(),
+         contains = 'biomod2_model',
+         prototype = list(model_class = 'RFd'),
+         validity = function(object) { # check model class
+           if (!inherits(object@model, "randomForest")) { return(FALSE)} else { return(TRUE) }
+         })
+
+##' 
+##' @rdname predict2.bm
+##' 
+
+
+setMethod('predict2', signature(object = 'RFd_biomod2_model', newdata = "SpatRaster"),
+          function(object, newdata, ...) {
+            pa <- .extract_modelNamesInfo(object@model_name, obj.type = "mod", info = "PA")
+            run <- .extract_modelNamesInfo(object@model_name, obj.type = "mod", info = "run")
+            dataset <- paste0("_", pa, "_", run)
+
+            if (!is.null(object@model_options@args.values[[dataset]]$type) && object@model_options@args.values[[dataset]]$type == "classification") {
+              predfun <- function(object, newdata, mod.name){
+                # new predict command used with terra
+                subset(predict(newdata, model = get_formal_model(object),
+                               type = 'prob',
+                               wopt = list(names = rep(mod.name,2))), 
+                       2)   
+                # old predict function used with raster
+                # predict(newdata, model = get_formal_model(object), type = 'prob', index = 2)
+              }
+            } else { #regression case
+              predfun <- function(object, newdata, mod.name){
+                predict(newdata, model = get_formal_model(object),
+                        type = 'response',
+                        wopt = list(names = rep(mod.name,2))) 
+              }
+            }
+
+            # old predict function used with raster
+            # predict(newdata, model = get_formal_model(object), type = 'prob', index = 2)            
+            # redirect to predict2.biomod2_model.SpatRaster
+
+            callNextMethod(object, newdata, predfun = predfun, ...)
+
+          }
+)
+
+##' @rdname predict2.bm
+setMethod('predict2', signature(object = 'RFd_biomod2_model', newdata = "data.frame"),
+          function(object, newdata, ...) {
+            pa <- .extract_modelNamesInfo(object@model_name, obj.type = "mod", info = "PA")
+            run <- .extract_modelNamesInfo(object@model_name, obj.type = "mod", info = "run")
+            dataset <- paste0("_", pa, "_", run)
+
+            if (!is.null(object@model_options@args.values[[dataset]]$type) && object@model_options@args.values[[dataset]]$type == "classification") {
+              predfun <- function(object, newdata, not_na_rows) {
+                as.numeric(predict(get_formal_model(object), as.data.frame(newdata[not_na_rows, , drop = FALSE]), type = 'prob')[, '1'])        
+              }
+            } else { # regression case
+              predfun <- function(object, newdata, not_na_rows) {
+                as.numeric(predict(get_formal_model(object), as.data.frame(newdata[not_na_rows, , drop = FALSE]), type = 'response'))        
+              }
+            }
+            # redirect to predict2.biomod2_model.data.frame
+            callNextMethod(object, newdata, predfun = predfun, ...)
+          }
+)
+
+
 
 #----------------------------------------------------------------------------- #
 ## 8.11 SRE_biomod2_model ----------------------------------------------------