Bypass colinearity reduction & nm_extract function

NAMESPACE

@@ -8,6 +8,7 @@ export(nm_eval)
 export(nm_gbif_suggestion)
 export(nm_find_hcv)
 export(nm_predict)
+export(nm_extract)
 ## Import
 importFrom("grDevices", "gray.colors", "rainbow")
 importFrom("graphics", "points")

R/nm_extract.R

@@ -0,0 +1,72 @@
+#' Extract raster data values based on point coordinates (longitude, latitude)
+#'
+#' @param data data.frame. Database with species presence, presence-absence,
+#' or pseudo-absence records with longitude and latitude coordinates.
+#' @param longitude character. Column name with spatial longitude coordinates.
+#' @param latitude character. Column name with spatial latitude coordinates.
+#' @param env_layer SpatRaster. Raster or raster stack.
+#' @param current_crs character. Current coordinate reference system of coordinates. One of:
+#' * `geographic`: Apllicable for longitude and latitude in decimal
+#' (e.g 31.796406, -24.536200)
+#' * `projected`: Applicable for longitude and latitude in projected
+#' system (e.g 7280635, 982148 - UTM zone 35S)
+#' @param variables character. Vector with the raster names to extract value from.
+#' If NULL (default) the function will return data for all raster.
+#' @param filter_na logical. If filter_na = TRUE (default), the rows with NA values
+#' for any of the raster are removed from the returned tibble.
+#'
+#' @return tibble with original data bound with extracted data
+#'
+#'
+#' @examples
+#'  library(terra)
+#'  wbv_path <- paste0(system.file("extdata", package = "nimo"), "/WbV_subset_occ_KNP.csv")
+#'  wbv_df <- read.csv(wbv_path)
+#'
+#'  env_layers_path <- paste0(system.file("extdata", package = "nimo"), "/env_layers")
+#'  env_layers <- terra::rast(list.files(env_layers_path, full.names = TRUE))
+#'
+#' extracted <- nm_extract(data = wbv_df, longitude = "decimalLongitude",
+#' latitude = "decimalLatitude", env_layer = env_layers)
+#'
+#' @export
+nm_extract <- function (data,
+                        longitude,
+                        latitude,
+                        env_layer,
+                        current_crs = "geographic",
+                        variables = NULL,
+                        filter_na = TRUE)
+{
+  if (is.null(variables)) {
+    variables <- names(env_layer)
+  }
+  data <- data %>%
+    dplyr::filter(!is.na(!!dplyr::sym(longitude))) %>%
+    dplyr::filter(!is.na(!!dplyr::sym(latitude)))
+
+  if (! current_crs %in% c("geographic", "projected")) {
+    stop("The current crs must be one of 'geographic' and 'projected'")
+  }
+  if(current_crs == "geographic"){
+    coord_rs <- 4326
+  }else{
+    coord_rs <- terra::crs(env_layer)
+  }
+  sp_data <- sf::st_as_sf(data, coords = c(longitude, latitude), crs = coord_rs) %>%
+    sf::st_transform(crs = terra::crs(env_layer))
+  extract_data <- dplyr::tibble(data,
+                                terra::extract(env_layer[[variables]], sp_data, cells = FALSE) %>%
+                                  dplyr::select({{variables}}))
+  if (filter_na) {
+    complete_vec <- stats::complete.cases(extract_data[,
+                                                       variables])
+    if (sum(!complete_vec) > 0) {
+      message(sum(!complete_vec), " rows were excluded from database because NAs were found")
+      extract_data <- extract_data %>% dplyr::filter(complete_vec)
+    }
+  }
+  return(extract_data)
+}
+
+

inst/nimo/server.R

@@ -437,39 +437,41 @@ occ_dt <- reactive({
 
   reduce_colin <- eventReactive(input$reduce_collin, {
     req(env_layers())
-    if(input$coli_method == "pearson"){
-      colin_var <- correct_colinvar(env_layer = env_layers(),
-                                    method = c("pearson", th = as.character(input$pearson_threshold)))
-      cr_df <- colin_var$cor_table # table
-      enlayer <- colin_var$cor_variables # layer
-      highly_corr_vars <- nm_find_hcv(cr_df, cutoff = input$pearson_threshold)
-      rm_enlayer <- highly_corr_vars
-    } else if(input$coli_method == "vif"){
-      colin_var <- correct_colinvar(env_layer = env_layers(), method = c("vif", th = as.character(input$vif_threshold)))
-      cr_df <- colin_var$vif_table # table
-      enlayer <- list()
-      for (i in 1:terra::nlyr(colin_var$env_layer)) {
-        l <- colin_var$env_layer[[i]]
-        enlayer[[i]] <- l
-      }
-      rm_enlayer <- colin_var$removed_variables
-    } else if(input$coli_method == "pca"){
-      colin_var <- correct_colinvar(env_layer = env_layers(), method = c("pca"))
-      cr_df <- colin_var$coefficients # table
-      enlayer <- list()
-      for (i in 1:terra::nlyr(colin_var$env_layer)) {
-        l <- colin_var$env_layer[[i]]
-        enlayer[[i]] <- l
-      }
-      rm_enlayer <- colin_var$cumulative_variance
-    } else if(input$coli_method == "fa" & terra::nlyr(env_layers()) > 2){
+    tryCatch({
+      if(input$coli_method == "pearson"){
+        colin_var <- correct_colinvar(env_layer = env_layers(),
+                                      method = c("pearson", th = as.character(input$pearson_threshold)))
+        cr_df <- colin_var$cor_table # table
+        enlayer <- colin_var$cor_variables # layer
+        highly_corr_vars <- nm_find_hcv(cr_df, cutoff = input$pearson_threshold)
+        rm_enlayer <- highly_corr_vars
+      } else if(input$coli_method == "vif"){
+        colin_var <- correct_colinvar(env_layer = env_layers(), method = c("vif", th = as.character(input$vif_threshold)))
+        cr_df <- colin_var$vif_table # table
+        enlayer <- list()
+        for (i in 1:terra::nlyr(colin_var$env_layer)) {
+          l <- colin_var$env_layer[[i]]
+          enlayer[[i]] <- l
+        }
+        rm_enlayer <- colin_var$removed_variables
+      } else if(input$coli_method == "pca"){
+        colin_var <- correct_colinvar(env_layer = env_layers(), method = c("pca"))
+        cr_df <- colin_var$coefficients # table
+        enlayer <- list()
+        for (i in 1:terra::nlyr(colin_var$env_layer)) {
+          l <- colin_var$env_layer[[i]]
+          enlayer[[i]] <- l
+        }
+        rm_enlayer <- colin_var$cumulative_variance
+      } else if(input$coli_method == "fa" & terra::nlyr(env_layers()) > 2){
         colin_var <- correct_colinvar(env_layer = env_layers(), method = c("fa"))
         cr_df <- colin_var$loadings # table
         enlayer <- colin_var$env_layer
         rm_enlayer <- colin_var$removed_variables
-    }
+      }
 
       return(list(cr_df, enlayer, rm_enlayer, colin_var))
+    }, error = error)
   })
 
   cr_env <- eventReactive(input$reduce_collin, {
@@ -955,33 +957,30 @@ observeEvent(input$valided_dp, {
   ## update predictor selection
 kept_colin_var <- reactiveValues(rc = NULL)
 
-rc <- reactive({
-  req(env_layers())
-  kept_colin_var$rc <- reduce_colin()[[3]]
-})
-
-
   observe({
     req(env_layers())
-    print(kept_colin_var$rc)
-    #print(kept_colin_var)
-    if (is.null(rc())) {
-      reduce_colin <- names(env_layers())
-    }else{
+    reduce_colin <- names(env_layers())
+    updateSelectInput(inputId = "extract_variables", choices = names(env_layers()),
+                      selected = reduce_colin)
+
+    tryCatch({kept_colin_var$rc <- reduce_colin()[[3]]}, error = function(e)print(e))
+    if (!is.null(isolate(kept_colin_var$rc))) {
       reduce_colin <- names(env_layers())[!names(env_layers()) %in% reduce_colin()[[3]]]
+      updateSelectInput(inputId = "extract_variables", choices = names(env_layers()),
+                        selected = reduce_colin)
     }
 
-    updateSelectInput(inputId = "extract_variables", choices = names(env_layers()),
-                      selected = reduce_colin)
+
   })
   ## process extraction
   extracted_df <- eventReactive(input$extract_data, {
     req(valided_dp())
-    sdm_extract(
+    nm_extract(
       data = valided_dp(),
-      x = ifelse(input$partition_type %in% c("part_sband", "part_sblock", "part_senv"), "x", input$long_var),
-      y = ifelse(input$partition_type %in% c("part_sband", "part_sblock", "part_senv"), "y", input$lat_var),
+      longitude = ifelse(input$partition_type %in% c("part_sband", "part_sblock", "part_senv"), "x", input$long_var),
+      latitude = ifelse(input$partition_type %in% c("part_sband", "part_sblock", "part_senv"), "y", input$lat_var),
       env_layer = env_layers(),
+      current_crs = input$occ_current_crs,
       variables = input$extract_variables,
       filter_na = TRUE
     )

inst/nimo/ui.R

@@ -268,7 +268,10 @@ nimo_body <- shinydashboard::dashboardBody(
                                                   selected = "Presence"),
                                       shinyFilesButton("choose_data_file", "Load data",
                                                        "Select Species occurrence data", multiple = FALSE,
-                                                       icon = icon("file-upload"))
+                                                       icon = icon("file-upload")),
+                                      selectInput("occ_current_crs", label = "Coordinates CRS",
+                                                  choices = c("Geographic" = "geographic", "Projected" = "projected"), multiple = FALSE,
+                                                  selected = c("Geographic" = "geographic"))
                                       ),
                      hr(),
                      conditionalPanel("output.geo_distribution != null",

tests/testthat/test-nm_extract.R

@@ -0,0 +1,22 @@
+test_that("test for nm_extract", {
+  require(terra)
+
+  wbv_path <- paste0(system.file("extdata", package = "nimo"), "/WbV_subset_occ_KNP.csv")
+  wbv_df <- read.csv(wbv_path)
+
+  env_layers_path <- paste0(system.file("extdata", package = "nimo"), "/env_layers")
+  env_layers <- terra::rast(list.files(env_layers_path, full.names = TRUE))
+
+  extracted <- nimo::nm_extract(data = wbv_df,
+                         longitude = "decimalLongitude",
+                         latitude = "decimalLatitude",
+                         env_layer = env_layers)
+
+  expect_true(all(class(extracted) %in% c("tbl_df", "tbl", "data.frame")))
+  expect_error(nm_extract(data = wbv_df,
+                          longitude = "decimalLongitude",
+                          latitude = "decimalLatitude",
+                          env_layer = env_layers,
+                          current_crs = "geo"))
+  rm(extracted, wbv_path, wbv_df, env_layers_path, env_layers)
+})