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:/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:/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:/ropensci/stplanr
+* Source code: NA
+* Number of recursive dependencies: 0
+
+</details>
+
+## Error before installation
+
+### Devel
+
+```
+
+
+
+
+
+
+```
+### CRAN
+
+```
+
+
+
+
+
+
+```
+# cyclestreets
+
+<details>
+
+* Version: 
+* GitHub: https:/ropensci/stplanr
+* Source code: NA
+* Number of recursive dependencies: 0
+
+</details>
+
+## Error before installation
+
+### Devel
+
+```
+
+
+
+
+
+
+```
+### CRAN
+
+```
+
+
+
+
+
+
+```
+# pct
+
+<details>
+
+* Version: 
+* GitHub: https:/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. :)*