single path networks

DOI-USGS · Dec 14, 2022 · 6c6f5ba · 6c6f5ba
1 parent 735506e
commit 6c6f5ba
Show file tree

Hide file tree

Showing 4 changed files with 35 additions and 7 deletions.
diff --git a/R/hl_graph_utils.R b/R/hl_graph_utils.R
@@ -26,10 +26,10 @@ make_index_ids <- function(x, format = FALSE, complete = FALSE) {
 }
 
 check_graph <- function(x) {
-  x <- left_join(x, x,
+  x <- left_join(x, drop_geometry(x),
                  by = c("toid" = "id"))
 
-  if(any(x$id == x$toid.y)) {
+  if(any(x$id == x$toid.y, na.rm = TRUE)) {
     stop("found one or more pairs of features that reference eachother.")
   }
 
@@ -61,7 +61,7 @@ make_fromids <- function(index_ids, return_list = FALSE) {
   max_from <- max(froms_l)
 
   # Convert list to matrix with NA fill
-  froms_m <- as.matrix(sapply(froms$fromindid, '[', seq(max_from)))
+  froms_m <- matrix(sapply(froms$fromindid, '[', seq(max_from)), nrow = max_from, ncol = nrow(froms))
 
   # NAs should be length 0
   froms_l[is.na(froms_m[1, ])] <- 0

diff --git a/tests/testthat/test_calc_network.R b/tests/testthat/test_calc_network.R
@@ -3,6 +3,16 @@ test_that("get_sorted error", {
                           toid = c(2, 3, 4, 9, 7, 8, 9, 4))
 
   expect_error(nhdplusTools::get_sorted(test_data))
+
+  test_data <- data.frame(id = c(1, 2, 3, 4, 6, 7, 8, 9),
+                          toid = c(2, 3, 4, 0, 7, 8, 9, 4))
+
+  expect_equal(nrow(nhdplusTools::get_sorted(test_data)), nrow(test_data))
+
+  test_data <- data.frame(id = c(1, 2, 3, 4),
+                          toid = c(2, 3, 4, 0))
+
+  expect_equal(nrow(nhdplusTools::get_sorted(test_data)), nrow(test_data))
 })
 
 test_that("total drainage area works", {

diff --git a/tests/testthat/test_get_path.R b/tests/testthat/test_get_path.R
@@ -1,5 +1,3 @@
-
-
 test_that("reweight", {
   x <- readRDS(list.files(pattern = "reweight_test.rds",
                           full.names = TRUE, recursive = TRUE))
@@ -10,6 +8,26 @@ test_that("reweight", {
   expect_equal(w$weight[w$nameID == w$ds_nameID], 1)
 })
 
+test_that("degenerate levelpath", {
+  x <- structure(list(ID = c(203071, 202863, 202883, 205509, 203069, 202875, 942110034),
+                      toID = c(202863, 202883, 205509, 203069, 202875, 942110034, 0),
+                      fcode = c(33600, 33600, 33600, 33600, 33600, 46006, 55800),
+                      nameID = c(630020286, 630020286, 630020286, 630020286, 630020286, 630020286, 630020286),
+                      lengthkm = c(14.962, 4.881, 13.204, 2.054, 9.601, 2.893, 10.988),
+                      reachcode = c("12110208001272", "12110208000093", "12110208001144",
+                                    "12110208001144", "12110208001144", "12110208000099", "12110208017253"),
+                      frommeas = c(0, 0, 46.98279, 38.69724, 0, 0, 0),
+                      tomeas = c(99.35641, 100, 100, 46.98279, 38.69724, 100, 100),
+                      areasqkm = c(21.7197, 1019.7891, 74.0889, 37.3122, 530.9604, 5.562, 17.8893),
+                      weight = c(14.962, 19.843, 33.047, 35.101, 44.702, 47.595, 58.583),
+                      terminalID = c(942110034, 942110034, 942110034, 942110034, 942110034, 942110034, 942110034
+                      )), row.names = c(NA, 7L), class = "data.frame")
+
+  y <- nhdplusTools::get_levelpaths(x)
+
+  expect_equal(nrow(y), nrow(x))
+})
+
 test_that("calculate level path", {
   source(system.file("extdata", "walker_data.R", package = "nhdplusTools"))
 

diff --git a/tests/testthat/test_run_plus_attributes.R b/tests/testthat/test_run_plus_attributes.R
@@ -22,8 +22,6 @@ test_that("example", {
 
   source(system.file("extdata", "walker_data.R", package = "nhdplusTools"))
 
-  expect_s3_class(get_sorted(walker_flowline), "sf")
-
   test_flowline <- prepare_nhdplus(walker_flowline, 0, 0, FALSE, warn = FALSE)
 
   test_flowline <- data.frame(
@@ -33,6 +31,8 @@ test_that("example", {
     lengthkm = test_flowline$LENGTHKM,
     areasqkm = walker_flowline$AreaSqKM)
 
+  expect_s3_class(get_sorted(sf::st_sf(test_flowline, sf::st_geometry(walker_flowline))), "sf")
+
   mess <- capture_output(fl <- add_plus_network_attributes(test_flowline,
                                                            status = TRUE))