Merge pull request #559 from ropensci/558-re-add-n_segments-argument-…

…to-line_segment 558 re add n segments argument to line segment
ropensci · Apr 26, 2024 · 4eeea3e · 4eeea3e
2 parents 2b68bb6 + ce874b4
commit 4eeea3e
Show file tree

Hide file tree

Showing 11 changed files with 236 additions and 31 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -5,6 +5,7 @@
 - `line_segment()` becomes an S3 generic which now has methods for `sf` and `sfc` class objects
 - `line_segment()` now works around [{rsgeo} issue](https://github.com/JosiahParry/rsgeo/issues/42) with `line_segmentize()` returning fewer segments than requested (#552)
 - Removal of offending URLs with `urlchecker::check_urls()` 
+- Improvement of documentation of `line_midpoint()`: comparison of output with `sf::st_point_on_surface()` 
 
 # stplanr 1.1.2  (2023-09)
 

diff --git a/R/linefuns.R b/R/linefuns.R
@@ -140,6 +140,9 @@ angle_diff <- function(l, angle, bidirectional = FALSE, absolute = TRUE) {
 #' plot(l$geometry, col = 2:5)
 #' midpoints <- line_midpoint(l)
 #' plot(midpoints, add = TRUE)
+#' # compare with sf::st_point_on_surface:
+#' midpoints2 <- sf::st_point_on_surface(l)
+#' plot(midpoints2, add = TRUE, col = "red")
 line_midpoint <- function(l, tolerance = NULL) {
   if (is.null(tolerance)) {
     sub <- lwgeom::st_linesubstring(x = l, from = 0, to = 0.5)
@@ -158,7 +161,9 @@ line_midpoint <- function(l, tolerance = NULL) {
 #' but does not always return the number of segments requested.
 #'
 #' @inheritParams line2df
-#' @param segment_length The approximate length of segments in the output (overides n_segments if set)
+#' @param segment_length The approximate length of segments in the output (overrides n_segments if set)
+#' @param n_segments The number of segments to divide the line into.
+#'   If there are multiple lines, this should be a vector of the same length.
 #' @param use_rsgeo Should the `rsgeo` package be used?
 #'  If `rsgeo` is available, this faster implementation is used by default.
 #'  If `rsgeo` is not available, the `lwgeom` package is used.
@@ -174,49 +179,72 @@ line_midpoint <- function(l, tolerance = NULL) {
 #' plot(l_seg_multi["ID"])
 #' plot(l_seg_multi$geometry, col = seq_along(l_seg_multi), lwd = 5)
 #' round(st_length(l_seg_multi))
-#' # rsgeo implementation:
-#' rsmulti = line_segment(l, segment_length = 1000, use_rsgeo = TRUE)
-#' plot(rsmulti["ID"])
-#' plot(rsmulti$geometry, col = seq_along(l_seg_multi), lwd = 5)
-#' # round(st_length(rsmulti))
-#' # waldo::compare(l_seg_multi, rsmulti)
+#' # rsgeo implementation (default if available):
+#' if (rlang::is_installed("rsgeo")) {
+#'   rsmulti = line_segment(l, segment_length = 1000, use_rsgeo = TRUE)
+#'   plot(rsmulti["ID"])
+#' }
+#' # Check they have the same total length, to nearest mm:
+#' # round(sum(st_length(l_seg_multi)), 3) == round(sum(st_length(rsmulti)), 3)
+#' # With n_segments for 1 line:
+#' l_seg_multi_n <- line_segment(l[1, ], n_segments = 3, use_rsgeo = FALSE)
+#' l_seg_multi_n <- line_segment(l$geometry[1], n_segments = 3, use_rsgeo = FALSE)
+#' l_seg_multi_n <- line_segment(l$geometry[1], n_segments = 3, use_rsgeo = TRUE)
+#' # With n_segments for all 3 lines:
+#' l_seg_multi_n <- line_segment(l, n_segments = 2)
+#' nrow(l_seg_multi_n) == nrow(l) * 2
 line_segment <- function(
     l,
     segment_length = NA,
+    n_segments = NA,
     use_rsgeo = NULL,
     debug_mode = FALSE) {
+  # Defensive programming:
+  if (is.na(segment_length) && is.na(n_segments)) {
+    rlang::abort(
+      "segment_length or n_segments must be set.",
+      call = rlang::caller_env()
+    )
+  }
   UseMethod("line_segment")
 }
 #' @export
 line_segment.sf <- function(
     l,
     segment_length = NA,
+    n_segments = NA,
     use_rsgeo = NULL,
-    debug_mode = FALSE) {
-  if (is.na(segment_length)) {
-    rlang::abort(
-      "`segment_length` must be set.",
-      call = rlang::caller_env()
-    )
+    debug_mode = FALSE
+  ) {
+  # Get n_segments if not provided:
+  if (is.na(n_segments)) {
+    segment_lengths <- as.numeric(sf::st_length(l))
+    n_segments <- n_segments(segment_lengths, segment_length)
+  } else {
+    if (length(n_segments) != nrow(l)) {
+      if (length(n_segments) == 1) {
+        message("Setting n_segments to ", n_segments, " for all lines")
+        n_segments <- rep.int(n_segments, nrow(l))
+      }
+    }
   }
   # Decide whether to use rsgeo or lwgeom, if not set:
   if (is.null(use_rsgeo)) {
     use_rsgeo <- use_rsgeo(l)
   }
   if (use_rsgeo) {
     # If using rsgeo, we can do the whole thing in one go:
-    segment_lengths <- as.numeric(sf::st_length(l))
-    n_segments <- n_segments(segment_lengths, segment_length)
     res <- line_segment_rsgeo(l, n_segments = n_segments)
     return(res)
   }
+  # lwgeom implementation:
   n_row_l <- nrow(l)
   if (n_row_l > 1) {
     res_list <- pbapply::pblapply(seq(n_row_l), function(i) {
       if (debug_mode) {
         message(paste0("Processing row ", i, " of ", n_row_l))
       }
-      l_segmented <- line_segment1(l[i, ], n_segments = NA, segment_length = segment_length)
+      l_segmented <- line_segment1(l[i, ], n_segments = n_segments[i], segment_length = NA)
       res_names <- names(sf::st_drop_geometry(l_segmented))
       # Work-around for https://github.com/ropensci/stplanr/issues/531
       if (i == 1) {
@@ -228,20 +256,20 @@ line_segment.sf <- function(
     res <- bind_sf(res_list)
   } else {
     # If there's only one row:
-    res <- line_segment1(l, n_segments = NA, segment_length = segment_length)
+    res <- line_segment1(l, n_segments = n_segments)
   }
   res
 }
 
-
 #' @export
 line_segment.sfc_LINESTRING <- function(
     l,
     segment_length = NA,
+    n_segments = NA,
     use_rsgeo = NULL,
     debug_mode = FALSE) {
   l <- sf::st_as_sf(l)
-  res <- line_segment(l, segment_length = segment_length, use_rsgeo, debug_mode)
+  res <- line_segment(l, segment_length = segment_length, n_segments = n_segments, use_rsgeo, debug_mode)
   sf::st_geometry(res)
 }
 
@@ -267,7 +295,8 @@ line_segment.sfc_LINESTRING <- function(
 line_segment1 <- function(
     l,
     n_segments = NA,
-    segment_length = NA) {
+    segment_length = NA
+    ) {
   UseMethod("line_segment1")
 }
 #' @export
@@ -383,7 +412,7 @@ line_segment_rsgeo <- function(l, n_segments) {
   res_sf <- sf::st_as_sf(
     res_tbl,
     geometry = res,
-    crs = crs    
+    crs = crs
     )
   res_sf
 }

diff --git a/cran-comments.md b/cran-comments.md
@@ -1,4 +1,4 @@
-Bug fix release, with offending URLs removed thanks to feedback from CRAN.
+Fix to reverse dependencies
 
 ## R CMD check results
 

diff --git a/man/line_midpoint.Rd b/man/line_midpoint.Rd
diff --git a/man/line_segment.Rd b/man/line_segment.Rd
diff --git a/man/line_segment1.Rd b/man/line_segment1.Rd
diff --git a/revdep/README.md b/revdep/README.md
@@ -0,0 +1,46 @@
+# Platform
+
+|field    |value                                                                                |
+|:--------|:------------------------------------------------------------------------------------|
+|version  |R version 4.3.3 (2024-02-29)                                                         |
+|os       |Ubuntu 22.04.4 LTS                                                                   |
+|system   |x86_64, linux-gnu                                                                    |
+|ui       |RStudio                                                                              |
+|language |en_GB:en                                                                             |
+|collate  |en_GB.UTF-8                                                                          |
+|ctype    |en_GB.UTF-8                                                                          |
+|tz       |Europe/London                                                                        |
+|date     |2024-04-26                                                                           |
+|rstudio  |2024.04.0-daily+662 Chocolate Cosmos (desktop)                                       |
+|pandoc   |3.1.11 @ /usr/lib/rstudio/resources/app/bin/quarto/bin/tools/x86_64/ (via rmarkdown) |
+
+# Dependencies
+
+|package    |old   |new       |Δ  |
+|:----------|:-----|:---------|:--|
+|stplanr    |1.1.2 |1.2.0     |*  |
+|curl       |NA    |5.2.1     |*  |
+|data.table |NA    |1.15.4    |*  |
+|DBI        |NA    |1.2.2     |*  |
+|geosphere  |NA    |1.5-18    |*  |
+|lwgeom     |NA    |0.2-14    |*  |
+|nabor      |0.5.0 |0.5.0     |   |
+|od         |0.4.4 |0.4.4     |   |
+|openssl    |NA    |2.1.2     |*  |
+|pbapply    |1.7-2 |1.7-2     |   |
+|RcppEigen  |NA    |0.3.4.0.0 |*  |
+|sf         |NA    |1.0-16    |*  |
+|sp         |NA    |2.1-3     |*  |
+|tidyselect |NA    |1.2.1     |*  |
+|units      |NA    |0.8-5     |*  |
+
+# Revdeps
+
+## Failed to check (3)
+
+|package        |version |error |warning |note |
+|:--------------|:-------|:-----|:-------|:----|
+|agricolaeplotr |?       |      |        |     |
+|cyclestreets   |?       |      |        |     |
+|pct            |?       |      |        |     |
+
diff --git a/revdep/cran.md b/revdep/cran.md
@@ -0,0 +1,7 @@
+## revdepcheck results
+
+We checked 3 reverse dependencies (0 from CRAN + 3 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package.
+
+ * We saw 0 new problems
+ * We failed to check 0 packages
+
diff --git a/revdep/data.sqlite b/revdep/data.sqlite
diff --git a/revdep/failures.md b/revdep/failures.md
@@ -0,0 +1,99 @@
+# agricolaeplotr
+
+<details>
+
+* Version: 
+* GitHub: https://github.com/ropensci/stplanr
+* Source code: NA
+* Number of recursive dependencies: 0
+
+</details>
+
+## Error before installation
+
+### Devel
+
+```
+
+
+
+
+
+
+```
+### CRAN
+
+```
+
+
+
+
+
+
+```
+# cyclestreets
+
+<details>
+
+* Version: 
+* GitHub: https://github.com/ropensci/stplanr
+* Source code: NA
+* Number of recursive dependencies: 0
+
+</details>
+
+## Error before installation
+
+### Devel
+
+```
+
+
+
+
+
+
+```
+### CRAN
+
+```
+
+
+
+
+
+
+```
+# pct
+
+<details>
+
+* Version: 
+* GitHub: https://github.com/ropensci/stplanr
+* Source code: NA
+* Number of recursive dependencies: 0
+
+</details>
+
+## Error before installation
+
+### Devel
+
+```
+
+
+
+
+
+
+```
+### CRAN
+
+```
+
+
+
+
+
+
+```
diff --git a/revdep/problems.md b/revdep/problems.md
@@ -0,0 +1 @@
+*Wow, no problems at all. :)*