Merge pull request #21 from Spatiotemporal-Exposures-and-Toxicology/d…

…ev03

0.0.4

.Rbuildignore

@@ -1,4 +1,4 @@
 rds$
-/tools
+/tools/*
 /.github
 scomps*.html$

.gitignore

@@ -1,2 +1,3 @@
 .DS_Store
-largedata/
+largedata/
+/tests/testdata

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: scomps
 Title: Scalable R geospatial computation
-Version: 0.0.3.10072023
+Version: 0.0.4.11012023
 Authors@R: 
     person("Insang", "Song", , "geoissong@gmail.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-8732-3256"))
@@ -16,6 +16,7 @@ Imports:
     future,
     future.apply,
     methods,
+    progressr,
     rlang,
     sf,
     stars,

NAMESPACE

@@ -11,6 +11,7 @@ export(clip_as_extent)
 export(clip_as_extent_ras)
 export(clip_as_extent_ras2)
 export(distribute_process)
+export(distribute_process_hierarchy)
 export(estimate_demands)
 export(extent_to_polygon)
 export(extract_with)
@@ -25,3 +26,8 @@ export(sp_index_grid)
 export(sp_indexing)
 export(switch_packbound)
 export(validate_and_repair_vectors)
+import(future)
+import(progressr)
+importFrom(dplyr,across)
+importFrom(methods,is)
+importFrom(rlang,sym)

R/check.R

@@ -138,9 +138,9 @@ check_bbox <- function(
 #' Check Coordinate Reference System
 #' @param x sf/stars/SpatVector/SpatRaster object.
 #' @return A st_crs or crs object.
-#' @description 
+#' @description It returns st_crs object from sf/Spat* objects.
 #' @author Insang Song \email{geoissong@@gmail.com}
-#' @examples 
+#' @examples
 #' # data
 #' library(sf)
 #' ncpath = system.file("shape/nc.shp", package = "sf")
@@ -168,10 +168,11 @@ check_crs <- function(x) {
 #' @param reference sf/stars/SpatVector/SpatRaster object.
 #' @return logical
 #' @author Insang Song \email{geoissong@@gmail.com}
+#' @importFrom methods is
 #' @export 
 check_within_reference <- function(input_object, reference) {
-    stopifnot("Input is invalid.\n" = (methods::is(input_object, "sf") || methods::is(input_object, "stars") || methods::is(input_object, "SpatVector") || methods::is(input_object, "SpatRaster")))
-    stopifnot("Reference is invalid.\n" = (methods::is(input_object, "sf") || methods::is(input_object, "stars") || methods::is(input_object, "SpatVector") || methods::is(input_object, "SpatRaster")))
+  stopifnot("Input is invalid.\n" = (methods::is(input_object, "sf") || methods::is(input_object, "stars") || methods::is(input_object, "SpatVector") || methods::is(input_object, "SpatRaster")))
+  stopifnot("Reference is invalid.\n" = (methods::is(input_object, "sf") || methods::is(input_object, "stars") || methods::is(input_object, "SpatVector") || methods::is(input_object, "SpatRaster")))
 
   bbox_input <- input_object |>
     sf::st_bbox() |>

R/interpret_computational_domain.R

@@ -26,26 +26,25 @@
 get_computational_regions <- function(
   input,
   mode = c("grid", "grid_advanced", "density"),
-  nx = 10,
-  ny = 10,
-  grid_min_features = 30,
+  nx = 10L,
+  ny = 10L,
+  grid_min_features = 30L,
   padding = NULL,
   unit = NULL,
   ...) {
-  # type check
-  package_detected <- check_packbound(input)
   # stopifnot("Invalid input.\n" = !any(grepl("^(sf|Spat)", class(input))))
-  match.arg(mode)
-  # stopifnot("Argument mode should be one of 'grid', 'grid_advanced', or 'density'.\n" = !mode %in% c("grid", "grid_advanced", "density"))
-  stopifnot("Ensure that nx, ny, and grid_min_features are all integer.\n" = all(is.integer(nx), is.integer(y), is.integer(grid_min_features)))
-  stopifnot("padding should be numeric. We convert padding to numeric...\n" = !is.numeric(padding))
+
+  stopifnot("Argument mode should be one of 'grid', 'grid_advanced', or 'density'.\n" = mode %in% c("grid", "grid_advanced", "density"))
+  stopifnot("Ensure that nx, ny, and grid_min_features are all integer.\n" = all(is.integer(nx), is.integer(ny), is.integer(grid_min_features)))
+  stopifnot("padding should be numeric. We convert padding to numeric...\n" = is.numeric(padding))
   # valid unit compatible with units::set_units?
+  switch(mode,
+    grid = sp_index_grid(points_in = input, ncutsx = nx, ncutsy = ny),
+    grid_advanced = grid_merge(points_in = input, sp_index_grid(input, nx, ny),
+      grid_min_features = grid_min_features),
+    density = simpleError("density method is under development.\n")
+  )
 
-    # if (detected_pnts == "sf") {
-    # }
-    # if (detected_pnts == "terra") {
-    #   grid1$ID = seq(1, nrow(grid1))
-    # }
   }
 
 #' @title sp_index_grid: Generate grid polygons
@@ -183,43 +182,3 @@ grid_merge <- function(points_in, grid_in, grid_min_features) {
 
 
 
-
-#' @title Process a given function in the entire or partial computational grids (under construction)
-#' 
-#' @description Should 
-#' @param grids sf/SpatVector object. Computational grids.
-#' @param grid_id character(1) or numeric(2). Default is NULL. If NULL, all grid_ids are used. \code{"id_from:id_to"} format or \code{c(unique(grid_id)[id_from], unique(grid_id)[id_to])}
-#' @param fun function supported in scomps. 
-#' @param ... Arguments passed to fun.
-#' @return a data.frame object with mean value
-#' @author Insang Song \email{geoissong@@gmail.com}
-#' 
-#' @export
-distribute_process <- function(
-  grids, 
-  grid_id = NULL,
-  fun,
-  ...) {
-  # subset using grids and grid_id
-  if (!is.null(grid_id)) {
-    if (is.character(grid_id)) {
-      grid_id_parsed <- strsplit(grid_id, ":", fixed = TRUE)[[1]]
-      grid_ids <- c(which(unique(grids[["CGRIDID"]]) == grid_id_parsed[1]),
-                      which(unique(grids[["CGRIDID"]]) == grid_id_parsed[2]))
-    }
-    if (is.numeric(grid_id)) {
-      grid_ids <- unique(grids[["CGRIDID"]])[grid_id]
-    }
-  }
-  grids_target <- grids[grid_ids,]
-  grids_target_list <- split(grids_target, grids_target[["CGRIDID"]])
-
-  results_distributed <- future.apply::future_lapply(
-    \(x, ...) {
-      fun(...)
-    }, grids_target_list,
-    future.seed = TRUE)
-  results_distributed <- do.call(rbind, results_distributed)
-  return(results_distributed)
-}
-

R/processing.R

@@ -96,7 +96,8 @@ clip_as_extent_ras2 <- function(
 #' @param na.rm logical(1). NA values are omitted when summary is calculated.
 #' @return a data.frame object with function value
 #' @author Insang Song \email{geoissong@@gmail.com}
-#' 
+#' @importFrom rlang sym
+#' @importFrom dplyr across
 #' @export
 extract_with_polygons <- function(
     polys,
@@ -160,15 +161,15 @@ extract_with_polygons <- function(
 #' @param func function taking one numeric vector argument.
 #' @param mode one of "polygon" (generic polygons to extract raster values with) or "buffer" (point with buffer radius)
 #' @param ... various. Passed to extract_with_buffer. See \code{?extract_with_buffer} for details.
-#' @return 
+#' @return A data.frame object with summarized raster values with respect to the mode (polygon or buffer) and the function.
 #' @author Insang Song \email{geoissong@@gmail.com}
 #' @export
 extract_with <- function(
   raster, 
   vector, 
   id, 
   func = mean, 
-  mode = c("polygon", "buffer"), 
+  mode = c("polygon", "buffer"),
   ...) {
 
   match.arg(mode)
@@ -180,7 +181,7 @@ extract_with <- function(
 
   extracted <- 
     switch(mode,
-      polygon = extract_with_polygons(vector, raster, id, func),
+      polygon = extract_with_polygons(vector, raster, id, func, ...),
       buffer = extract_with_buffer(vector, raster, id = id, func = func, ...))
   return(extracted)
 }
@@ -289,7 +290,7 @@ aw_covariates <- function(
       poly_intersected[["area_segment_"]] <- terra::expanse(poly_intersected)
       poly_intersected <- data.frame(poly_intersected) |>
         dplyr::group_by(!!rlang::sym(id_poly_in)) |>
-        dplyr::summarize(dplyr::across(is.numeric,
+        dplyr::summarize(dplyr::across(dplyr::where(is.numeric),
           ~stats::weighted.mean(., w = area_segment_))) |>
         dplyr::ungroup()
       return(poly_intersected)
@@ -299,12 +300,12 @@ aw_covariates <- function(
   class_poly_weight <- check_packbound(poly_weight)
 
   if (class_poly_in != class_poly_weight) {
-    class_poly_weight <- switch_packbound(class_poly_weight)
+    poly_weight <- switch_packbound(poly_weight)
   }
 
   switch(class_poly_in,
-    sf = sf::st_interpolate_aw(poly_weight[, index_numeric],
-      poly_in, extensive = FALSE),
+    sf = suppressWarnings(sf::st_interpolate_aw(poly_weight[, index_numeric],
+      poly_in, extensive = FALSE)),
     terra = aw_covariates_terra(poly_in, poly_weight[, index_numeric],
       id_poly_in = id_poly_in))
 
@@ -333,6 +334,7 @@ aw_covariates <- function(
 #' @param func a function taking a numeric vector argument.
 #' @param kernel character(1). Name of a kernel function (yet to be implemented)
 #' @param bandwidth numeric(1). Kernel bandwidth.
+#' @param grid_ref SpatVector object. A unit grid polygon that is used to get a subset inside the polygon
 #' @return a data.frame object with mean value
 #' @author Insang Song \email{geoissong@@gmail.com}
 #' 
@@ -342,35 +344,40 @@ extract_with_buffer <- function(
     surf,
     radius,
     id,
-    qsegs = 90,
+    qsegs = 90L,
     func = mean,
     kernel = NULL,
-    bandwidth = NULL
+    bandwidth = NULL,
+    grid_ref = NULL
     ) {
   # type check
   stopifnot("Check class of the input points.\n" = methods::is(points, "SpatVector"))
   stopifnot("Check class of the input radius.\n" = is.numeric(radius))
   stopifnot(is.character(id))
-  stopifnot(is.integer(qsegs))
+  stopifnot(is.numeric(qsegs))
+
+  if (!is.null(grid_ref)) {
+    points <- points[grid_ref, ]
+  }
 
   if (!is.null(kernel)) {
-    extracted <- extract_with_buffer_flat(points = points,
-                                  surf = surf,
-                                  radius = radius,
-                                  id = id,
-                                  func = func,
-                                  qsegs = qsegs)
+    extracted <- extract_with_buffer_kernel(points = points,
+                                    surf = surf,
+                                    radius = radius,
+                                    id = id,
+                                    func = func,
+                                    qsegs = qsegs,
+                                    kernel = kernel,
+                                    bandwidth = bandwidth)
     return(extracted)
   }
 
-  extracted <- extract_with_buffer_kernel(points = points,
-                                  surf = surf,
-                                  radius = radius,
-                                  id = id,
-                                  func = func,
-                                  qsegs = qsegs,
-                                  kernel = kernel,
-                                  bandwidth = bandwidth)
+  extracted <- extract_with_buffer_flat(points = points,
+                                surf = surf,
+                                radius = radius,
+                                id = id,
+                                func = func,
+                                qsegs = qsegs)
   return(extracted)
 
 }
@@ -397,7 +404,7 @@ extract_with_buffer_flat <- function(
   surf_at_bufs_summary <-
     surf_at_bufs |>
       dplyr::group_by(ID) |>
-      dplyr::summarize(dplyr::across(dplyr::all_of(name_surf_val), ~mean, na.rm = TRUE)) |> 
+      dplyr::summarize(dplyr::across(dplyr::all_of(name_surf_val), ~mean(., na.rm = TRUE))) |> 
       dplyr::ungroup()
   return(surf_at_bufs_summary)
 }