Merge pull request #79 from poissonconsulting/add-point-to-stream-mea…

…sure

DESCRIPTION

@@ -14,7 +14,7 @@ URL: https://poissonconsulting.github.io/fwatlasbc/
 Depends: 
     R (>= 4.1)
 Imports: 
-    chk (>= 0.8.1.9001),
+    chk,
     digest,
     dplyr,
     fwapgr (>= 0.1.0.9013),
@@ -27,7 +27,8 @@ Imports:
     stringr,
     tibble,
     tidyplus,
-    tidyselect
+    tidyselect,
+    units
 Suggests: 
     covr,
     googleway,
@@ -37,7 +38,6 @@ Suggests:
     rlang,
     testthat (>= 3.0.0)
 Remotes:
-    poissonconsulting/chk,
     poissonconsulting/fwapgr
 Config/testthat/edition: 3
 Encoding: UTF-8

NAMESPACE

@@ -8,6 +8,7 @@ export(fwa_add_downstream_split_to_rms)
 export(fwa_add_gm_elevation_to_point)
 export(fwa_add_intersection_to_geometry)
 export(fwa_add_new_blk_rm_to_blk_rm)
+export(fwa_add_point_to_stream_measure)
 export(fwa_add_rms_to_blk)
 export(fwa_add_section_to_rms)
 export(fwa_add_stream_names_to_blk)

R/add-point-to-stream-measure.R

@@ -0,0 +1,79 @@
+add_point_to_stream_measure <- function(x, streams) {
+  stream <- streams[streams$blk == x$blk[1],]
+  x$proportion <- x$stream_measure / stream$length
+  x$geometry <- stream |>
+    sf::st_line_sample(sample = x$proportion) |>
+    sf::st_cast("POINT")
+  x
+}
+
+#' Add Point to Stream Measure
+#'
+#' Adds point geometry for stream measure in m based on the blue line key (blk)
+#' and the proportion of the stream measure along the stream.
+#' If the proportion is >= 1 then the geometry is set to the top of the stream.
+#'
+#' @param x A data frame with columns blk and stream_measure.
+#' @param streams An sf object of spatial linestrings with blk column.
+#' @param ... Additional columns to group by when assigning.
+#' @return An updated version of x with numeric column proportion
+#' giving the proportion of the stream measure along the stream
+#' and a geometry column.
+#' @seealso [fwa_snap_stream_measure_to_point()]
+#' @export
+#' @examples
+#' \dontrun{
+#' watershed <- fwa_add_watershed_to_blk(data.frame(blk = 356308001, rm = 1000))
+#' network <- fwa_add_collection_to_polygon(watershed)
+#' network$blk <- network$blue_line_key
+#' streams <- fwa_join_stream_segments(network)
+#' points <- fwa_add_rms_to_blk(data.frame(blk = 356308001))
+#' points <- fwa_snap_stream_measure_to_point(points, streams)
+#' points <- points[c("blk", "stream_measure")]
+#' fwa_add_point_to_stream_measure(points, streams)
+#' }
+fwa_add_point_to_stream_measure <- function(x, streams, ...) {
+  chk::chk_data(x)
+  chk::chk_s3_class(streams, "sf")
+
+  check_names(x, c("blk", "stream_measure"))
+  chk_not_subset(colnames(x), "..fwa_id")
+  chk_whole_numeric(x$blk)
+  chk_gt(x$blk)
+  chk_numeric(x$stream_measure)
+  chk_gte(x$stream_measure)
+
+  check_names(streams, "blk")
+  chk_whole_numeric(streams$blk)
+  chk_not_any_na(streams$blk)
+  chk_gt(streams$blk)
+  check_key(streams, "blk")
+
+  chk_join(x, streams, by = "blk")
+
+  chk_s3_class(sf::st_geometry(streams), "sfc_LINESTRING")
+
+  check_dim(x, dim = nrow, values = TRUE)
+  check_dim(streams, dim = nrow, values = TRUE)
+
+  crs <- sf::st_crs(streams)
+
+  x <- sf::st_drop_geometry(x)
+
+  chk_not_subset(colnames(x), c("geometry"))
+
+  streams <- streams |>
+    dplyr::mutate(length = sf::st_length(streams),
+                  length = units::set_units(.data$length, "m"),
+                  length = as.numeric(length)) |>
+    dplyr::select("blk", "length")
+
+  x |>
+    dplyr::mutate(..fwa_id = 1:dplyr::n()) |>
+    group_split_sf(.data$blk, ...) |>
+    lapply(add_point_to_stream_measure, streams = streams) |>
+    dplyr::bind_rows() |>
+    dplyr::arrange(.data$..fwa_id) |>
+    dplyr::select(!c("..fwa_id")) |>
+    identity()
+}

tests/testthat/_snaps/add-point-to-stream-measure/add_point_x1.csv

@@ -0,0 +1,2 @@
+blk,stream_measure,proportion
+356308001,0,0

tests/testthat/_snaps/add-point-to-stream-measure/add_point_x2.csv

@@ -0,0 +1,6 @@
+blk,stream_measure,proportion
+356308001,0,0
+356308001,100,0.005199028066473258
+356308001,10000,0.5199028066473258
+356308001,20000,1.0398056132946516
+356308001,40000,2.079611226589303

tests/testthat/_snaps/add-point-to-stream-measure/add_point_x2s.csv

@@ -0,0 +1,3 @@
+blk,stream_measure,proportion
+356308001,0,0
+355992254,1,0.006747530069601267

tests/testthat/_snaps/add-point-to-stream-measure/add_point_x4.csv

@@ -0,0 +1,6 @@
+blk,stream_measure,proportion
+356308001,0,0
+356308001,100,0.005199028066473258
+356308001,10000,0.5199028066473258
+356308001,20000,1.0398056132946516
+356308001,40000,2.079611226589303

tests/testthat/_snaps/add-point-to-stream-measure/apsm.csv

@@ -0,0 +1,21 @@
+blk,stream_measure,proportion
+356308001,0,0
+356308001,1000.003607,0.051990468193674935
+356308001,2000.017171,0.10398145405457444
+356308001,3000.011434,0.15597143645106684
+356308001,4000.014659,0.20796188478445457
+356308001,5000.00998,0.2599519221866639
+356308001,6000.008678,0.3119421351600511
+356308001,7000.024298,0.3639332279129676
+356308001,8000.020311,0.4159233012924512
+356308001,9000.01751,0.4679134363324076
+356308001,10000.030555,0.5199043952103515
+356308001,11000.041108,0.5718952245285159
+356308001,12000.051979,0.6238860703795895
+356308001,13000.075469,0.675877572296015
+356308001,14000.103248,0.7278692971987542
+356308001,15000.131712,0.7798610577148356
+356308001,16000.133767,0.8318514452195949
+356308001,17000.12526,0.88384128360301
+356308001,18000.138751,0.9358322656686188
+356308001,19000.150674,0.9878231662134679

tests/testthat/test-add-point-to-stream-measure.R

@@ -0,0 +1,39 @@
+test_that("test fwa_add_point_to_stream_measure", {
+  watershed <- fwa_add_watershed_to_blk(data.frame(blk = 356308001, rm = 1000))
+  network <- fwa_add_collection_to_polygon(watershed)
+  network$blk <- network$blue_line_key
+  streams <- fwa_join_stream_segments(network)
+  points <- fwa_add_rms_to_blk(data.frame(blk = 356308001))
+
+  x1 <- data.frame(blk = 356308001, stream_measure = 0)
+  x1 <- fwa_add_point_to_stream_measure(x1, streams)
+  expect_snapshot_data(x1, "add_point_x1")
+
+  x4 <- data.frame(blk = 356308001, stream_measure = c(0, 100, 10000, 20000, 40000))
+  x4 <- fwa_add_point_to_stream_measure(x4, streams)
+  expect_snapshot_data(x4, "add_point_x4")
+
+  x2 <- data.frame(blk = 356308001, stream_measure = c(0, 100, 10000, 20000, 40000))
+  x2 <- fwa_add_point_to_stream_measure(x2, streams)
+  expect_snapshot_data(x2, "add_point_x2")
+
+  x2s <- data.frame(blk = c(356308001, 355992254), stream_measure = c(0,1))
+  x2s <- fwa_add_point_to_stream_measure(x2s, streams)
+  expect_snapshot_data(x2s, "add_point_x2s")
+
+  x0 <- data.frame(blk = 1, stream_measure = 0)
+  expect_error(fwa_add_point_to_stream_measure(x0, streams), "must match")
+})
+
+
+test_that("example add point to stream measure", {
+  watershed <- fwa_add_watershed_to_blk(data.frame(blk = 356308001, rm = 1000))
+  network <- fwa_add_collection_to_polygon(watershed)
+  network$blk <- network$blue_line_key
+  streams <- fwa_join_stream_segments(network)
+  points <- fwa_add_rms_to_blk(data.frame(blk = 356308001))
+  points <- fwa_snap_stream_measure_to_point(points, streams)
+  points <- points[c("blk", "stream_measure")]
+  points <- fwa_add_point_to_stream_measure(points, streams)
+  expect_snapshot_data(points, "apsm")
+})