Merge pull request #351 from sjevelazco/fun_improv

Fun improv

R/extra_eval.R

@@ -13,7 +13,10 @@
 #'   \item mahalanobis: Degree of extrapolation is calculated based on Mahalanobis distance.
 #'   \item euclidean: Degree of extrapolation is calculated based on Euclidean distance.
 #'   }
-#'
+#' @param univar_comb logical. If true, the function will add a layer or column to distinguish
+#' between univariate (i.e., projection data outside the range of training conditions) and
+#' combinatorial extrapolation (i.e., projection data within the range of training conditions)
+#' using values 1 and 2, respectively. Default FALSE
 #' @param projection_data SpatRaster, data.frame or tibble with environmental condition used for projecting a model (e.g.,
 #' a larger, encompassing region, a spatially separate region, or a different time period).
 #' If data.frame or tibble is used function will return a tibble object.
@@ -27,7 +30,7 @@
 #'
 #'
 #' @return
-#' A SpatRaster object with extrapolation values measured in percentage of extrapolation (relative Euclidean distance)
+#' A SpatRaster object with extrapolation values measured by Shape extrapolation and
 #'
 #' @seealso \code{\link{extra_truncate}}, \code{\link{p_extra}}, \code{\link{p_pdp}}, \code{\link{p_bpdp}}
 #'
@@ -72,7 +75,7 @@
 #'   data = sp,
 #'   x = "x",
 #'   y = "y",
-#'   n = nrow(sp) * 2, # selecting number of pseudo-absence points twice number of presences
+#'   n = nrow(sp) * 2,
 #'   method = "random",
 #'   rlayer = somevar,
 #'   calibarea = ca
@@ -83,8 +86,11 @@
 #' sp_pa
 #'
 #' # Get environmental condition of calibration area
-#' sp_pa_2 <- sdm_extract(data = sp_pa, x = "x", y = "y", env_layer = somevar)
-#' sp_pa_2
+#' sp_pa_2 <- sdm_extract(data = sp_pa,
+#'                        x = "x",
+#'                        y = "y",
+#'                        env_layer = somevar)
+#'                        sp_pa_2
 #'
 #' # Measure degree of extrapolation based on Mahalanobis and
 #' # for a projection area based on a SpatRaster object
@@ -116,7 +122,9 @@
 #'   thr = c("max_sorensen")
 #' )
 #'
-#' predsuit <- sdm_predict(models = a_model, pred = somevar, thr = "max_sorensen")
+#' predsuit <- sdm_predict(models = a_model,
+#'                         pred = somevar,
+#'                         thr = "max_sorensen")
 #' predsuit # list with a raster with two layer
 #' plot(predsuit[[1]])
 #'
@@ -140,8 +148,11 @@
 #' plot(predsuit_2$`200`)
 #'
 #'
-#' # Measure degree of extrapolation for projection area
-#' # based on data.frame
+#' ##%######################################################%##
+#' ####        Measure degree of extrapolation for         ####
+#' ####        projection area based on data.frame         ####
+#' ##%######################################################%##
+#'
 #' extr_df <-
 #'   extra_eval(
 #'     training_data = sp_pa_2,
@@ -154,12 +165,32 @@
 #' extr_df
 #' # see 'p_extra()' to explore extrapolation or suitability pattern in the
 #' # environmental and/or geographical space
+#'
+#' ##%######################################################%##
+#' ####             Explore Shape metric with              ####
+#' ####     univariate and combinatorial extrapolation     ####
+#' ##%######################################################%##
+#' extr <-
+#'   extra_eval(
+#'     training_data = sp_pa_2,
+#'     projection_data = somevar,
+#'     pr_ab = "pr_ab",
+#'     n_cores = 1,
+#'     aggreg_factor = 1,
+#'     metric = "mahalanobis",
+#'     univar_comb = TRUE
+#'   )
+#'
+#' extr
+#' plot(extr) # In the second layer, values equal to 1 and 2
+#' # depict univariate and combinatorial extrapolation, respectively
 #' }
 extra_eval <-
   function(training_data,
            pr_ab,
            projection_data,
            metric = "mahalanobis",
+           univar_comb = FALSE,
            n_cores = 1,
            aggreg_factor = 1) {
     Value <- val <- . <- x <- NULL
@@ -386,9 +417,39 @@ extra_eval <-
         extraraster <- terra::mask(extraraster, disag)
       }
       names(extraraster) <- "extrapolation"
+
+      # Univariate and combinatorial extrapolation
+      if (univar_comb) {
+          rng <- apply(training_data, 2, range, na.rm = TRUE)
+          univar_ext <- projection_data
+          for (i in 1:terra::nlyr(projection_data)) {
+            univar_ext[[i]] <- (projection_data[v0[i]] <= rng[, v0[i]][1] |
+                                  projection_data[v0[i]] >= rng[, v0[i]][2])
+          }
+          univar_comb_r <- sum(univar_ext)
+          univar_comb_r[univar_comb_r > 0] <- 2
+          univar_comb_r[univar_comb_r == 0] <- 1
+          names(univar_comb_r) <- "uni_comb"
+          extraraster <- c(extraraster, univar_comb_r)
+      }
     } else {
       for (i in names(s_center)) {
-        env_proj2[i] <- env_proj2[i]*s_scale[i]+s_center[i]
+        env_proj2[i] <- env_proj2[i] * s_scale[i] + s_center[i]
+      }
+      # Univariate and combinatorial extrapolation
+      if (univar_comb) {
+        rng <- apply(training_data, 2, range, na.rm = TRUE)
+        univar_ext <- projection_data
+        for (i in 1:ncol(projection_data)) {
+          univar_ext[, v0[i]] <- (projection_data[,v0[i]] <= rng[, v0[i]][1] |
+                                projection_data[, v0[i]] >= rng[, v0[i]][2])
+        }
+        univar_comb_r <- apply(univar_ext, 1, sum)
+        univar_comb_r[univar_comb_r > 0] <- 2
+        univar_comb_r[univar_comb_r == 0] <- 1
+        env_proj2 <- env_proj2 %>%
+          dplyr::mutate(univar_comb_r) %>%
+          dplyr::relocate(extrapolation, univar_comb = univar_comb_r)
       }
       return(dplyr::as_tibble(env_proj2))
     }

R/extra_truncate.R

@@ -30,7 +30,7 @@ extra_truncate <- function(suit, extra, threshold = 50, trunc_value = 0) {
   for (i in 1:length(threshold)) {
     l[[i]] <- suit
     for (ii in 1:terra::nlyr(l[[i]])) {
-      l[[i]][[ii]][extra > threshold[i]] <- trunc_value
+      l[[i]][[ii]][extra[[1]] > threshold[i]] <- trunc_value
     }
   }
   names(l) <- threshold

R/p_extra.R

@@ -50,7 +50,8 @@
 #'   dplyr::select(x, y, pr_ab)
 #'
 #' # Calibration area based on some criterion such as dispersal ability
-#' ca <- calib_area(sp, x = "x", y = "y", method = c("buffer", width = 50000), crs = crs(somevar))
+#' ca <- calib_area(sp, x = "x", y = "y",
+#'                  method = c("buffer", width = 50000), crs = crs(somevar))
 #'
 #' plot(somevar[[1]])
 #' points(sp)
@@ -63,7 +64,7 @@
 #'   data = sp,
 #'   x = "x",
 #'   y = "y",
-#'   n = nrow(sp) * 2, # selecting number of pseudo-absence points twice number of presences
+#'   n = nrow(sp) * 2,
 #'   method = "random",
 #'   rlayer = somevar,
 #'   calibarea = ca
@@ -81,18 +82,19 @@
 #' # using SHAPE metric
 #' extr <-
 #'   extra_eval(
-#'     training_data = sp_pa_2, # change by training_data
-#'     projection_data = somevar, # change to projection_data
+#'     training_data = sp_pa_2,
+#'     pr_ab = "pr_ab",
+#'     projection_data = somevar,
+#'     metric = "mahalanobis",
+#'     univar_comb = FALSE,
 #'     n_cores = 1,
 #'     aggreg_factor = 1
 #'   )
 #' plot(extr)
 #'
 #' ## %######################################################%##
-#' #                                                          #
 #' ####            Explore extrapolation in the            ####
 #' ####        environmental and geographical space        ####
-#' #                                                          #
 #' ## %######################################################%##
 #'
 #' p_extra(
@@ -168,11 +170,39 @@
 #' )
 #'
 #'
+#' ##%######################################################%##
+#' ####                 Explore univariate                 ####
+#' ####          and combinatorial extrapolation           ####
+#' ##%######################################################%##
+#' extr <-
+#'   extra_eval(
+#'     training_data = sp_pa_2,
+#'     pr_ab = "pr_ab",
+#'     projection_data = somevar,
+#'     metric = "mahalanobis",
+#'     univar_comb = TRUE,
+#'     n_cores = 1,
+#'     aggreg_factor = 1
+#'   )
+#'
+#' plot(extr)
+#'
+#'
+#' p_extra(
+#'   training_data = sp_pa_2,
+#'   x = "x",
+#'   y = "y",
+#'   pr_ab = "pr_ab",
+#'   extra_suit_data = extr$uni_comb, # use  uni_comb layer
+#'   projection_data = somevar,
+#'   geo_space = TRUE,
+#'   prop_points = 0.05,
+#'   color_gradient = c("#B3DC2B","#25818E")
+#' )
+#'
 #' ## %######################################################%##
-#' #                                                          #
 #' ####           With p_extra also is possible            ####
 #' ####       to explore the patterns of suitability       ####
-#' #                                                          #
 #' ## %######################################################%##
 #'
 #' sp_pa_2 <- part_random(
@@ -226,7 +256,7 @@
 #'   x = "x",
 #'   y = "y",
 #'   pr_ab = "pr_ab",
-#'   extra_suit_data = extr,
+#'   extra_suit_data = suit,
 #'   projection_data = somevar,
 #'   geo_space = FALSE,
 #'   prop_points = 0.05,