extract_at update

- addressing #105
- TODO: field name filtering in .kernel_weighting() needs to be generalized to avoid potential duplicated name errors

NEWS.md

@@ -1,5 +1,6 @@
 # 0.9
 - `mirai` based `par_*` functions for parallelization
+- terra::extract mode in `extract_at()` with `terra` argument and auxiliary arguments including exact, weights, touches
 
 # 0.8
 - Bumped version from 0.7.8 to 0.8.0: improving package coverage

R/processing.R

@@ -52,6 +52,7 @@ kernelfunction <-
   y_vec,
   id,
   extracted,
+  terra = FALSE,
   kernel_func = stats::weighted.mean,
   kernel = NULL,
   bandwidth = NULL,
@@ -70,9 +71,17 @@ kernelfunction <-
     )
     y_vec <- terra::centroids(y_vec, inside = TRUE)
   }
-  name_surf_val <-
-    ifelse(terra::nlyr(x_ras) == 1,
-           "value", names(x_ras))
+  if (!terra) {
+    name_surf_val <-
+      ifelse(terra::nlyr(x_ras) == 1,
+             "value", names(x_ras))
+  } else {
+    # TODO: "ID", "x", "y" are too generic to exclude;
+    #  need to find a generalized way of excluding names
+    exclude_vec <- c("id_chopin", "coverage_fraction", "ID", "x", "y")
+    exclude_vec <- append(exclude_vec, names(y_vec))
+    name_surf_val <- setdiff(names(extracted), exclude_vec)
+  }
   # convert to data.frame
   coords_df <- as.data.frame(y_vec, geom = "XY")
   # apply strict order
@@ -90,7 +99,9 @@ kernelfunction <-
   coverage_fraction <- NULL
 
   # post-processing
-  extracted <- do.call(rbind, extracted)
+  if (!is.data.frame(extracted)) {
+    extracted <- do.call(rbind, extracted)
+  }
   names(extracted)[grep("(x|y)", names(extracted))] <- c("xdest", "ydest")
   extracted_summary <-
     extracted |>
@@ -127,8 +138,10 @@ kernelfunction <-
 #' @param id character(1). Name of unique identifier field.
 #' @param func character(1)/function. supported function names or functions
 #'   taking `x` and `w` in `exactextractr::exact_extract`
+#' @param terra logical(1). If `TRUE`, use `terra::extract` instead of
+#'   `exactextractr::exact_extract`.
 #' @param extent numeric. Passed to .check_vector
-#' @param radius numeric(1).
+#' @param radius numeric(1). Buffer radius.
 #' @param out_class character(1). "sf" or "terra"
 #' @param kernel character(1). Name of kernel functions [kernelfunction]
 #' @param kernel_func function. Kernel weight summary function.
@@ -139,20 +152,27 @@ kernelfunction <-
 #' @param .standalone logical(1). Whether or not running standalone mode.
 #'   `TRUE` will apply internal input check functions, whereas
 #'   `FALSE` will let `par_*` functions will check inputs.
+#' @param weights passed to `terra::extract()` Default is TRUE.
+#' @param exact passed to `terra::extract()` Default is TRUE.
+#' @param touches passed to `terra::extract()` Default is FALSE.
 #' @keywords internal
 #' @noRd
 .extract_at <- function(
   x = NULL,
   y = NULL,
   id = NULL,
   func = "mean",
+  terra = FALSE,
   extent = NULL,
   radius = NULL,
   out_class = "sf",
   kernel = NULL,
   kernel_func = stats::weighted.mean,
   bandwidth = NULL,
   max_cells = NULL,
+  exact = TRUE,
+  weights = TRUE,
+  touches = FALSE,
   .standalone = TRUE,
   ...
 ) {
@@ -172,7 +192,7 @@ kernelfunction <-
       )
     # reproject polygons to raster's crs
     y <- reproject_to_raster(vector = y, raster = x)
-    if (dep_check(y) == "terra") {
+    if (dep_check(y) == "terra" && !terra) {
       y <- dep_switch(y)
     }
   }
@@ -188,20 +208,37 @@ kernelfunction <-
   }
   iskernel <- !is.null(kernel)
 
-  extracted <-
-    exactextractr::exact_extract(
-      x = x,
-      y = y,
-      fun = if (iskernel) NULL else func,
-      force_df = TRUE,
-      stack_apply = !iskernel,
-      append_cols = if (iskernel) NULL else id,
-      include_cols = if (iskernel) id else NULL,
-      progress = FALSE,
-      include_area = iskernel,
-      include_xy = iskernel,
-      max_cells_in_memory = max_cells
-    )
+  if (!terra) {
+    extracted <-
+      exactextractr::exact_extract(
+        x = x,
+        y = y,
+        fun = if (iskernel) NULL else func,
+        force_df = TRUE,
+        stack_apply = !iskernel,
+        append_cols = if (iskernel) NULL else id,
+        include_cols = if (iskernel) id else NULL,
+        progress = FALSE,
+        include_area = iskernel,
+        include_xy = iskernel,
+        max_cells_in_memory = max_cells
+      )
+  } else {
+    extracted <-
+      terra::extract(
+        x = x, y = y,
+        fun = if (iskernel) NULL else func,
+        xy = TRUE,
+        weights = weights,
+        exact = exact,
+        touches = touches,
+        bind = TRUE,
+        ID = TRUE
+      )
+    extracted$id_chopin <- y[[id]][extracted$ID]
+    names(extracted)[names(extracted) == "id_chopin"] <- id
+    names(extracted)[names(extracted) == "weight"] <- "coverage_fraction"
+  }
 
   if (iskernel) {
     stopifnot(!is.null(bandwidth))
@@ -215,6 +252,7 @@ kernelfunction <-
         y_vec = y,
         id = id,
         extracted = extracted,
+        terra = terra,
         kernel = kernel,
         kernel_func = kernel_func,
         bandwidth = bandwidth
@@ -243,6 +281,8 @@ kernelfunction <-
 #' @param func function taking one numeric vector argument.
 #'   Default is `"mean"` for all supported signatures in arguments
 #'  `x` and `y`.
+#' @param terra logical(1). If `TRUE`, use `terra::extract` instead of
+#'   `exactextractr::exact_extract`.
 #' @param extent numeric(4) or SpatExtent. Extent of clipping vector.
 #'  It only works with `points` of character(1) file path.
 #' @param radius numeric(1). Buffer radius.
@@ -258,6 +298,9 @@ kernelfunction <-
 #'   the function will be executed in a standalone mode.
 #'   When using this function in `par_*` functions,
 #'   set this to `FALSE`.
+#' @param weights passed to `terra::extract()` Default is TRUE.
+#' @param exact passed to `terra::extract()` Default is TRUE.
+#' @param touches passed to `terra::extract()` Default is FALSE.
 #' @param ... Placeholder.
 #' @returns A data.frame object with summarized raster values with
 #'  respect to the mode (polygon or buffer) and the function.
@@ -305,18 +348,23 @@ setMethod(
     y = NULL,
     id = NULL,
     func = "mean",
+    terra = FALSE,
     extent = NULL,
     radius = NULL,
     out_class = "sf",
     kernel = NULL,
     kernel_func = stats::weighted.mean,
     bandwidth = NULL,
     max_cells = 3e+07,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     .standalone = TRUE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
@@ -343,25 +391,33 @@ setMethod(
     y = NULL,
     id = NULL,
     func = "mean",
+    terra = FALSE,
     extent = NULL,
     radius = NULL,
     out_class = "sf",
     kernel = NULL,
     kernel_func = stats::weighted.mean,
     bandwidth = NULL,
     max_cells = 3e+07,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     .standalone = TRUE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
       kernel = kernel,
       kernel_func = kernel_func,
       bandwidth = bandwidth,
       max_cells = max_cells,
+      exact = exact,
+      weights = weights,
+      touches = touches,
       .standalone = .standalone
     )
   }
@@ -389,17 +445,24 @@ setMethod(
     bandwidth = NULL,
     max_cells = 3e+07,
     .standalone = TRUE,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
       kernel = kernel,
       kernel_func = kernel_func,
       bandwidth = bandwidth,
       max_cells = max_cells,
+      exact = exact,
+      weights = weights,
+      touches = touches,
       .standalone = .standalone
     )
   }
@@ -418,25 +481,33 @@ setMethod(
     y = NULL,
     id = NULL,
     func = "mean",
+    terra = FALSE,
     extent = NULL,
     radius = NULL,
     out_class = "sf",
     kernel = NULL,
     kernel_func = stats::weighted.mean,
     bandwidth = NULL,
     max_cells = 3e+07,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     .standalone = TRUE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
       kernel = kernel,
       kernel_func = kernel_func,
       bandwidth = bandwidth,
       max_cells = max_cells,
+      exact = exact,
+      weights = weights,
+      touches = touches,
       .standalone = .standalone
     )
   }
@@ -456,25 +527,33 @@ setMethod(
     y = NULL,
     id = NULL,
     func = "mean",
+    terra = FALSE,
     extent = NULL,
     radius = NULL,
     out_class = "sf",
     kernel = NULL,
     kernel_func = stats::weighted.mean,
     bandwidth = NULL,
     max_cells = 3e+07,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     .standalone = TRUE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
       kernel = kernel,
       kernel_func = kernel_func,
       bandwidth = bandwidth,
       max_cells = max_cells,
+      exact = exact,
+      weights = weights,
+      touches = touches,
       .standalone = .standalone
     )
   }
@@ -495,25 +574,33 @@ setMethod(
     y = NULL,
     id = NULL,
     func = "mean",
+    terra = FALSE,
     extent = NULL,
     radius = NULL,
     out_class = "sf",
     kernel = NULL,
     kernel_func = stats::weighted.mean,
     bandwidth = NULL,
     max_cells = 3e+07,
+    exact = TRUE,
+    weights = TRUE,
+    touches = FALSE,
     .standalone = TRUE,
     ...
   ) {
     .extract_at(
       x = x, y = y, id = id, func = func,
+      terra = terra,
       extent = extent,
       radius = radius,
       out_class = out_class,
       kernel = kernel,
       kernel_func = kernel_func,
       bandwidth = bandwidth,
       max_cells = max_cells,
+      exact = exact,
+      weights = weights,
+      touches = touches,
       .standalone = .standalone
     )
   }

codemeta.json

@@ -14,7 +14,7 @@
     "name": "R",
     "url": "https://r-project.org"
   },
-  "runtimePlatform": "R version 4.4.1 (2024-06-14)",
+  "runtimePlatform": "R version 4.4.2 (2024-10-31)",
   "author": [
     {
       "@type": "Person",
@@ -370,7 +370,7 @@
     },
     "SystemRequirements": "netcdf"
   },
-  "fileSize": "27933.471KB",
+  "fileSize": "27935.52KB",
   "releaseNotes": "https://github.com/ropensci/chopin/blob/master/NEWS.md",
   "readme": "https://github.com/ropensci/chopin/blob/main/README.md",
   "contIntegration": ["https://github.com/ropensci/chopin/actions", "https://github.com/ropensci/chopin/actions/workflows/check-standard.yaml"],