Add hotspot_clip()

NAMESPACE

@@ -12,6 +12,7 @@ export(autoplot)
 export(hotspot_change)
 export(hotspot_classify)
 export(hotspot_classify_params)
+export(hotspot_clip)
 export(hotspot_count)
 export(hotspot_dual_kde)
 export(hotspot_gistar)

NEWS.md

@@ -1,6 +1,9 @@
 # sfhotspot 1.0.0
 
+* New function `hotspot_clip()` added to extract points from an SF object inside 
+  the boundary of a polygon (#57).
 * Functions now return useful error if provided with an empty dataset (#58).
+* Adjusted bandwidth now reported accurately (#56).
 
 
 # sfhotspot 0.9.2

R/hotspot_clip.R

@@ -0,0 +1,62 @@
+#' Extract points inside polygon
+#' 
+#' @param data \code{\link[sf]{sf}} data frame containing points.
+#' @param boundary \code{\link[sf]{sf}} data frame containing polygons.
+#' @param quiet if set to \code{TRUE}, messages reporting the values of any
+#'   parameters set automatically will be suppressed. The default is
+#'   \code{FALSE}.
+#' @param ... Further arguments passed to \code{\link[sf]{st_intersection}}.
+#' 
+#' @details
+#' 
+#' This function is a wrapper around \code{\link[sf]{st_intersection}} that
+#'   performs some additional checks and reports useful information.
+#' 
+#' @return an SF data frame containing those points that are covered by the
+#'   polygons.
+#' 
+#' @export 
+
+hotspot_clip <- function(data, boundary, quiet = FALSE, ...) {
+
+  # Check inputs that are not checked in a helper function
+  validate_inputs(
+    data = data, 
+    grid = boundary, 
+    name_grid = "boundary", 
+    quiet = quiet
+  )
+
+  # Count number of rows in data
+  initial_rows <- nrow(data)
+
+  # Get name of geometry column in boundary file
+  geometry_column <- attr(boundary, "sf_column")
+
+  # Convert boundary dataset to a single (multi)polygon and remove everything
+  # except the geometry
+  boundary_outline <- sf::st_union(boundary[, geometry_column])
+
+  # Clip data
+  clipped_data <- suppressWarnings(sf::st_intersection(data, boundary_outline))
+
+  # Report number of rows removed
+  if (rlang::is_false(quiet)) {
+
+    final_rows <- nrow(clipped_data)
+    rows_removed <- initial_rows - final_rows
+
+    cli::cli_inform(
+      paste0(
+        "Removed {format(rows_removed, big.mark = ',', scientific = FALSE)} ",
+        "rows ({sprintf('%0.1f%%', (rows_removed / initial_rows) * 100)} of ",
+        "original rows) from {.var data}"
+      )
+    )
+
+  }
+
+  # Return clipped data
+  clipped_data
+
+}

R/validate_inputs.R

@@ -17,15 +17,22 @@ validate_inputs <- function(
   grid = NULL,
   quiet = TRUE,
   name_data = "data",
+  name_grid = "grid",
   call = rlang::caller_env()
 ) {
 
   # Validate `data` and `grid`
-  validate_sf(data, label = "data", type = "POINT", quiet = quiet, call = call)
+  validate_sf(
+    data, 
+    label = name_data, 
+    type = "POINT", 
+    quiet = quiet, 
+    call = call
+  )
   if (!rlang::is_null(grid)) {
     validate_sf(
       grid,
-      label = "grid",
+      label = name_grid,
       type = c("POLYGON", "MULTIPOLYGON"),
       allow_null = TRUE,
       quiet = quiet,
@@ -42,15 +49,15 @@ validate_inputs <- function(
       cli::cli_abort(
         c(
           paste0(
-            "{.var {name_data}} and {.var grid} must use the same co-ordinate ",
-            "reference system (CRS)."
+            "{.var {name_data}} and {.var {name_grid}} must use the same ",
+            "co-ordinate reference system (CRS)."
           ),
           "i" = paste0(
             "{.var {name_data}} uses CRS {.q {format(sf::st_crs(data))}} ",
             "({sf::st_crs(data, parameters = TRUE)$srid})."
           ),
           "i" = paste0(
-            "{.var grid} uses CRS {.q {format(sf::st_crs(grid))}} ",
+            "{.var {name_grid}} uses CRS {.q {format(sf::st_crs(grid))}} ",
             "({sf::st_crs(grid, parameters = TRUE)$srid})."
           )
         ),
@@ -68,7 +75,7 @@ validate_inputs <- function(
     if (rlang::is_false(check_overlap[1, 1])) {
       cli::cli_abort(
         c(
-          "{.var {name_data}} and {.var grid} must overlap.",
+          "{.var {name_data}} and {.var {name_grid}} must overlap.",
           "i" = "Check co-ordinates are correct (e.g. by mapping them)."
         ),
         call = call

tests/testthat/test-hotspot_clip.R

@@ -0,0 +1,36 @@
+data_sf <- memphis_robberies_jan
+boundary_sf <- memphis_precincts[1, ]
+result <- hotspot_clip(data_sf, boundary_sf, quiet = TRUE)
+
+
+# CHECK INPUTS -----------------------------------------------------------------
+
+# Note that common inputs are tested in `validate_inputs()` and tested in the
+# corresponding test file
+
+
+
+# CHECK OUTPUTS ----------------------------------------------------------------
+
+
+## Correct outputs ----
+
+test_that("output is an SF tibble", {
+  expect_s3_class(result, "sf")
+  expect_s3_class(result, "tbl_df")
+})
+
+test_that("output object has same column names as input", {
+  expect_equal(names(data_sf), names(result))
+})
+
+test_that("output has correct number of rows", {
+  expect_equal(nrow(result), 21)
+})
+
+
+## Messages ----
+
+test_that("function produces message summarising rows removed", {
+  expect_message(hotspot_clip(data_sf, boundary_sf), "^Removed 185 rows")
+})