Merge pull request #43 from DOI-USGS/navigate

Cleanup suggests and get UT navigation working with diverted network.

R/add_divergence.R

@@ -128,7 +128,7 @@ add_divergence.hy <- function(x, coastal_outlet_ids, inland_outlet_ids,
     try(navigate_network_dfs(x = net, starts = i,
                              direction = "up",
                              reset = FALSE))
-  }, net = x, cl = "future")
+  }, net = x, cl = future_available())
 
   paths_df <- data.frame(id = unlist(term),
                          paths = I(unlist(paths,

R/add_levelpaths.R

@@ -145,8 +145,7 @@ add_levelpaths.hy <- function(x, name_attribute, weight_attribute,
     group_by(.data$toid) |>
     group_split()
 
-  cl <- "future"
-  if(inherits(future::plan(), "sequential")) cl = NULL
+  cl <- future_available()
 
   # reweight sets up ranked upstream paths
   x <- pblapply(x, reweight, override_factor = override_factor,

R/index_points_to_lines.R

@@ -392,6 +392,8 @@ index_points_to_lines.hy <- function(x, points,
 #' @export
 #' @examples
 #'
+#' if(require(nhdplusTools)) {
+#'
 #' source(system.file("extdata/sample_data.R", package = "nhdplusTools"))
 #'
 #' waterbodies <- sf::st_transform(
@@ -404,6 +406,8 @@ index_points_to_lines.hy <- function(x, points,
 #' index_points_to_waterbodies(waterbodies, points,
 #'                     search_radius = units::set_units(500, "m"))
 #'
+#' }
+#'
 index_points_to_waterbodies <- function(waterbodies, points, flines = NULL,
                                         search_radius = NULL) {
 

R/make_attribute_topology.R

@@ -77,7 +77,7 @@ make_attribute_topology.hy <- function(x, min_distance) {
       which(d == min(d, na.rm = TRUE))
     }
 
-  }, nodes = nodes, cl = "future")
+  }, nodes = nodes, cl = future_available())
 
   # Add resulting list as a list column
   nodes$torow <- closest

R/navigate_connected_paths.R

@@ -78,7 +78,8 @@ navigate_connected_paths <- function(x, outlets, status = FALSE) {
   }
 
   pairs <- t(combn(length(id_match), 2))
-  paths <- pbapply(pairs, 1, get_path, all_dn = all_dn, cl = "future")
+
+  paths <- pbapply(pairs, 1, get_path, all_dn = all_dn, cl = future_available())
 
   connected_paths <- paths[lengths(paths) > 0]
 

R/navigation_network.R

@@ -3,7 +3,7 @@ required_atts_navigate <- function(mode, distance) {
                         DM = c(id, levelpath, dn_levelpath,
                                topo_sort, dn_topo_sort),
                         UT = c(id, levelpath,
-                               topo_sort, dn_topo_sort),
+                               topo_sort, dn_topo_sort, dn_minor_topo_sort),
                         DD = c(id, levelpath, dn_levelpath,
                                topo_sort, dn_topo_sort, dn_minor_topo_sort))
 
@@ -41,6 +41,13 @@ get_start_row <- function(x, id) {
 #' @param distance numeric distance in km to limit navigation. The first
 #' catchment that exceeds the provided distance is included.
 #' @details if only `mode` is supplied, require network attributes are displayed.
+#'
+#' NOTE: for "Upstream with tributaries" navigation, if a tributary emanates from
+#' a diversion and is the minor path downstream of that diversion, it will be
+#' included. This can have a very large impact when a diversion between two
+#' large river systems. To strictly follow the dendritic network, set the
+#' "dn_minor_topo_sort" attribute to all 0 in x.
+#'
 #' @returns vector of identifiers found along navigation
 #' @name navigate_hydro_network
 #' @export
@@ -131,10 +138,18 @@ get_UT <- function(x, id, distance) {
 
     x <- filter(x, .data$id %in% all)
 
-    filter(x, .data$pathlength_km <= stop_pathlength_km)$id
-  } else {
-    all
+    all <- filter(x, .data$pathlength_km <= stop_pathlength_km)$id
   }
+
+  incoming_div <- filter(x, !id %in% all &
+                           dn_minor_topo_sort %in% x$topo_sort[x$id %in% all])
+
+  extra <- lapply(incoming_div$id, \(i) get_UT(x, i, distance))
+
+  all <- c(all, unique(unlist(extra)))
+
+  return(all)
+
 }
 
 private_get_UT <- function(x, id) {

R/utils.R

@@ -1,3 +1,8 @@
+future_available <- function() {
+  if(!requireNamespace("future", quietly = TRUE) ||
+     inherits(future::plan(), "sequential")) NULL else "future"
+}
+
 get_outlet_value <- function(x) {
   if(inherits(x$id, "character")) {
     ""

tests/testthat/test_add_pfafstetter.R

@@ -1,6 +1,6 @@
 test_that("get_pfaf", {
 
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
 
   work_dir <- nhdplusTools::nhdplusTools_data_dir()
 

tests/testthat/test_get_hydro_location.R

@@ -1,5 +1,5 @@
 test_that("get location", {
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
 
   source(system.file("extdata", "sample_flines.R", package = "nhdplusTools"))
 

tests/testthat/test_index.R

@@ -1,5 +1,5 @@
 test_that("index to waterbodies", {
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
 
   source(system.file("extdata/sample_data.R", package = "nhdplusTools"))
 
@@ -52,15 +52,16 @@ test_that("index to waterbodies", {
 
 sr <- units::set_units(0.1, "degrees")
 
-if(require(nhdplusTools)) {
+if(requireNamespace("nhdplusTools", quietly = TRUE)) {
   source(system.file("extdata", "sample_flines.R", package = "nhdplusTools"))
 
   sample_flines <- sf::st_cast(sample_flines, "LINESTRING", warn = FALSE)
 }
 
 test_that("point indexing to nearest existing node works as expected", {
 
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
+  if(!requireNamespace("lwgeom", quietly = TRUE)) skip("Missing lwgeom")
 
   flines_in <- sample_flines
 
@@ -113,7 +114,7 @@ test_that("point indexing to nearest existing node works as expected", {
 
 test_that("point indexing works without measures", {
 
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
 
     flines_in <- sample_flines
 
@@ -133,8 +134,8 @@ test_that("point indexing works without measures", {
 
 test_that("point indexing to for multiple points works", {
 
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
-
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
+  if(!requireNamespace("lwgeom", quietly = TRUE)) skip("Missing lwgeom")
   flines_in <- sample_flines
 
   flines_in <- sf::st_transform(flines_in, 4269)
@@ -227,7 +228,7 @@ test_that("no duplicates when using precision", {
 
 test_that("disambiguate", {
 
-  if(!require(nhdplusTools)) skip("Missing nhdplusTools")
+  if(!requireNamespace("nhdplusTools", quietly = TRUE)) skip("Missing nhdplusTools")
 
   source(system.file("extdata", "sample_flines.R", package = "nhdplusTools"))
 

vignettes/advanced_network.Rmd

@@ -191,7 +191,7 @@ lp <-  unique(lp$levelpath)
 terminal_fpath <- dplyr::filter(fpath, id %in% terminal_id)
 
 gif_file <- "levelpath.gif"
-
+try({
 gifski::save_gif({
   for(i in 1:length(lp)) {
     lp_plot <- dplyr::filter(fpath, levelpath == lp[i])
@@ -207,6 +207,7 @@ gifski::save_gif({
 }, gif_file, delay = 0.5)
 
 knitr::include_graphics(gif_file)
+})
 ```
 
 # Summary

vignettes/flow-table.Rmd

@@ -11,9 +11,10 @@ vignette: >
 ```{r setup, include = FALSE}
 local <- (Sys.getenv("BUILD_VIGNETTES") == "TRUE")
 
-if(!require(nhdplusTools)) local <- FALSE
+if(!requireNamespace("nhdplusTools", quietly = TRUE)) local <- FALSE
+if(!requireNamespace("mapview", quietly = TRUE)) local <- FALSE
 
-if(!local) {
+if(local) {
   nhdplusTools::nhdplusTools_data_dir(tempdir())
 }