From 6c6f5babaebce7ea55200709ebd400f667812929 Mon Sep 17 00:00:00 2001 From: David Blodgett Date: Wed, 14 Dec 2022 12:54:10 -0600 Subject: [PATCH] single path networks --- R/hl_graph_utils.R | 6 +++--- tests/testthat/test_calc_network.R | 10 ++++++++++ tests/testthat/test_get_path.R | 22 ++++++++++++++++++++-- tests/testthat/test_run_plus_attributes.R | 4 ++-- 4 files changed, 35 insertions(+), 7 deletions(-) diff --git a/R/hl_graph_utils.R b/R/hl_graph_utils.R index ffeeefc3..4a912eb6 100644 --- 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 index 59934b93..b7fb8d61 100644 --- 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 index 90148259..cb89664d 100644 --- 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 index 08013283..96275198 100644 --- 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))