diff --git a/.gitignore b/.gitignore
index 719b9046a64288fc47cf19f3b9da9630a39c4590..21174297cf8b4e17fb68833384286311aa2fcc96 100644
--- a/.gitignore
+++ b/.gitignore
@@ -21,4 +21,6 @@ workspace/reports
*.fst
*.parquet
*.Renviron
-*.zip
\ No newline at end of file
+*.zip
+*.Rprofile
+*.targets_stores
\ No newline at end of file
diff --git a/README.md b/README.md
index a5863c46d325cc1c25abbf2f91612754bf3f9552..e8a8405ebe9b19325efa97604f4be89c03425eba 100644
--- a/README.md
+++ b/README.md
@@ -1,18 +1,12 @@
# National Hydrologic Geospatial Fabric (hydrofabric) Workflow
-## Provisional Citation
-
-Blodgett, D.L., Bock, A.R., Johnson, J.M., Santiago, M., Wieczorek, M.E., 2022, National Hydrologic Geospatial Fabric (hydrofabric) Workflow: U.S. Geological Survey software release, https://doi.org/10.5066/P977IAA2 (pending)
-
## Overview
-This repository houses workflow software for development of three data releases associated with the National Hydrologic Geospatial Fabric (hydrofabric).
-
-1) Blodgett, D.L., 2022, Updated CONUS river network attributes based on the E2NHDPlusV2 and NWMv2.1 networks: U.S. Geological Survey data release, https://doi.org/10.5066/P9W79I7Q.
+This repository houses workflow software for development of two data releases associated with the National Hydrologic Geospatial Fabric (hydrofabric).
-2) Johnson, J.M., Blodgett, D.L., Bock A.R., 2022, Updated CONUS network geometry based on NWMv2.1: U.S. Geological Survey data release, https://doi.org/10.5066/P9ZP6NNO. (pending here https://www.sciencebase.gov/catalog/item/6317a72cd34e36012efa4e8a)
+1) Johnson, J.M., Blodgett, D.L., Bock A.R., 2022, Updated CONUS network geometry based on NWMv2.1: U.S. Geological Survey data release, https://doi.org/10.5066/P9ZP6NNO. (pending here https://www.sciencebase.gov/catalog/item/6317a72cd34e36012efa4e8a)
-3) Bock, A.R., Blodgett, D.L., Johnson, J.M., Santiago, M., Wieczorek, M.E., 2022, National Hydrologic Geospatial Fabric Reference and Derived Hydrofabrics: U.S. Geological Survey data release, https://doi.org/10.5066/P9NFPB5S (pending here https://www.sciencebase.gov/catalog/item/60be0e53d34e86b93891012b)
+2) Bock, A.R., Blodgett, D.L., Johnson, J.M., Santiago, M., Wieczorek, M.E., 2022, National Hydrologic Geospatial Fabric Reference and Derived Hydrofabrics: U.S. Geological Survey data release, https://doi.org/10.5066/P9NFPB5S (pending here https://www.sciencebase.gov/catalog/item/60be0e53d34e86b93891012b)
These efforts are development-phase and are working towards the priorities of the USGS [Water Availability and Use Science Program ](https://www.usgs.gov/programs/water-availability-and-use-science-program) and the NOAA [National Water Model](https://water.noaa.gov/). Details of these efforts will be documented in forthcoming reports and web communication products.
@@ -30,51 +24,6 @@ Although this software program has been used by the U.S. Geological Survey (USGS
This software is provided "AS IS."
-## Environment Types
-
-This repository is meant to support, local, docker/Jupyter-based, and HPC use with Shifter.
-
-### Local
-
-Local environment setup is largely up to the developer and not all dependencies are strictly required for everyone. As such, review the `Dockerfile` to see what is installed in Docker for what might be required. If you add things, please either add them to the Docker build or notify someone who knows how and they will add them. Development of local environment setup / verification scripts should be considered for use with individual process steps.
-
-A major exception for local builds is ArcPy. Because it requires an ArcGIS license, it can not be intalled in a shared Docker/Jupyter environment. We will have to work through those dependencies on a case be case basis -- do not hesitate to check in files with ArcPY dependencies, *but aim to have the workflow steps that use ArcPy generate data that can be accessed by other workflow steps rather than needing to rerun the ArcPy code.*
-
-`parallel --jobs 10 < workspace/navigate_calls.txt && docker run --mount type=bind,source="$(pwd)"/workspace,target=/jupyter dblodgett/gfv2:v0.12 R -e "rmarkdown::render('/jupyter/merge.Rmd', output_file='/jupyter/merge.html')" && parallel --jobs 10 < workspace/hyRefactor_calls.txt`
-
-
-### Docker/Jupyter
-
-The Docker / Jupyter environment will be treated as a continuous integration system that can be run on a local Docker or a remote Docker. Binder may be a suitable technology here as well. Some project developers may work directly in this environment, others may use it as a test environment to build the final version of their artifact.
-
-### Denali / Shifter
-
-Interactive, first `salloc`:
-
-`salloc -N 1 -A impd -t 01:00:00`
-
-then use `shifter` to enter a running container
-
-`shifter --image=docker:dblodgett/hydrogeoenv-custom:latest --volume="/absolute/path/gfv2/gfv2.0/workspace:/jupyter" /bin/bash`
-
-Or execute a test `shifter` command.
-
-Batch, use a batch script like:
-
-```
-#!/bin/bash
-#SBATCH -A impd
-#SBATCH -N 1
-#SBATCH --job-name=gfv2
-#SBATCH --time=24:00:00
-
-parallel --jobs 20 < workspace/shifter_navigate_calls.txt
-
-shifter --volume="/absolute/path/gfv2/gfv2.0/workspace:/jupyter" --image=dblodgett/hydrogeoenv-custom:latest R -e "rmarkdown::render('/jupyter/merge.Rmd', output_file='/jupyter/merge.html')"
-
-parallel --jobs 10 < workspace/shifter_hyRefactor_calls.txt
-```
-
## Artifact Management
In order to keep the workflow system from getting too complex, we will not pursue automated artifact cache management initially. Rather, local builds should (optionally) check for remote content from upstream processing steps and download the output if it is available. *Each processing step will be responsible for fetching its own cache.* Process output should be versioned but can be versioned per processing step such that newly-checked-in code should have the updated version of it's output checked in already and know how to fetch it for other's to use.
diff --git a/hyfabric/DESCRIPTION b/hyfabric/DESCRIPTION
index df518e925e3636203778cce277db074c64dca10a..e1e2e903faef5722e7250403d0347423b143da7c 100644
--- a/hyfabric/DESCRIPTION
+++ b/hyfabric/DESCRIPTION
@@ -1,16 +1,16 @@
Package: hyfabric
Type: Package
-Title: Utility functions for creating the reference geospatial fabric.
-Version: 0.5.8
+Title: Utility functions for creating the reference hydrofabric.
+Version: 0.6.0
Authors@R: c(person(given = "David",
family = "Blodgett",
role = c("aut", "cre"),
email = "dblodgett@usgs.gov"))
-Description: TBD
-Imports: sf
+Description: Functions used in reference hydrofabric creation workflows. These functions are scoped specifically to the workflows in the repository this package resides in.
+Imports: sf, dplyr, data.table, hydroloom
Suggests: testthat
License: CC0
Encoding: UTF-8
LazyData: true
VignetteBuilder: knitr
-RoxygenNote: 7.1.2
+RoxygenNote: 7.3.2
diff --git a/hyfabric/NAMESPACE b/hyfabric/NAMESPACE
index 6be8415326a466d5b893a374924abe07f9ed9f45..e81e06e97591de739542ad37e0be28c546796379 100644
--- a/hyfabric/NAMESPACE
+++ b/hyfabric/NAMESPACE
@@ -4,6 +4,7 @@ export(NetworkConnection)
export(POI_creation)
export(addType)
export(get_rpu_dependent_vars)
+export(make_incremental_segments)
export(needs_layer)
export(switchDiv)
import(dplyr)
@@ -13,8 +14,7 @@ importFrom(dplyr,left_join)
importFrom(dplyr,mutate)
importFrom(dplyr,rename)
importFrom(dplyr,select)
-importFrom(nhdplusTools,get_node)
+importFrom(hydroloom,get_node)
importFrom(nhdplusTools,st_compatibalize)
importFrom(sf,st_drop_geometry)
importFrom(sf,st_layers)
-importFrom(sf, st_as_sf)
diff --git a/hyfabric/R/poi_creation.R b/hyfabric/R/poi_creation.R
index f4be00021fd202a08977209dea8f45a87d936ba9..45206e93804eb9bd228df24106db9ce093db224a 100644
--- a/hyfabric/R/poi_creation.R
+++ b/hyfabric/R/poi_creation.R
@@ -6,7 +6,7 @@
#' @param IDfield character) Name of 'Type' field to be modified in POI
#'
#' @return (sf data.frame) OIs for the specific data theme
-#' @importFrom nhdplusTools get_node
+#' @importFrom hydroloom get_node
#' @importFrom dplyr filter mutate inner_join select
#' @export
POI_creation<-function(srcData, nhdDF, IDfield){
@@ -17,12 +17,12 @@ POI_creation<-function(srcData, nhdDF, IDfield){
sub_segs <- filter(nhdDF, COMID %in% srcData$COMID)
POIs <- sub_segs %>%
- get_node(., position = "end") %>%
+ get_node(position = "end") %>%
mutate(COMID = sub_segs$COMID) %>%
inner_join(srcData %>% select(COMID, ID), by = "COMID") %>%
mutate(!!(paste0("Type_", IDfield)) := ID) %>%
select(COMID, !!(paste0("Type_", IDfield))) %>%
- st_as_sf()
+ sf::st_as_sf()
return(POIs)
}
@@ -97,7 +97,7 @@ addType <- function(new_POIs, POIs, IDfield, nexus = TRUE, bind = TRUE){
POIs_fin <- data.table::rbindlist(list(POIs_orig,
POIs_new),
fill = TRUE) %>%
- st_as_sf()
+ sf::st_as_sf()
} else {
POIs_fin <- POIs_orig
}
@@ -112,7 +112,7 @@ addType <- function(new_POIs, POIs, IDfield, nexus = TRUE, bind = TRUE){
if(nrow(new_nexus) > 0){
POIs_fin <- data.table::rbindlist(list(POIs_orig, new_nexus),
fill = TRUE) %>%
- st_as_sf()
+ sf::st_as_sf()
}
return(POIs_fin)
diff --git a/hyfabric/man/addType.Rd b/hyfabric/man/addType.Rd
index 71599346d91078baf543ee95a501747e418d331d..427f68e961e337d07f1d9205452284657b2362bc 100644
--- a/hyfabric/man/addType.Rd
+++ b/hyfabric/man/addType.Rd
@@ -4,7 +4,7 @@
\alias{addType}
\title{Adds the type attribute for co-located POIs of multiple themes}
\usage{
-addType(new_POIs, POIs, IDfield, bind = TRUE)
+addType(new_POIs, POIs, IDfield, nexus = TRUE, bind = TRUE)
}
\arguments{
\item{new_POIs}{(sf data.frame) new POIs to be tested against existing}
@@ -13,6 +13,8 @@ addType(new_POIs, POIs, IDfield, bind = TRUE)
\item{IDfield}{(character) Name of 'Type' field to be modified in existing POI}
+\item{nexus}{(logical) whether to consider existing nexus/event locations when adding to POI information}
+
\item{bind}{(logical) whether to bind non co-located POIs to data frame or just
attribute existing POIs}
}
diff --git a/workspace/00_get_data.Rmd b/workspace/00_get_data.Rmd
index 9c8b496866baf5e911b85c2dbf3a936dfb9e1247..3e53781db99391b4ee3ecd2654bb942fbba55134 100644
--- a/workspace/00_get_data.Rmd
+++ b/workspace/00_get_data.Rmd
@@ -17,13 +17,17 @@ are made to the output of this notebook, they should be checked in.
source("R/utils.R")
source("R/config.R")
source("R/user_vars.R")
-source("R/1_get_data.R")
+source("R/00_get_data_functions.R")
+
+library(sbtools)
+library(jsonlite)
if(!dir.exists("data")) {dir.create("data")}
if(!dir.exists("bin")) {dir.create("bin")}
data_dir <- "data"
-out_list <- list("data_dir" = data_dir)
+out_list <- list("data_dir" = data_dir,
+ nhdplushr_dir = file.path(data_dir, "nhdplushr"))
out_file <- file.path("cache", "data_paths.json")
sevenz <- "7z"
@@ -39,7 +43,9 @@ if(is(check_7z, "try-error")) {
sevenz <- "bin/7za.exe"
}
-initialize_sciencebase_session(username = Sys.getenv("sb_user"))
+if(!sbtools::is_logged_in())
+ initialize_sciencebase_session(username = Sys.getenv("sb_user"))
+
# Enable mapview rendering if desired
mapview <- FALSE
```
@@ -51,12 +57,15 @@ national modeling fabrics.
# Blodgett, D.L., 2022, Mainstem Rivers of the Conterminous United States:
# U.S. Geological Survey data release, https://doi.org/10.5066/P9BTKP3T.
+wbd_points_file <- "102020wbd_outlets.gpkg"
+
+get_sb_file(item = "63cb38b2d34e06fef14f40ad",
+ item_files = wbd_points_file,
+ out_destination = data_dir)
+
out_list <- c(
out_list,
- list(hu12_points_path =
- get_sb_file(item = "63cb38b2d34e06fef14f40ad",
- item_files = "102020wbd_outlets.gpkg",
- out_destination = data_dir)))
+ list(hu12_points_path = file.path(data_dir, wbd_points_file)))
if(mapview)(mapview(read_sf(out_list$hu12_points_path)))
@@ -82,6 +91,11 @@ out_list <- c(
item_files = "all",
out_destination = file.path(data_dir, "SWIM_gage_loc"))))
+# written by 00_gage_info
+out_list <- c(
+ out_list,
+ list(SWIM_dbf = file.path(data_dir, "SWIMGFinfo.dbf")))
+
if(mapview)(mapview(read_sf(out_list$SWIM_points_path)))
```
@@ -110,11 +124,11 @@ dir.create(TE_points_path, recursive = TRUE, showWarnings = FALSE)
get_sb_file("5dbc53d4e4b06957974eddae",
"2015_TE_Model_Estimates_lat.long_COMIDs.7z",
- TE_points_path, unzip = TRUE)
+ TE_points_path)
get_sb_file("63adc826d34e92aad3ca5af4",
"galanter_and_others_2023.zip",
- TE_points_path, unzip = TRUE)
+ TE_points_path)
out_list <- c(out_list, list(TE_points_path = TE_points_path))
@@ -132,22 +146,12 @@ water use withdrawals.
# Attributes and Modified Routing for NHDPlus Version 2.1 Flowlines: U.S.
# Geological Survey data release, https://doi.org/10.5066/P986KZEM.
-USGS_IT_path <- file.path(data_dir, "USGS_IT")
-
-if(!file.exists(USGS_IT_path)) {
- dir.create(USGS_IT_path, recursive = TRUE, showWarnings = FALSE)
-
- ITzip <- "supplemental_files.zip"
- check_auth()
- sbtools::item_file_download("5d16509ee4b0941bde5d8ffe", names = ITzip,
- destinations = file.path(USGS_IT_path, ITzip))
-
- unzip(file.path(USGS_IT_path, ITzip), exdir = USGS_IT_path)
-
- rm(ITzip)
-}
-
-out_list <- c(out_list, list(USGS_IT_path = USGS_IT_path))
+out_list <- c(
+ out_list,
+ list(USGS_IT_path =
+ get_sb_file("5d16509ee4b0941bde5d8ffe",
+ "supplemental_files.zip",
+ file.path(data_dir, "USGS_IT"))))
```
Two datasets relate hydro location information from the National Inventory of
@@ -169,29 +173,16 @@ natural flow (Wieczorek and others, 2021).
NID_points_path <- file.path(data_dir, "NID_points")
-if(!file.exists(NID_points_path)) {
- dir.create(NID_points_path, recursive = TRUE, showWarnings = FALSE)
-
- NIDtxt <- "NID_attributes_20170612.txt"
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae", names = NIDtxt,
- destinations = file.path(NID_points_path,
- NIDtxt))
-
- NIDzip <- "Final_NID_2018.zip"
- check_auth()
- sbtools::item_file_download("5fb7e483d34eb413d5e14873", names = NIDzip,
- destinations = file.path(NID_points_path,
- NIDzip))
-
- unzip(file.path(NID_points_path, NIDzip), files = NULL,
- exdir = NID_points_path)
-
-
- rm(NIDtxt, NIDzip)
-}
+get_sb_file("5dbc53d4e4b06957974eddae",
+ "NID_attributes_20170612.txt",
+ NID_points_path)
+
+get_sb_file("5fb7e483d34eb413d5e14873",
+ "Final_NID_2018.zip",
+ NID_points_path)
out_list <- c(out_list, list(NID_points_path = NID_points_path))
+
if(mapview)(mapview(read_sf(out_list$NID_points_path)))
```
@@ -213,88 +204,50 @@ efforts. These include:
# Units: U.S. Geological Survey data release,
# https://doi.org/10.5066/P9CFXHGT.
+epa_data_root <- "https://dmap-data-commons-ow.s3.amazonaws.com/NHDPlusV21/Data/"
+
nhdplus_dir <- file.path(data_dir, "NHDPlusNationalData")
-nhdplus_gdb <- file.path(data_dir,
- "NHDPlusNationalData/NHDPlusV21_National_Seamless_Flattened_Lower48.gdb")
+nhdplus_gdb <- file.path(nhdplus_dir, "NHDPlusV21_National_Seamless_Flattened_Lower48.gdb")
islands_dir <- file.path(data_dir, "islands")
-islands_gdb <- file.path(islands_dir,
- "NHDPlusNationalData/NHDPlusV21_National_Seamless_Flattened_HI_PR_VI_PI.gdb/")
+islands_gdb <- file.path(islands_dir, "NHDPlusNationalData/NHDPlusV21_National_Seamless_Flattened_HI_PR_VI_PI.gdb/")
rpu <- file.path(nhdplus_dir, "NHDPlusGlobalData", "BoundaryUnit.shp")
-if(!file.exists(nhdplus_dir)) {
- message("downloading NHDPlus...")
-
- dir.create(nhdplus_dir, recursive = TRUE, showWarnings = FALSE)
- dir.create(islands_dir, recursive = TRUE, showWarnings = FALSE)
+get_sb_file("5dbc53d4e4b06957974eddae", "NHDPlusV21_NationalData_GageLoc_05.7z", nhdplus_dir)
- gLz <- "NHDPlusV21_NationalData_GageLoc_05.7z"
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae", names = gLz,
- destinations = file.path(nhdplus_dir, gLz))
-
- system(paste0(sevenz, " e -o", nhdplus_dir, " ",
- file.path(nhdplus_dir, gLz)))
-
- xWalk <- "CrosswalkTable_NHDplus_HU12_CSV.7z"
-
- sbtools::item_file_download("5c86a747e4b09388244b3da1", names = xWalk,
- destinations = file.path(nhdplus_dir, xWalk))
- check_auth()
- system(paste0(sevenz, " e -o", nhdplus_dir, " ",
- file.path(nhdplus_dir, xWalk)))
-
- x <- tryCatch(
- download_nhdplusv2(data_dir, url = "https://dmap-data-commons-ow.s3.amazonaws.com/NHDPlusV21/Data/NationalData/NHDPlusV21_NationalData_Seamless_Geodatabase_Lower48_07.7z"),
- # Quiet the download, overwrite existing files
- error = function(e)
- {system(paste0(sevenz, " x ", file.path(data_dir,
- "NHDPlusV21_NationalData_Seamless_Geodatabase_Lower48_07.7z")
- , " -o", data_dir), ignore.stdout = T)}
- )
-
- x <- tryCatch(
- download_nhdplusv2(islands_dir,
- url = paste0("https://dmap-data-commons-ow.s3.amazonaws.com/NHDPlusV21/",
- "Data/NationalData/NHDPlusV21_NationalData_Seamless",
- "_Geodatabase_HI_PR_VI_PI_03.7z")),
-
- # Quiet the download, overwrite existing files
- error = function(e)
- {system(paste0(sevenz, " x ", file.path(islands_dir, "NHDPlusV21_NationalData_Seamless_Geodatabase_HI_PR_VI_PI_03.7z")
- , " -o", islands_dir), ignore.stdout = T)}
- )
-
- rm(gLz, xWalk)
-
- HUC12 <- read_sf(nhdplus_gdb, layer = "HUC12") %>%
- st_make_valid() %>%
- st_transform(., crs = proj_crs)
-
- saveRDS(HUC12, file = file.path(nhdplus_dir, "HUC12.rds"))
-
- gagelocgf <- "GageLocGFinfo.dbf"
- check_auth()
- sbtools::item_file_download("5dcd5f96e4b069579760aedb", names = gagelocgf,
- destinations = file.path(data_dir, gagelocgf))
-
- u <- "http://www.horizon-systems.com/NHDPlusData/NHDPlusV21/Data/GlobalData/NHDPlusV21_NHDPlusGlobalData_03.7z"
-
- out_f <- file.path(nhdplus_dir, basename(u))
-
- download.file(u, destfile = out_f, mode = "wb")
-
- system(paste0(sevenz, " x ", out_f, " -o", nhdplus_dir),
- ignore.stdout = TRUE, intern = TRUE)
-
+get_sb_file("5c86a747e4b09388244b3da1", "CrosswalkTable_NHDplus_HU12_CSV.7z", nhdplus_dir)
+
+# will download the 7z and unzip into the folder structure in nhdplus_gdb path
+download_file(paste0(epa_data_root, "NationalData/NHDPlusV21_NationalData_Seamless_Geodatabase_Lower48_07.7z"),
+ out_path = data_dir, check_path = nhdplus_gdb)
+
+download_file(paste0(epa_data_root, "NationalData/NHDPlusV21_NationalData_Seamless_Geodatabase_HI_PR_VI_PI_03.7z"),
+ out_path = islands_dir, check_path = islands_gdb)
+
+# cache the huc12 layer in rds format
+hu12_rds <- file.path(nhdplus_dir, "HUC12.rds")
+
+if(!file.exists(hu12_rds)) {
+ read_sf(nhdplus_gdb, layer = "HUC12") |>
+ st_make_valid() |>
+ st_transform(crs = proj_crs) |>
+ # TODO: convert this to gpkg
+ saveRDS(file = hu12_rds)
}
+get_sb_file("5dcd5f96e4b069579760aedb", "GageLocGFinfo.dbf", data_dir)
+
+download_file(paste0(epa_data_root, "GlobalData/NHDPlusV21_NHDPlusGlobalData_03.7z"),
+ out_path = nhdplus_dir, check_path = rpu)
+
out_list <- c(out_list, list(nhdplus_dir = nhdplus_dir,
nhdplus_gdb = nhdplus_gdb,
islands_dir = islands_dir,
islands_gdb = islands_gdb,
- nhdplus_rpu = rpu))
+ nhdplus_rpu = rpu,
+ gageloc_info = file.path(data_dir,
+ "GageLocGFinfo.dbf")))
```
Reference catchments and flowlines are hydrographic products that are derived
@@ -314,95 +267,22 @@ ref_cat <- file.path(ref_fab_path, "reference_catchments.gpkg")
ref_fl <- file.path(ref_fab_path, "reference_flowline.gpkg")
nwm_fl <- file.path(ref_fab_path, "nwm_network.gpkg")
-if(!dir.exists(ref_fab_path)) {
- dir.create(ref_fab_path, recursive = TRUE, showWarnings = FALSE)
-}
-
-if(!file.exists(ref_cat)){
- possible_vpu <- c("01", "08", "10L", "15", "02", "04", "05", "06", "07", "09",
- "03S", "03W", "03N", "10U", "11", "12", "13", "14", "16",
- "17", "18")
-
- for (vpu in possible_vpu){
- vpu_gpkg <- paste0(vpu, "_reference_features.gpkg")
- check_auth()
- sbtools::item_file_download("6317a72cd34e36012efa4e8a", names = vpu_gpkg,
- destinations = file.path(ref_fab_path, vpu_gpkg))
- }
- check_auth()
- sbtools::item_file_download("61295190d34e40dd9c06bcd7",
- names = "reference_catchments.gpkg",
- destinations = ref_cat)
- check_auth()
- sbtools::item_file_download("61295190d34e40dd9c06bcd7",
- names = "reference_flowline.gpkg",
- destinations = ref_fl)
- check_auth()
- sbtools::item_file_download("61295190d34e40dd9c06bcd7",
- names = "nwm_network.gpkg",
- destinations = nwm_fl)
-}
-
-
-out_list <- c(out_list, list(ref_fab_path = ref_fab_path, ref_cat = ref_cat,
- ref_fl = ref_fl, nwm_fl = nwm_fl))
-```
-
-NHDPlus Value-added attributes used to characterize the network and get
-information such as velocity and mean streamflow.
-
-```{r NHDPlusV2 VAA}
-# Waterbodies - derived after downloading and post-processing
-# NHDPlus Seamless National Geodatabase
-# Compacted here into a GDB
-VAA_fst_path <- file.path(nhdplus_dir, "nhdplusVAA.fst")
-VAA_rds_path <- file.path(nhdplus_dir, "nhd_vaa.rds")
-#TODO pull attributes needed for threshold POIs
-
-if(!file.exists(VAA_rds_path)) {
- message("downloading NHDPlusVAA...")
-
- download_vaa(VAA_fst_path)
+for (vpu in c("01", "08", "10L", "15", "02", "04", "05", "06", "07", "09",
+ "03S", "03W", "03N", "10U", "11", "12", "13", "14", "16",
+ "17", "18")) {
- # Extract other attributes
- nhdpv2_vaa <- read_sf(nhdplus_gdb, "NHDFlowline_Network") %>%
- st_drop_geometry()
-
- saveRDS(nhdpv2_vaa, file.path(nhdplus_dir, "nhd_vaa.rds"))
+ get_sb_file("6317a72cd34e36012efa4e8a",
+ paste0(vpu, "_reference_features.gpkg"),
+ ref_fab_path)
}
-out_list <- c(out_list, list(VAA_fst = VAA_fst_path, VAA_rds = VAA_rds_path))
-```
-
-NHDPlus Waterbody and Area Polygons converted to an RDS file for easier
-loading within R.
+get_sb_file("61295190d34e40dd9c06bcd7",
+ c("reference_catchments.gpkg", "reference_flowline.gpkg", "nwm_network.gpkg"),
+ out_destination = ref_fab_path)
-```{r NHDPlusV2 Waterbodies}
-# Waterbodies - derived after downloading and post-processing
-# NHDPlus Seamless National Geodatabase
-# Compacted here into a GDB
-waterbodies_path <- file.path(nhdplus_dir, "nhdplus_waterbodies.rds")
-if(!file.exists(waterbodies_path)) {
- message("formatting NHDPlus watebodies...")
-
- # Read the feature class
- wb_sf <- read_sf(nhdplus_gdb, "NHDWaterbody") %>%
- st_transform(proj_crs) %>%
- mutate(layer = "NHDWaterbody")
-
- wbarea_sf <- read_sf(nhdplus_gdb, "NHDArea") %>%
- st_transform(proj_crs) %>%
- mutate(layer = "NHDArea")
-
- wb_fc <- data.table::rbindlist(list(wb_sf, wbarea_sf), fill = TRUE) %>%
- st_as_sf()
-
- # Convert to simple feature and save out
- saveRDS(wb_fc, waterbodies_path)
-}
-
-out_list <- c(out_list, list(waterbodies_path = waterbodies_path))
+out_list <- c(out_list, list(ref_fab_path = ref_fab_path,
+ ref_cat = ref_cat, ref_fl = ref_fl, nwm_fl = nwm_fl))
```
Formatting a full list of network and non-network catchments for the NHDPlus
@@ -414,114 +294,37 @@ when aggregating at points of interest.
fullcat_path <- file.path(nhdplus_dir, "nhdcat_full.rds")
islandcat_path <- file.path(islands_dir, "nhdcat_full.rds")
-# Create full cat dataset
-if(!file.exists(fullcat_path)){
-
- cat_tab <- cat_rpu(out_list$ref_cat, nhdplus_gdb)
- saveRDS(cat_tab, fullcat_path)
-
- island_tab <- cat_rpu(out_list$islands_gdb, islands_gdb)
- saveRDS(island_tab, islandcat_path)
-}
+if(!file.exists(fullcat_path))
+ saveRDS(cat_rpu(out_list$ref_cat, nhdplus_gdb),
+ fullcat_path)
+
+if(!file.exists(islandcat_path))
+ saveRDS(cat_rpu(out_list$islands_gdb, islands_gdb),
+ islandcat_path)
-out_list <- c(out_list, list(fullcats_table = fullcat_path))
-out_list <- c(out_list, list(islandcats_table = islandcat_path))
+out_list <- c(out_list, list(fullcats_table = fullcat_path, islandcats_table = islandcat_path))
+
```
Download NHDPlusV2 FDR and FAC grids for refactoring and catcment splitting.
```{r NHDPlusV2 FDR_FAC}
# NHDPlus FDR/FAC grids available by raster processing unit
+# TODO: set this up for a per-region download for #134
+out_list<- c(out_list, make_fdr_fac_list(file.path(data_dir, "fdrfac")))
-fdr_fac_dir <- file.path(data_dir, "fdrfac")
-
-if(!dir.exists(fdr_fac_dir)) {
- dir.create(fdr_fac_dir, recursive = TRUE, showWarnings = FALSE)
-
- download_elev("FDRFAC", fdr_fac_dir)
-}
-
-dirs <- unique(dirname(list.files(fdr_fac_dir, recursive = TRUE,
- full.names = TRUE)))
-fdr <- dirs[grepl(".*/fdr$", dirs)]
-fac <- dirs[grepl(".*/fac$", dirs)]
-
-out <- list(fdr = list(), fac = list())
-
-rpu <- substr(fdr, (nchar(fdr) - 6), (nchar(fdr) - 4))
-
-out$fdr <- as.list(setNames(fdr, paste0("rpu_", rpu)))
-out$fac <- as.list(setNames(fac, paste0("rpu_", rpu)))
-
-out_list<- c(out_list, out)
```
Download NHDPlusV2 elevation grids for headwater extensions and splitting
catchments into left and right banks.
```{r NHDPlusV2 elev}
-# NHDPlus FDR/FAC grids available by raster processing unit
-
-elev_dir <- file.path(data_dir, "nhdplusv2_elev")
-
-if(!dir.exists(elev_dir)) {
- dir.create(elev_dir, recursive = TRUE, showWarnings = FALSE)
-
- download_elev("DEM", elev_dir)
-}
-
-dirs <- unique(dirname(list.files(elev_dir, recursive = TRUE,
- full.names = TRUE)))
-elev_cm <- dirs[grepl(".*/elev_cm$", dirs)]
-
-out <- list(elev_cm = list())
-
-rpu <- substr(elev_cm, (nchar(elev_cm) - 10), (nchar(elev_cm) - 8))
-
-out$elev_cm <- as.list(setNames(elev_cm, paste0("rpu_", rpu)))
-
-out_list<- c(out_list, out)
-```
-
-Download the current WBD snapshot.
-
-```{r WBD}
-# Snapshot of National WBD
-
-wbd_dir <- file.path(data_dir, "wbd")
-
-wbd_file <- "WBD_National_GDB"
-if(!dir.exists(wbd_dir)) {
-
- dir.create(wbd_dir, recursive = TRUE)
- wbd <- download.file(
- "https://prd-tnm.s3.amazonaws.com/StagedProducts/Hydrography/WBD/National/GDB/WBD_National_GDB.zip",
- destfile = file.path(wbd_dir, "WBD_National_GDB.zip"), mode = "wb")
-}
-
-out_gdb <- file.path(wbd_dir, paste0(wbd_file, ".gdb"))
-out <- list(latest_wbd = file.path(wbd_dir, "WBD.rds"))
+# NHDPlus elev grids available by raster processing unit
+# TODO: set this up for a per-region download for #134
+out_list<- c(out_list, make_nhdplus_elev_list(file.path(data_dir, "nhdplusv2_elev")))
-if(!file.exists(out$latest_wbd)) {
- wbd <- file.path(wbd_dir, paste0(wbd_file, ".zip"))
- system(paste0(sevenz, " x ", wbd, " -o", wbd_dir),
- ignore.stdout = TRUE, intern = TRUE)
-
- # Read the feature class
- wbdfc <- sf::read_sf(out_gdb,
- "WBDHU12") %>%
- st_as_sf() %>%
- st_transform(crs = proj_crs)
-
- saveRDS(wbdfc, out$latest_wbd)
-}
-
-out_rds <- list(latest_wbd_rds = out$latest_wbd)
-
-out_list <- c(out_list, out_rds)
```
-
Merrit Topographic and Hydrographic data for deriving GIS Features of the
National Hydrologic Modeling, Alaska Domain
@@ -536,72 +339,35 @@ National Hydrologic Modeling, Alaska Domain
merit_dir <- file.path(data_dir, "merged_AK_MERIT_Hydro")
-out <- list(merit_catchments = file.path(merit_dir, "merged_AK_MERIT_Hydro",
- "cat_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp"),
- merit_rivers = file.path(merit_dir, "merged_AK_MERIT_Hydro",
- "riv_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp"),
- aster_dem = file.path(merit_dir, "dem.tif"),
- merit_dem = file.path(merit_dir, "ak_merit_dem.tif"),
- merit_fdr = file.path(merit_dir, "ak_merit_fdr.tif"),
- merit_fac = file.path(merit_dir, "ak_merit_fac.tif"))
-
-if(!dir.exists(merit_dir)) {
- dir.create(merit_dir, recursive = TRUE, showWarnings = FALSE)
-
- m <- "merged_AK_MERIT_Hydro.zip"
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae", names = m,
- destinations = file.path(merit_dir, m))
-
- unzip(file.path(merit_dir, m), exdir = merit_dir)
-
- rm(m)
-
- get_sbfile <- function(f, itm) {
- if(!file.exists(o <- gsub("zip", "tif", f))) {
- check_auth()
- sbtools::item_file_download(itm, names = basename(f),
- destinations = f)
- }
- #unzip(f, exdir = merit_dir)
- system(paste0(sevenz, " x ", f, " -o", merit_dir), ignore.stdout = TRUE,
- intern = TRUE)
- return(o)
-
- }
-
- # Out folders
- out <- list(aster_dem = get_sbfile(file.path(merit_dir, "dem.zip"),
- "5fbbc6b6d34eb413d5e21378"),
- merit_dem = get_sbfile(file.path(merit_dir,
- "ak_merit_dem.zip"),
- "5fbbc6b6d34eb413d5e21378"),
- merit_fdr = get_sbfile(file.path(merit_dir,
- "ak_merit_fdr.zip"),
- "64ff628ed34ed30c2057b430"),
- merit_fac = get_sbfile(file.path(merit_dir,
- "ak_merit_fac.zip"),
- "64ff628ed34ed30c2057b430"))
-
- out <- list(aster_dem = get_sbfile(file.path(merit_dir, "dem.zip"), "5fbbc6b6d34eb413d5e21378"),
- merit_dem = get_sbfile(file.path(merit_dir,
- "ak_merit_dem.zip"), "5fc51e65d34e4b9faad8877b"),
- merit_fdr = get_sbfile(file.path(merit_dir,
- "ak_merit_fdr.zip"), "5fc51e65d34e4b9faad8877b"),
- merit_fac = get_sbfile(file.path(merit_dir,
- "ak_merit_fac.zip"), "5fc51e65d34e4b9faad8877b"))
-
-}
+get_sb_file("5dbc53d4e4b06957974eddae", "merged_AK_MERIT_Hydro.zip", merit_dir)
+# TODO: update to use "6644f85ed34e1955f5a42dc4" when released (roughly Dec 10,)
+get_sb_file("5fbbc6b6d34eb413d5e21378", "dem.zip", merit_dir)
+get_sb_file("64ff628ed34ed30c2057b430",
+ c("ak_merit_dem.zip", "ak_merit_fdr.zip", "ak_merit_fac.zip"),
+ merit_dir)
-out_list <- c(out_list, out)
-```
+out_list <- c(
+ out_list,
+ list(merit_catchments = file.path(merit_dir,
+ "merged_AK_MERIT_Hydro",
+ "cat_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp"),
+ merit_rivers = file.path(merit_dir,
+ "merged_AK_MERIT_Hydro",
+ "riv_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp"),
+ aster_dem = file.path(merit_dir, "dem.tif"),
+ merit_dem = file.path(merit_dir, "ak_merit_dem.tif"),
+ merit_fdr = file.path(merit_dir, "ak_merit_fdr.tif"),
+ merit_fac = file.path(merit_dir, "ak_merit_fac.tif")))
-Source data for deriving GIS Featurs of the National Hydrologic Modeling,
+```
+
+ Source data for deriving GIS Featurs of the National Hydrologic Modeling,
Alaska Domain
```{r AK GF Source data}
+# TODO: fix this citation
# Bock, A.R., Rosa, S.N., McDonald, R.R., Wieczorek, M.E., Santiago, M.,
# Blodgett, D.L., and Norton, P.A., 2024, Geospatial Fabric for National
# Hydrologic Modeling, Hawaii Domain: U.S. Geological Survey data release,
@@ -610,18 +376,10 @@ Alaska Domain
AK_GF_source <- "ak.7z"
AK_dir <- file.path(data_dir, "AK")
-if(!dir.exists(AK_dir)) {
- dir.create(AK_dir, recursive = TRUE)
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae", names = AK_GF_source,
- destinations = file.path(AK_dir, AK_GF_source))
-
- system(paste0(sevenz, " e -o", AK_dir, " ", file.path(AK_dir, AK_GF_source)))
-
-} else {
- out_ak <- list(ak_source = file.path(AK_dir, "ak.gpkg"))
- out_list <- c(out_list, out_ak)
-}
+get_sb_file("5dbc53d4e4b06957974eddae", AK_GF_source, AK_dir)
+
+out_list <- c(out_list, list(ak_source = file.path(AK_dir, "ak.gpkg")))
+
```
Source data for deriving GIS Featurs of the National Hydrologic Modeling,
@@ -633,80 +391,10 @@ Hawaii Domain
# Hydrologic Modeling, Hawaii Domain: U.S. Geological Survey data release,
# https://doi.org/10.5066/P9HMKOP8
-HI_GF_source <- "hi.7z"
-out_hi <- list(hi_source = file.path(islands_dir, "hi.gpkg"))
-
-if(!file.exists(file.path(islands_dir, "hi.gpkg"))) {
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae", names = HI_GF_source,
- destinations = file.path(islands_dir,
- HI_GF_source))
-
- system(paste0(sevenz, " e -o", islands_dir, " ",
- file.path(islands_dir, HI_GF_source)))
-}
-
-out_list <- c(out_list, out_hi)
-```
-
-National Water Model Network Topology
-
-```{r nwm_topology}
-nwm_targz_url <-
- "https://www.nohrsc.noaa.gov/pub/staff/keicher/NWM_live/NWM_parameters/NWM_parameter_files_v2.1.tar.gz"
-nwm_parm_url <-
- "https://www.nohrsc.noaa.gov/pub/staff/keicher/NWM_live/web/data_tools/NWM_v2.1_channel_hydrofabric.tar.gz"
-
-targz <- file.path(data_dir, basename(nwm_targz_url))
-
-out <- list(nwm_network = file.path(data_dir, "NWM_parameters_v2.1", "RouteLink_CONUS.nc"))
-
-if(!file.exists(out$nwm_network)) {
- options(timeout = 60000)
- download.file(nwm_targz_url, destfile = targz)
-
- utils::untar(targz, exdir = data_dir)
-
-}
-
-out_list <- c(out_list, out)
-
-parmtgz <- file.path(data_dir, basename(nwm_parm_url))
-
-out <- list(nwm_parm = file.path(data_dir,
- "NWM_v2.1_channel_hydrofabric_10262020",
- "nwm_v2_1_hydrofabric.gdb"))
-
-if(!file.exists(out$nwm_parm)) {
-
- download.file(nwm_parm_url, destfile = parmtgz)
-
- utils::untar(parmtgz, exdir = data_dir)
-
-}
-
-out_list <- c(out_list, out)
-
-```
-
-e2nhd Network Attributes
+get_sb_file("5dbc53d4e4b06957974eddae", "hi.7z", islands_dir)
-```{r nhdplus_attributes}
-# Blodgett, D.L., 2023, Updated CONUS river network attributes based on the
-# E2NHDPlusV2 and NWMv2.1 networks (ver. 2.0, February 2023): U.S. Geological
-# Survey data release, https://doi.org/10.5066/P976XCVT.
+out_list <- c(out_list, list(hi_source = file.path(islands_dir, "hi.gpkg")))
-out <- list(new_nhdp_atts = file.path("cache",
- (sb_f <- "enhd_nhdplusatts.csv")))
-
-if(!file.exists(out$new_nhdp_atts)) {
- check_auth()
- sbtools::item_file_download("63cb311ed34e06fef14f40a3",
- names = sb_f,
- destinations = out$new_nhdp_atts)
-}
-
-out_list <- c(out_list, out)
```
GIS Features of the Geospatial Fabric for National Hydrologic Modeling,
@@ -719,65 +407,41 @@ version 1.1, Transboundary Geospatial Fabric
# https://doi.org/10.5066/P971JAGF.
GFv11_dir <- file.path(data_dir, "GFv11")
+
out <- list(GFv11_gages_lyr = file.path(data_dir, "GFv11/GFv11_gages.rds"),
GFv11_gdb = file.path(GFv11_dir, "GFv1.1.gdb"),
GFv11_tgf = file.path(GFv11_dir, "TGF.gdb"))
-# Download the GFv1.1 geodatabase
-if(!dir.exists(GFv11_dir)) {
- dir.create(GFv11_dir, recursive = TRUE)
- check_auth()
- sbtools::item_file_download("5e29d1a0e4b0a79317cf7f63",
- names = "GFv1.1.gdb.zip",
- destinations = file.path(GFv11_dir,
- "GFv1.1.gdb.zip"))
-
- tgf_f <- file.path(GFv11_dir, "TGF.gdb.zip")
- check_auth()
- sbtools::item_file_download("5d967365e4b0c4f70d113923",
- names = basename(tgf_f),
- destinations = tgf_f)
-
- unzip(file.path(GFv11_dir, "GFv1.1.gdb.zip"), exdir = GFv11_dir)
- unzip(tgf_f, exdir = GFv11_dir)
-
- file.remove(tgf_f)
+get_sb_file("5e29d1a0e4b0a79317cf7f63", "GFv1.1.gdb.zip", GFv11_dir, check_path = out$GFv11_gdb)
+
+get_sb_file("5d967365e4b0c4f70d113923", "TGF.gdb.zip", GFv11_dir, check_path = out$GFv11_tgf)
+
+if(!file.exists(out$GFv11_gages_lyr)) {
# Extract gages
- GFv11_gages <- read_sf(out$GFv11_gdb, "POIs_v1_1") %>%
- filter(Type_Gage != 0)
-
- saveRDS(GFv11_gages, out$GFv11_gages_lyr)
+ read_sf(out$GFv11_gdb, "POIs_v1_1") |>
+ filter(Type_Gage != 0) |>
+ saveRDS(out$GFv11_gages_lyr)
- file.remove(file.path(GFv11_dir, "GFv1.1.gdb.zip"))
}
out_list <- c(out_list, out)
+
if(mapview)(mapview(readRDS(out_list$GFv11_gages_lyr)))
```
GAGESII dataset
```{r Gages_II}
-# https://doi.org/10.3133/70046617
+# Falcone, J., 2011, GAGES-II: Geospatial Attributes of Gages for Evaluating
+# Streamflow: U.S. Geological Survey data release, https://doi.org/10.5066/P96CPHOT.
-if(!dir.exists(SWIM_points_path))
- dir.create(SWIM_points_path, recursive = TRUE)
+SWIM_points_path <- file.path(data_dir, "SWIM_gage_loc")
-g2_out <- list(gagesii_lyr = file.path(SWIM_points_path,
- "gagesII_9322_point_shapefile"))
+get_sb_file("631405bbd34e36012efa304a", "gagesII_9322_point_shapefile.zip", SWIM_points_path)
-gagesII_url <- "https://water.usgs.gov/GIS/dsdl/gagesII_9322_point_shapefile.zip"
-
-zip <- file.path(SWIM_points_path, basename(gagesII_url))
-
-if(!file.exists(g2_out$gagesii_lyr)) {
-
- download.file(gagesII_url, destfile = zip)
-
- unzip(zip, exdir = g2_out$gagesii_lyr)
-}
+out_list <- c(out_list, list(
+ gagesii_lyr = file.path(SWIM_points_path, "gagesII_9322_point_shapefile")))
-out_list <- c(out_list, g2_out)
if(mapview)(mapview(read_sf(out_list$gagesii_lyr)))
```
@@ -791,27 +455,18 @@ locations
# DOI: https/doi.org/10.21951/HILARRI/1960141
hilarri_dir <- file.path(data_dir, "HILARRI")
-hilarri_out <- list(hilari_sites = file.path(hilarri_dir, "HILARRI_v2.csv"))
+hilarri_out <- list(hilarri_sites = file.path(hilarri_dir, "HILARRI_v2.csv"))
-# Download the HILARRI points
-if(!dir.exists(hilarri_dir))
- dir.create(hilarri_dir, recursive = TRUE)
+download_file("https://hydrosource.ornl.gov/sites/default/files/2023-03/HILARRI_v2.zip",
+ out_path = hilarri_dir, check_path = hilarri_out$hilari_sites)
-hilarri_url <- "https://hydrosource.ornl.gov/sites/default/files/2023-03/HILARRI_v2.zip"
-
-if(!file.exists(file.path(hilarri_dir, "HILARRI_v2.csv"))){
- download.file(hilarri_url,
- dest = file.path(hilarri_dir, basename(hilarri_url)),
- mode = "wb")
-
- unzip(file.path(hilarri_dir, basename(hilarri_url)), exdir = hilarri_dir)
-}
out_list <- c(out_list, hilarri_out)
-if(mapview){
- hill_sf <- st_as_sf(read.csv(out_list$hilari_sites),
- coords = c("longitude", "latitude"), crs = 4326)
- mapview(hill_sf)}
+if(mapview) {
+ mapview(st_as_sf(read.csv(out_list$hilarri_sites),
+ coords = c("longitude", "latitude"),
+ crs = 4326))
+}
```
@@ -831,51 +486,51 @@ ResOpsUS dataset and indexed locations
# management. Frontiers in Ecology and the Environment 9 (9): 494-502.
# https://ln.sync.com/dl/bd47eb6b0/anhxaikr-62pmrgtq-k44xf84f-pyz4atkm/view/default/447819520013
+res_path <- file.path(data_dir,"reservoir_data")
+
# Set Data download links
res_att_url <- "https://zenodo.org/record/5367383/files/ResOpsUS.zip?download=1"
# ISTARF - Inferred Storage Targets and Release Functions for CONUS large reservoirs
istarf_url <- "https://zenodo.org/record/4602277/files/ISTARF-CONUS.csv?download=1"
# Download GRanD zip from above
-GRanD_zip <- "GRanD_Version_1_3.zip"
+GRanD_zip <- file.path(res_path, "GRanD_Version_1_3.zip")
-# - ResOpsUS - reservoir operations
-res_path <- file.path(data_dir,"reservoir_data")
-if(!dir.exists(res_path))
- dir.create(res_path, recursive = TRUE)
-the_ex_dir <- file.path(res_path, "ResOpsUS")
-tab_out <- list(res_attributes = file.path(the_ex_dir, "attributes",
- "reservoir_attributes.csv"))
-# Download istarf data
+download_file(res_att_url, res_path, file_name = "ResOpsUS.zip")
+
+out_list <- c(out_list,
+ list(res_attributes = file.path(res_path, "ResOpsUS", "attributes",
+ "reservoir_attributes.csv")))
+
istarf_csv <- file.path(res_path, "ISTARF-CONUS.csv")
-if(!file.exists(istarf_csv)) {
- download.file(istarf_url, destfile = istarf_csv, mode = "wb")
-}
-tab_out <- list(istarf = istarf_csv)
-out_list <- c(out_list, tab_out)
+
+download_file(istarf_url, res_path, istarf_csv, file_name = "ISTARF-CONUS.csv")
+
+out_list <- c(out_list, list(istarf = istarf_csv))
+
+grand_dir <- file.path(res_path, "GRanD_Version_1_3")
# Extract GRanD data
-if(!file.exists(GRanD_zip)) {
- # set mode wb for a file of type zip
- unzip(file.path(res_path, GRanD_zip), exdir = res_path)
-} else {
- print("Download GRanD data")
+if(!dir.exists(grand_dir)) {
+ if(!file.exists(GRanD_zip))
+ stop("Download GRanD data from https://ln.sync.com/dl/bd47eb6b0/anhxaikr-62pmrgtq-k44xf84f-pyz4atkm/view/default/447819520013 to ",
+ res_path)
+
+ unzip(GRanD_zip, exdir = res_path)
}
-out_list <- c(out_list, tab_out)
-# crosswalk of selected (fit %in% c("full", "storage_only") 595 ResOpsUS to NID
-# - derived by msant and abock; currently hosted at GFv2 POI Source data page
+out_list <- c(out_list, list(GRanD = grand_dir))
+
resops_to_nid_path <- file.path(res_path, "cw_ResOpsUS_NID.csv")
-if(!file.exists(resops_to_nid_path)) {
- check_auth()
- sbtools::item_file_download("5dbc53d4e4b06957974eddae",
- names = "cw_ResOpsUS_NID.csv",
- destinations = resops_to_nid_path)
-}
+get_sb_file("5dbc53d4e4b06957974eddae", "cw_ResOpsUS_NID.csv", dirname(resops_to_nid_path))
+
+istarf_xwalk_path <- file.path(res_path, "istarf_xwalk_final_48_gfv11.csv")
+
+get_sb_file("5dbc53d4e4b06957974eddae", "istarf_xwalk_final_48_gfv11.csv", dirname(istarf_xwalk_path))
+
+out_list <- c(out_list, list(resops_NID_CW = resops_to_nid_path, istarf_xwalk = istarf_xwalk_path))
-tab_out <- list(resops_NID_CW = resops_to_nid_path)
-out_list <- c(out_list, tab_out)
```
All Hydro-linked Network Data Index (NLDI) datasets
@@ -886,23 +541,13 @@ All Hydro-linked Network Data Index (NLDI) datasets
nldi_dir <- file.path(data_dir, "nldi")
-# Download the HILARRI points
-if(!dir.exists(nldi_dir))
- dir.create(nldi_dir, recursive = TRUE)
-
-nldi_list <- item_list_files("60c7b895d34e86b9389b2a6c", recursive = FALSE,
- fetch_cloud_urls = TRUE)
-
-for (fname in nldi_list$fname){
- print(fname)
- floc <- file.path(nldi_dir, fname)
- if(!file.exists(floc)){
- #check_auth()
- sbtools::item_file_download("60c7b895d34e86b9389b2a6c",
- names = fname,
- destinations = floc)
- }
-}
+get_sb_file("60c7b895d34e86b9389b2a6c", "all", nldi_dir)
+
+out_list <- c(
+ out_list,
+ list(usgs_nldi_gages = file.path(nldi_dir, "usgs_nldi_gages.geojson"))
+)
+
```
```{r}
diff --git a/workspace/01_Gage_Selection.Rmd b/workspace/01_Gage_Selection.Rmd
deleted file mode 100644
index f7c247f65542cdb8e751279cac302a5a039a6572..0000000000000000000000000000000000000000
--- a/workspace/01_Gage_Selection.Rmd
+++ /dev/null
@@ -1,425 +0,0 @@
----
-title: "Gage Selection"
-output: html_document
----
-This notebook builds a final set of gages for GFv2.0 from data sources assembled in 00_gage_info.rmd
-
-```{r setup_0, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width = 6,
- fig.height = 4,
- cache = FALSE)
-```
-
-```{r setup}
-# Load data and libraries
-library(nhdplusTools)
-library(dplyr)
-library(readxl)
-library(sf)
-library(hyRefactor)
-library(tidyr)
-library(foreign)
-library(hyfabric)
-library(mapview)
-
-# Load custom functions
-source("R/utils.R")
-source("R/NHD_navigate.R")
-# Gages which are manually inspected from "Gages_to_check" file and added back in
-source("R/config.R")
-source("R/user_vars.R")
-source("R/gage_mod.R")
-
-# Load user-defined data paths
-data_paths <- jsonlite::read_json(file.path("cache", "data_paths.json"))
-# Load NHDPlus Data if precprocessed to RDS format
-nhdplus_path(data_paths$nhdplus_gdb)
-# Load NHD
-nhd <- read_sf(data_paths$ref_fl)
-
-# clear dropped gages file
-if(file.exists("cache/dropped_gages.csv")){
- file.remove("cache/dropped_gages.csv")
-}
-# gages II
-gages_ii <- read_sf(data_paths$gagesii_lyr)
-ref_gages <- read_sf("data/nldi/usgs_nldi_gages.geojson")
-gages_ii_ref <- filter(ref_gages, id %in%
- filter(gages_ii, CLASS == "Ref")$STAID)
-```
-
-```{r GAGESIII-SWIM}
-# Read gagesIII dbf that is a POR summary produced from 00_gage_info.Rmd
-gagesIII_db_full <- read.dbf(file = file.path(data_paths$data_dir, "SWIMGFinfo.dbf"), as.is = TRUE) %>%
- rename(total_obs = count_nu, total_poss_obs = TPdays1)
-
-# Read in shapefile
-gagesIII_sf_full <- read_sf(data_paths$SWIM_points_path, "SWIM_gage_loc") %>%
- st_zm(drop = TRUE) %>%
- # Use site_no as the authoritative station ID name
- rename(site_no = Gage_no) %>%
- # Drop fields in NLDI gages
- select(-c(COMID, REACHCODE, REACH_meas)) %>%
- # Join to NLDI reference gages
- left_join(select(st_drop_geometry(ref_gages), id, comid = nhdpv2_COMID,
- reachcode = nhdpv2_REACHCODE,
- reach_meas = nhdpv2_REACH_measure),
- by = c("site_no" = "id"))
-
-# Read Gages III shapefile
-gagesIII_sf <- gagesIII_sf_full %>%
- # Get rid of invalid COMIDs, for multiple site IDs get one with the furthest reach measure downstream
- filter(comid > 0, site_no %in% gagesIII_db_full$site_no) %>%
- # There are some rows with dupslicate site_no, drainage area, and POR infomrmation
- group_by(site_no) %>%
- slice(which.min(reach_meas)) %>%
- # There were some duplicate rows that needed to be removed
- select(site_no, comid, reachcode, reach_meas) %>%
- distinct()
-
-# Start documenting gages that are dropped out; these gages have no mean daily Q
-gage_document(filter(select(st_drop_geometry(gagesIII_sf_full), site_no),
- !site_no %in% gagesIII_sf$site_no),
- "GAGES-III", "No Q or COMID")
-
-# First subset
-gagesIII_db <- gagesIII_db_full %>%
- # Get rid of inital fields we are not interested in,
- select(-c(agency_cd, ts_id)) %>%
- # Constrain by date and/or POR
- filter(end_date > POR_Start | total_obs > min_obs,
- # remove site codes associated with canals, ditchest, etc
- !site_tp_cd %in% c("ST-CA", "ST-DCH", "FA-STS"),
- # keep sites with daily mean streamflow parameter
- stat_cd == "00003") %>%
- distinct()
-
-# Gages that don't fit the POR requirement, or are non-ST site types
-gage_document(filter(select(st_drop_geometry(gagesIII_sf), site_no),
- !site_no %in% gagesIII_db$site_no),
- "GAGES-III", "Non-ST; POR")
-
-# scan for potential canals/ditches among the remaining ST site types
-potCanalsIII <- gagesIII_db %>%
- # Flag station_nm with the follwing words
- filter(grepl(paste(c("DITCH", "ditch", "CANAL", "canal", "CN", "DIV", "div"),
- collapse = "|"), station_nm)) %>%
- # Remove the station_nm with the following
- filter(!grepl(paste(c("RIVER AT", "RIVER BELOW", "RIVER BL", "R AB", "R BL", "R ABV"),
- collapse = "|"),
- station_nm, ignore.case = TRUE)) %>%
- # These have been manually checked and are located in config.R
- filter(!site_no %in% gages_add)
-
-# Write out for manual checking
-if(!file.exists("temp/GagestoCheck_GAGESIII.csv")){
- write.csv(potCanalsIII, "temp/GagestoCheck_GAGESIII.csv")
-} else {
- potCanalsIII <- read.csv("temp/GagestoCheck_GAGESIII.csv")
-}
-
-# Subset further by streamgages below the minimum drainage area critera
-gagesIII_db_fin <- gagesIII_db %>%
- filter(!site_no %in% potCanalsIII$site_no, drain_area > (min_da_km_gages * sqkm_sqmi))
-
-# Write out gages that dropped to document.
-gage_document(select(potCanalsIII, site_no), "GAGES-III", "ST; Pot. Canal")
-gage_document(gagesIII_db %>%
- filter(!site_no %in% potCanalsIII$site_no,
- drain_area < min_da_km_gages) %>%
- select(site_no),
- "GAGES-III", "below DA")
-
-# Join shapefile to POR table
-gagesIII_final <- gagesIII_sf %>%
- inner_join(gagesIII_db_fin, by = "site_no") %>%
- select(-c(coord_acy_, huc_cd, parm_cd, stat_cd, missing_da, site_tp_cd)) %>%
- mutate(source = "gagesIII") %>%
- # deal with one duplicate row
- group_by(site_no) %>%
- filter(total_obs == max(total_obs)) %>%
- ungroup() %>%
- st_transform()
-
-# Visualize results
-mapview(gagesIII_sf_full, layer.name = "all GAGES-III") +
- mapview(filter(gagesIII_sf_full, !site_no %in% gagesIII_sf$site_no),
- layer.name = "No Q; COMID", col.regions = "red") +
- mapview(filter(gagesIII_sf, !site_no %in% gagesIII_db$site_no),
- layer.name = "Non-ST; POR", col.regions = "purple") +
- mapview(filter(gagesIII_sf, site_no %in% potCanalsIII$site_no),
- layer.name = "Canals, man. checked", col.regions = "blue") +
- mapview(filter(gagesIII_sf %>%
- inner_join(select(gagesIII_db, site_no, drain_area),
- by = "site_no"), drain_area < min_da_km_gages),
- layer.name = "below min DA", col.regions = "green") +
- mapview(gagesIII_final, layer.name = "Final GAGES-III", col.regions = "orange")
-
-```
-
-```{r GageLoc}
-# Read gages3 dbf that is a POR summary produced from 00_gage_info.Rmd
-gageloc_db_full <- read.dbf(file = file.path(data_paths$data_dir, "GageLocGFinfo.dbf"), as.is = TRUE) %>%
- rename(total_obs = count_nu, total_poss_obs = TPdays1)
-
-# Read in shapefile
-gageloc_sf_full <- read_sf(data_paths$nhdplus_gdb, "Gage") %>%
- # Drop Z geometries
- st_zm(drop = TRUE) %>%
- rename(site_no = SOURCE_FEA) %>%
- select(-c(FLComID, REACHCODE, Measure)) %>%
- # Disregard locations already removed in GAGESIII
- filter(!site_no %in% gagesIII_sf_full$site_no) %>%
- # Update index information with NLDI gages
- left_join(select(st_drop_geometry(ref_gages), site_no = id,
- comid = nhdpv2_COMID, reachcode = nhdpv2_REACHCODE,
- reach_meas = nhdpv2_REACH_measure ), by = "site_no")
-
-# Subset to locations with streamflow
-gageloc_sf <- gageloc_sf_full %>%
- # Get rid of invalid COMIDs, for multiple site IDs get one with the furthest reach measure downstream
- filter(site_no %in% gageloc_db_full$site_no) %>%
- # Like GAGES-III, multiple site_no
- group_by(site_no) %>%
- slice(which.min(reach_meas)) %>%
- # There were some duplicate rows that needed to be removed
- select(site_no, comid, reachcode, reach_meas) %>%
- distinct()
-
-# Start documenting gages that are dropped out; these gages have no mean daily Q
-gage_document(filter(select(st_drop_geometry(gageloc_sf_full), site_no),
- !site_no %in% gageloc_sf$site_no),
- "GageLoc", "No Q, COMID")
-
-# do the same exercise with GageLoc, but with more site type attributes to filter out
-gageloc_db <- gageloc_db_full %>%
- filter(end_date > POR_Start | total_obs > min_obs,
- !site_tp_cd %in%
- c("ST-CA", "ST-DCH", "FA-STS", "SB_TSM", "FA-DV", "FA-STS", "FA-CS",
- "FA-WWD", "FA-OF", "GW"), stat_cd == "00003") %>%
- # Some sites are listed twice with same information but different agencies,
- select(-c(agency_cd, ts_id)) %>%
- distinct(site_no, drain_area, dec_lat_va, dec_long_v, .keep_all = T)
-
-# Gages that don't fit the POR requirement, or are non-ST site types
-gage_document(filter(select(gageloc_db_full, site_no),
- !site_no %in% gageloc_db$site_no),
- "GageLoc", "Non-ST; POR")
-
-# scan for potential canals/ditches
-potCanals_gageloc <- gageloc_db %>%
- filter(grepl(paste(c("DITCH", "ditch", "CANAL", "canal", "CN", "DIV", "div"),
- collapse = "|"), station_nm)) %>%
- filter(!site_no %in% gages_add)
-
-# Write out for manual checking
-if(!file.exists("temp/GagestoCheck_GageLoc.csv")){
- write.csv(potCanals_gageloc, "temp/GagestoCheck_GageLoc.csv")
-} else {
- potCanals_gageloc <- read.csv("temp/GagestoCheck_GageLoc.csv")
-}
-
-gageloc_db_fin <- gageloc_db %>%
- filter(!site_no %in% potCanals_gageloc$site_no, drain_area >
- (min_da_km_gages * sqkm_sqmi))
-
-# Gages that are ST site types, but reside on canals, artificial waterbodies.
-gage_document(select(potCanals_gageloc, site_no), "GageLoc", "ST; Pot. Canal")
-gage_document(gageloc_db_fin %>%
- filter(!site_no %in% potCanals_gageloc$site_no,
- drain_area < min_da_km_gages) %>% select(site_no),
- "GageLoc", "below DA")
-
-# NHD gages shpafile
-gageloc_final <- gageloc_sf %>%
- inner_join(gageloc_db_fin, by = "site_no") %>%
- select(-c(coord_acy_, huc_cd, parm_cd, stat_cd, missing_da, site_tp_cd)) %>%
- st_as_sf(coords = c("dec_long_v", "dec_lat_va")) %>%
- mutate(source = "GageLoc") %>%
- # deal with one duplicate row
- group_by(site_no) %>%
- filter(total_obs == max(total_obs)) %>%
- ungroup() %>%
- st_sf() %>%
- st_compatibalize(gagesIII_final)
-
-mapview(gageloc_sf_full, layer.name = "all GageLoc") +
- mapview(filter(gageloc_sf_full, !site_no %in% gageloc_sf$site_no),
- layer.name = "No Q; COMID", col.regions = "red") +
- mapview(filter(gageloc_sf, !site_no %in% gageloc_db$site_no),
- layer.name = "Non-ST; POR", col.regions = "purple") +
- mapview(filter(gageloc_sf, site_no %in% potCanals_gageloc$site_no),
- layer.name = "Canals, man. checked", col.regions = "blue") +
- mapview(filter(gageloc_sf %>%
- inner_join(select(gageloc_db, site_no, drain_area), by = "site_no"),
- drain_area < min_da_km_gages),
- layer.name = "below min DA", col.regions = "green") +
- mapview(gageloc_final, layer.name = "Final GageLoc", col.regions = "orange")
-```
-
-```{r Gfv11}
-# Integrate GFv11 locations not included in GagesLoc and/or gagesIII
-gfv11_sf_full <- readRDS(data_paths$GFv11_gages_lyr) %>%
- st_zm(drop = TRUE) %>%
- st_transform(st_crs(gageloc_final))
-
-# Filter to sites not in GagesIII or GageLoc
-gfv11_db_full <- read.dbf(file = file.path(data_paths$data_dir, "GFV11.dbf"), as.is = TRUE) %>%
- #filter(site_no %in% gfv11_sf_full$site_no) %>%
- select(-c(agency_cd, site_tp_cd, coord_acy_, huc_cd, parm_cd, stat_cd, ts_id, missing_da)) %>%
- rename(total_obs = count_nu, total_poss_obs = TPdays1)
-
-# Remove transboundary
-gfv11_sf <- gfv11_sf_full %>%
- # Remove streamgages assocaited with transboundary
- filter(nchar(NHD_Unit) < 4,
- !Type_Gage %in% c(gagesIII_final$site_no, gageloc_final$site_no)) %>%
- select(site_no = Type_Gage, NHDPlusID) %>%
- # join to get comid, reachcode, measure data
- left_join(st_drop_geometry(gageloc_sf_full), by = "site_no") %>%
- # Know from previous work 3 locations with no COM/RC/M
- left_join(select(st_drop_geometry(nhd), COMID, REACHCODE, FromMeas),
- by = c("NHDPlusID" = "COMID")) %>%
- # bring over RC/M for 3 gages missing them
- mutate(comid = ifelse(is.na(comid), NHDPlusID, comid),
- reachcode = ifelse(is.na(reachcode), REACHCODE, reachcode),
- reach_meas = ifelse(is.na(reach_meas), FromMeas, reach_meas)) %>%
- select(-c(NHDPlusID, REACHCODE, FromMeas)) %>%
- # Update index information with NLDI gages
- left_join(select(st_drop_geometry(ref_gages),
- id, nhdpv2_COMID, nhdpv2_REACHCODE, nhdpv2_REACH_measure),
- by = c("site_no" = "id")) %>%
- mutate(comid = ifelse(!is.na(nhdpv2_COMID), nhdpv2_COMID, comid),
- reachcode = ifelse(!is.na(nhdpv2_REACHCODE),
- nhdpv2_REACHCODE, reachcode),
- reach_meas = ifelse(!is.na(nhdpv2_REACH_measure),
- nhdpv2_REACH_measure, reach_meas)) %>%
- select(site_no, comid, reachcode, reach_meas) %>%
- filter(!is.na(comid)) %>%
- st_sf()
-
-# get NWIS, non-GF lat lon for GFv11 gages
-gfv11_nwis <- dataRetrieval::readNWISsite(gfv11_sf$site_no) %>%
- filter(agency_cd == "USGS") %>%
- select(site_no, dec_long_va, dec_lat_va) %>%
- st_as_sf(coords = c("dec_long_va", "dec_lat_va"), crs = 4269)
-
-# Bring NWIS geometries over to GFv11 data
-gfv11_sf_final <- st_drop_geometry(gfv11_sf) %>%
- inner_join(gfv11_nwis, by = "site_no") %>%
- st_as_sf()
-
-# Build list of STAID - Drainage area for use in the GFv11 section
-# combine DA data from dbf outputs from 00_get_data
-DA_data <- rbind(select(gfv11_db_full, site_no, drain_area),
- select(gageloc_db_full, site_no, drain_area),
- select(gagesIII_db_full, site_no, drain_area)) %>%
- dplyr::filter(!is.na(drain_area)) %>%
- dplyr::rename(drain_area_full = drain_area) %>%
- dplyr::filter(site_no %in% gfv11_sf_final$site_no) %>%
- distinct()
-
-# final Gfv11 file, rebuild geometry
-gfv11_final <- gfv11_sf_final %>%
- left_join(gfv11_db_full, by = "site_no") %>%
- mutate(source = "GFv11") %>%
- left_join(DA_data, by = "site_no") %>%
- dplyr::mutate(drain_area = if_else(is.na(drain_area), drain_area_full, drain_area)) %>%
- select(-drain_area_full) %>%
- st_compatibalize(gagesIII_final)
-
-# Gages that don't fit the POR requirement, or are non-ST site types
-gage_document(filter(st_drop_geometry(gfv11_sf) %>% select(site_no), !site_no %in% gfv11_db_full$site_no),
- "GFv11", "No Q")
-
-mapview(gfv11_final, layer.name = "gfv11")
-```
-
-```{r Wrapup}
-# Bind them together
-gage_final <- data.table::rbindlist(list(gagesIII_final, gageloc_final,
- gfv11_final)) %>%
- st_as_sf()
-
-# which gagesii_ref gages are missing from final set
-missing_gagesii_ref <- filter(gages_ii_ref, !id %in% gage_final$site_no) %>%
- rename(site_no = id, comid = nhdpv2_COMID, reachcode = nhdpv2_REACHCODE,
- reach_meas = nhdpv2_REACH_measure) %>%
- inner_join(gageloc_db_full, by = "site_no") %>%
- select(-c(agency_cd, site_tp_cd, coord_acy_, huc_cd, parm_cd, stat_cd, ts_id, missing_da)) %>%
- st_compatibalize(gage_final)
-
-# Append those with data to gage_final
-gage_final <- data.table::rbindlist(list(gage_final, missing_gagesii_ref), fill = TRUE) %>%
- st_as_sf()
-
-# Rank multiple gages that occur on same COMID
-gage_final_ranked <- gage_final %>%
- filter(!is.na(comid)) %>%
- group_by(comid) %>%
- mutate(n = n()) %>%
- # Arrange by number of days
- arrange(total_obs, .by_group = TRUE) %>%
- # Populate by rank (1 - lowest number of days to n(highest))
- mutate(gage_score = ifelse(n > 1, row_number(), 1)) %>%
- # If a reference gage is one of gages, bump that to the top
- rowwise() %>%
- mutate(gage_score = ifelse(n > 1,
- ifelse(!is.na(gagesII_cl) && gagesII_cl == "Ref",
- max(gage_score) + 1, gage_score), gage_score)) %>%
- ungroup() %>%
- # Some gages have multiple gages with same days (inlets/outlets around dam)
- # This further prioritizes to the gage with the smallest reach measure (furthest downstream)
- group_by(comid, total_obs) %>%
- mutate(n = n()) %>%
- arrange(reach_meas, .by_group = TRUE) %>%
- rowwise() %>%
- mutate(gage_score = ifelse(n > 1,
- ifelse(reach_meas == min(reach_meas), max(gage_score) + 1, gage_score), gage_score)) %>%
- ungroup() %>%
- group_by(comid) %>%
- mutate(n = n()) %>%
- arrange(end_date, -reach_meas) %>%
- rowwise() %>%
- mutate(gage_score = ifelse(n > 1,
- ifelse(end_date == max(end_date), max(gage_score) + 1, gage_score), gage_score)) %>%
- ungroup() %>%
- select(-n) %>%
- st_transform(geo_crs)
-
-# conver to emtpy strings
-write_sf(gage_final_ranked, gage_info_gpkg, "Gages")
-
-# Format csv and csvt file
-# Convert geometry to WKT format
-gage_final_ranked <- st_as_sf(gage_final_ranked, wkt = "geometry")
-
-# Format to WKT geometry field
-gage_final_ranked$WKT <- paste0("POINT", noquote('('), data.frame(st_coordinates(gage_final_ranked))$X, ' ',
- data.frame(st_coordinates(gage_final_ranked))$Y, noquote(')'))
-
-# Classes of columns
-gage_final_ranked_csvt <- unlist(sapply(st_drop_geometry(gage_final_ranked), class))
-# replace names
-gage_final_ranked_csvt <- gage_final_ranked_csvt[names(gage_final_ranked_csvt) != "WKT"]
-gage_final_ranked_csvt <- gsub("character", "String", gage_final_ranked_csvt)
-gage_final_ranked_csvt <- gsub("numeric", "Real", gage_final_ranked_csvt)
-gage_final_ranked_csvt <- gsub("Date", "Date (YYYY-MM-DD)", gage_final_ranked_csvt)
-
-# write csv
-write.csv(st_drop_geometry(gage_final_ranked), gage_info_csv, row.names = F, quote = F)
-
-# Write csvt
-csvt_names <- as.matrix(t(unname(gage_final_ranked_csvt)))
-write.table(csvt_names, file = gage_info_csvt, sep = ",",
- col.names = FALSE, row.names = F)
-
-mapview(gage_final_ranked, layer.name = "GFv2.0 streamgages", zcol = "source")
-```
-
-
-
-
diff --git a/workspace/01_NHD_prep.Rmd b/workspace/01_NHD_prep.Rmd
deleted file mode 100644
index c21d5108cc81e0e55c6daebb16406d7887e12ae3..0000000000000000000000000000000000000000
--- a/workspace/01_NHD_prep.Rmd
+++ /dev/null
@@ -1,167 +0,0 @@
----
-title: "NHD Prep"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-Prepares the NHD network for navigate and refactor. Adds base layers to the reference fabric.
-
-```{r setup_rmd, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=6,
- fig.height=4,
- cache=FALSE)
-```
-
-```{r setup}
-# Load custom functions
-source("R/utils.R")
-source("R/NHD_navigate.R")
-
-# Load Configuration of environment
-source("R/config.R")
-source("R/user_vars.R")
-
-if(exists("rpu_code")){rm(rpu_code)}
-
-if(!exists("vpu_codes")) {
- vpu_codes <- unique(rpu_vpu$vpuid)
-} else {
- rpu_vpu <- filter(rpu_vpu, vpuid %in% vpu_codes)
-}
-
-all_rpu_codes <- unique(rpu_vpu$rpuid)
-full_cat_table <- readRDS(data_paths$fullcats_table)
-
-out_vpu <- rep(list(list()), length(vpu_codes))
-names(out_vpu) <- vpu_codes
-
-out_rpu <- rep(list(list()), length(all_rpu_codes))
-names(out_rpu) <- all_rpu_codes
-
-fline <- sf::read_sf(ref_gpkg, "flowlines")
-catchment <- sf::read_sf(ref_gpkg, "catchments")
-waterbodies <- sf::read_sf(ref_gpkg, "waterbodies")
-full_cat_table <- readRDS(data_paths$fullcats_table)
-
-# we can remove truely degenerate COMIDs
-# for 0 upstream area and no catchment area
-degen_comid <- fline[fline$TotDASqKM == 0 &
- !fline$COMID %in% catchment$featureid, ]$COMID
-
-# need to make sure we don't disconnect anything.
-keep_tocomid <- fline$toCOMID[!fline$COMID %in% degen_comid]
-
-if(length(degen_comid[degen_comid %in% keep_tocomid]) > 0) stop("this will break the network")
-
-fline <- fline[!fline$COMID %in% degen_comid, ]
-
-# there are some duplicates with enhd
-nhd <- fline %>%
- group_by(COMID) %>%
- filter(row_number() == 1) %>%
- ungroup() %>%
- make_standalone()
-
-# Filter and write dendritic/non-coastal subset to gpkg
-# This will be iterated over to produce the final network after POIs identified
-zero_order <- filter(nhd, TerminalFl == 1 & TotDASqKM < min_da_km_gages)
-non_dend <- unique(unlist(lapply(zero_order$COMID, NetworkNav, nhdDF = st_drop_geometry(nhd))))
-nhd <- nhd %>%
- mutate(dend = ifelse(!COMID %in% non_dend, 1, 0),
- poi = ifelse(!COMID %in% non_dend & TotDASqKM >= min_da_km_gages, 1, 0))
-
-cat_network <- sf::st_drop_geometry(nhd)
-names(cat_network) <- tolower(names(cat_network))
-cat_network <- select(cat_network, comid, tocomid, lengthkm, areasqkm, totdasqkm,
- hydroseq, levelpathi, terminalpa, dnlevelpat, dnhydroseq,
- reachcode, frommeas, tomeas, pathlength, arbolatesu,
- ftype, fcode, vpuid, rpuid, wbareacomi)
-
-write_sf(nhd, nav_gpkg, nhd_flowline)
-write_sf(cat_network, nav_gpkg, nhd_network)
-write_sf(waterbodies, nav_gpkg, nhd_waterbody)
-
-cats_rpu <- full_cat_table %>%
- filter(RPUID %in% rpu_codes$rpuid)
-
-cats <- catchment %>%
- rename(FEATUREID = featureid,
- AREASQKM = areasqkm) %>%
- mutate(VPUID = vpu_codes) %>%
- left_join(select(cats_rpu, FEATUREID, RPUID), by = c("FEATUREID")) %>%
- filter(FEATUREID %in%
- unique(c(nhd$COMID,
- full_cat_table$FEATUREID[full_cat_table$RPUID %in% rpu_codes$rpuid]))) %>%
- mutate(hy_cats = ifelse(FEATUREID %in% nhd$COMID, 1, 0),
- full_cats = ifelse(FEATUREID %in% cats_rpu$FEATUREID, 1, 0)) %>%
- filter(full_cats == 1 | hy_cats == 1) %>%
- st_sf()
-
-write_sf(cats, nav_gpkg, nhd_catchment)
-
-out_vpu[[vpu_codes]] <- nhd %>%
- sf::st_drop_geometry() %>%
- select(COMID, toCOMID) %>%
- filter(!toCOMID %in% COMID & !toCOMID == 0)
-
-for(rpu_code in rpu_codes$rpuid) {
- source("R/config.R")
-
- if(needs_layer(out_refac_gpkg, nhd_flowline)) {
- nhd_sub <- subset_rpu(nhd, rpu_code, run_make_standalone = TRUE) %>%
- st_sf()
-
- write_sf(nhd_sub, out_refac_gpkg, nhd_flowline)
-
- cats_rpu <- full_cat_table %>%
- filter(RPUID == rpu_code)
-
- cats %>%
- mutate(hy_cats = ifelse(FEATUREID %in% nhd_sub$COMID, 1, 0),
- full_cats = ifelse(FEATUREID %in% cats_rpu$FEATUREID, 1, 0)) %>%
- filter(full_cats == 1 | hy_cats == 1) %>%
- st_sf() %>%
- write_sf(out_refac_gpkg, nhd_catchment)
-
- } else {
- nhd_sub <- read_sf(out_refac_gpkg, nhd_flowline)
- }
-
- out_rpu[[rpu_code]] <- nhd_sub %>%
- sf::st_drop_geometry() %>%
- select(COMID, toCOMID) %>%
- filter(!toCOMID %in% COMID & !toCOMID == 0)
-}
-```
-
-```{r}
-if(!file.exists("cache/rpu_vpu_out.csv")) {
- make_df <- function(x, d, n) {
- y <- d[[x]]
- nr <- nrow(y)
- na <- names(d)[x]
- o <- data.frame(d = rep(na, nr),
- COMID = d[[x]]$COMID,
- toCOMID = d[[x]]$toCOMID)
- names(o) <- c(n, "COMID", "toCOMID")
- o
- }
-
- rpu <- do.call(rbind, lapply(1:length(out_rpu), make_df, d = out_rpu, n = "rpu"))
-
- vpu <- do.call(rbind, lapply(1:length(out_vpu), make_df, d = out_vpu, n = "vpu"))
-
- out_rpu_vpu <- left_join(rpu, vpu, by = "COMID")
-
- out_rpu_vpu <- select(out_rpu_vpu, RPUID = rpu, VPUID = vpu,
- COMID = COMID, toCOMID = toCOMID.x)
-
- out_rpu_vpu <- left_join(out_rpu_vpu, select(sf::st_drop_geometry(fline), COMID, toRPUID = RPUID, toVPUID = VPUID), by = c("toCOMID" = "COMID"))
-
- readr::write_csv(out_rpu_vpu, "cache/rpu_vpu_out.csv")
-}
-
-```
diff --git a/workspace/02_AK_navigate.Rmd b/workspace/02_AK_navigate.Rmd
index 4a2808622dbb90c5cf8e6162f77a1c1cb8de3669..508bd5b81327acc8402d1b3493a0ba162be1575d 100644
--- a/workspace/02_AK_navigate.Rmd
+++ b/workspace/02_AK_navigate.Rmd
@@ -266,7 +266,7 @@ if(all(is.na(nav_POIs$Type_Conf))) {
select(-LevelPathI.y)
# Navigate upstream from each POI and determine minimally-sufficient network between current POI sets
- up_net <- unique(unlist(lapply(unique(nav_POIs$COMID), NetworkNav, merit)))
+ up_net <- unique(unlist(lapply(unique(nav_POIs$COMID), \(x, net) get_UM(net, x), net = merit)))
final_net <- unique(NetworkConnection(up_net, st_drop_geometry(merit)))
# Subset merit flowlines to navigation results and write to shapefile
@@ -423,7 +423,7 @@ if(!"Type_Elev" %in% colnames(nav_POIs)) {
}
# derive incremental segments from POIs
- inc_segs <- segment_increment(merit, filter(st_drop_geometry(merit),
+ inc_segs <- make_incremental_segments(merit, filter(st_drop_geometry(merit),
COMID %in% nav_POIs$COMID, COMID %in% merit$COMID)) %>%
inner_join(select(merit, COMID, LENGTHKM, TotDASqKM, MAXELEVSMO, MINELEVSMO), by = "COMID") %>%
st_as_sf()
@@ -477,7 +477,7 @@ if(needs_layer(nav_gpkg, nsegments_layer)) {
seg_POIs <- filter(st_drop_geometry(merit), COMID %in% nav_POIs$COMID)
# Attribute reaches that contribute locally to each POI
- inc_segs <- segment_increment(merit, seg_POIs)
+ inc_segs <- make_incremental_segments(merit, seg_POIs)
merit <- merit %>%
left_join(select(inc_segs, COMID, POI_ID), by = "COMID") %>%
mutate(StartFlag = ifelse(!Hydroseq %in% DnHydroseq, 1, 0),
diff --git a/workspace/02_HI_navigate.Rmd b/workspace/02_HI_navigate.Rmd
index 6deba6b39ccfe43daf79909506291b1cc8a6821f..0beb88fbfcb6140b6bf11a70b98309709ecf1f24 100644
--- a/workspace/02_HI_navigate.Rmd
+++ b/workspace/02_HI_navigate.Rmd
@@ -95,7 +95,8 @@ if(needs_layer(nav_gpkg, nhd_flowline)) {
# Coastal and non-dendritic flowlines below the size threshold for poi selection and refactoring
non_dend_COM <- unique(unlist(lapply(filter(nhd, TerminalFl == 1 & TotDASqKM < min_da_km)
- %>% pull(COMID), NetworkNav, st_drop_geometry(nhd_prep), withTrib = TRUE)))
+ %>% pull(COMID), \(x, nhdDF) get_UT(nhdDF, x),
+ nhdDF = st_drop_geometry(nhd_prep))))
non_dend_nhd <- filter(nhd_prep, COMID %in% non_dend_COM)
dend_COM <- filter(nhd_prep, !COMID %in% non_dend_COM)
@@ -314,7 +315,8 @@ Determine confluence POIs
if(all(is.na(nav_POIs$Type_Conf))) {
# Navigate upstream from each POI and determine minimally-sufficient network between current POI sets
- up_net <- unique(unlist(lapply(unique(nav_POIs$COMID), NetworkNav, filter(st_drop_geometry(nhd_prep), dend == 1))))
+ up_net <- unique(unlist(lapply(unique(nav_POIs$COMID), \(x, nhdDF) get_UM(nhdDF, x),
+ nhdDF = filter(st_drop_geometry(nhd_prep), dend == 1))))
finalNet <- unique(NetworkConnection(up_net, filter(st_drop_geometry(nhd_prep), dend == 1)))
# Subset NHDPlusV2 flowlines to navigation results and write to shapefile
@@ -433,7 +435,7 @@ mapview(filter(nav_POIs, !is.na(Type_NID)))
This chunk breaks up potential aggregated segments where the elevation range of the are contributing to the segment exceeds 500-m
```{r Elevation Break POIs}
# derive incremental segments from POIs
-inc_segs <- segment_increment(filter(nhd_prep, minNet == 1), filter(st_drop_geometry(nhd),
+inc_segs <- make_incremental_segments(filter(nhd_prep, minNet == 1), filter(st_drop_geometry(nhd),
COMID %in% nav_POIs$COMID, COMID %in% filter(nhd_prep, minNet == 1)$COMID)) %>%
# bring over VAA data
inner_join(select(atts, ComID, LengthKM, MaxElevSmo, MinElevSmo, AreaSqKm, TotDASqKm), by = c("COMID" = "ComID"))
@@ -552,7 +554,7 @@ if(needs_layer(nav_gpkg, nsegments_layer)) {
COMID %in% filter(nhd_prep, minNet == 1)$COMID)
# Attribute reaches that contribute locally to each POI
- inc_segs <- segment_increment(filter(nhd_prep, minNet == 1), seg_POIs)
+ inc_segs <- make_incremental_segments(filter(nhd_prep, minNet == 1), seg_POIs)
nhd_Final <- nhd_prep %>%
left_join(select(inc_segs, COMID, POI_ID), by = "COMID")
diff --git a/workspace/02_NHD_navigate.Rmd b/workspace/02_NHD_navigate.Rmd
deleted file mode 100644
index 6c1edc83dd32cafe33f79f842a9596e18470b592..0000000000000000000000000000000000000000
--- a/workspace/02_NHD_navigate.Rmd
+++ /dev/null
@@ -1,1038 +0,0 @@
----
-title: "MAPNAT POI Geneation"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-This notebook generates a network of Points of Interest harvested from Public
-source that are used to generate a hydrofabric for use within the USGS
-MAPNAT Project.
-
-
-
-```{r setup_rmd, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=6,
- fig.height=4,
- cache=FALSE)
-```
-
-```{r setup}
-# Load custom functions
-source("R/utils.R")
-source("R/NHD_navigate.R")
-#source("R/test.R")
-
-# increase timeout for data downloads
-options(timeout=600)
-
-# Load Configuration of environment
-source("R/config.R")
-source("R/user_vars.R")
-
-# Gages output from Gage_selection
-gages <- read_sf(gage_info_gpkg, "Gages")
-
-# need some extra attributes for a few POI analyses
-#atts <- read_fst(data_paths$VAA_fst)
-atts_rds <- readRDS(data_paths$VAA_rds)
-```
-
-```{r huc12 POIs}
-# Derive or load HUC12 POIs
-if(needs_layer(temp_gpkg, nav_poi_layer)) {
-
- nhd <- read_sf(nav_gpkg, nhd_flowline)
- if("POI_ID" %in% colnames(nhd)){
- try(nhd <- select(nhd, -c(wb_id, POI_ID)), silent = TRUE) %>%
- distinct()
- }
-
- # Some NHDPlus VPUs include HUCs from other VPUs
- if(vpu_codes == "02"){
- grep_exp <-"^02|^04"
- } else if (vpu_codes == "08") {
- grep_exp <- "^03|^08"
- } else {
- grep_exp <- paste0("^", substr(vpu_codes, start = 1, stop = 2))
- }
-
- # Join HUC12 outlets with NHD
- HUC12_COMIDs <- read_sf(data_paths$hu12_points_path, "hu_points") %>%
- filter(grepl(grep_exp, .data$HUC12)) %>%
- select(COMID, HUC12) %>%
- # Remove this when HUC12 outlets finished
- group_by(COMID) %>%
- filter(row_number() == 1) %>%
- ungroup()
-
- # Create POIs - some r05 HUC12 POIs not in R05 NHD
- huc12_POIs <- POI_creation(st_drop_geometry(HUC12_COMIDs), filter(nhd, poi == 1), "HUC12")
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(huc12_POIs, temp_gpkg, nav_poi_layer)
- tmp_POIs <- huc12_POIs
-} else {
- # Load HUC12 POIs as the tmpPOIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
-}
-
-mapview(filter(tmp_POIs, Type_HUC12 != ""), layer.name = "HUC12 POIs", col.regions = "red")
-```
-
-```{r streamgage POIs}
-if(!"Type_Gages" %in% names(tmp_POIs)) {
-
- # Previously identified streamgages within Gage_Selection.Rmd
- streamgages_VPU <- gages %>%
- rename(COMID = comid) %>%
- filter(COMID %in% nhd$COMID) %>%
- inner_join(st_drop_geometry(st_drop_geometry(nhd), COMID, Divergence), by = "COMID") %>%
- switchDiv(., nhd) %>%
- filter(drain_area > min_da_km_gages)
-
- streamgages <- streamgages_VPU %>%
- group_by(COMID) %>%
- # If multiple gages per COMID, pick one with highest rank as rep POI_ID
- filter(gage_score == max(gage_score), !is.na(drain_area)) %>%
- ungroup()
-
- # Derive GAGE POIs; use NHD as we've already filtered by NWIS DA in the Gage selection step
- gages_POIs <- gage_POI_creation(tmp_POIs, streamgages, filter(nhd, poi == 1), combine_meters, reach_meas_thresh)
- tmp_POIs <- gages_POIs$tmp_POIs
- events <- rename(gages_POIs$events, POI_identifier = Type_Gages)
-
- # As a fail-safe, write out list of gages not assigned a POI
- if(nrow(filter(streamgages_VPU, !site_no %in% tmp_POIs$Type_Gages)) > 0) {
- write_sf(filter(streamgages_VPU, !site_no %in% tmp_POIs$Type_Gages) %>%
- rename(nhd_reachcode = REACHCODE),
- temp_gpkg, "unassigned_gages")
-
- # Start documenting gages that are dropped out; these gages have no mean daily Q
- gage_document(filter(streamgages_VPU, !site_no %in% tmp_POIs$Type_Gages) %>%
- select(site_no),
- "Gages_info", paste0("VPU ", vpu_codes, "; low gage score"))
-
- }
-
- # Write out events and outelts
- write_sf(events, temp_gpkg, split_layer)
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- events <- read_sf(temp_gpkg, split_layer)
-}
-
-#mapview(filter(tmp_POIs, !is.na(Type_Gages)), layer.name = "Streamgage POIs", col.regions = "blue")
-```
-
-```{r TE POIs}
-if(!"Type_TE" %in% names(tmp_POIs)) {
-
- if(vpu_codes == "08"){
- nhd$VPUID <- "08"
- } else {
- nhd$VPUID <- substr(nhd$RPUID, 1, 2)
- }
-
- # Read in Thermoelectric shapefile for 2015 estimates
- TE_v1 <- read_sf(data_paths$TE_points_path,
- "2015_TE_Model_Estimates_lat.long_COMIDs")
- # Read in Thermoelectric Plants csv for updated estimates
- TE_v2 <- read.csv(file.path(data_paths$TE_points_path,
- "te_plants.csv"),
- colClasses = "character") %>%
- mutate(Plant.Code = as.integer(Plant.Code))
-
- # Bind hydrographic address information together and get final COMIDs
- TE_COMIDs_full <- TE_v2 %>%
- filter(water_source %in% c("sw_fresh", "gw_fresh", "gw_sw_mix")) %>%
- left_join(select(st_drop_geometry(TE_v1),
- Plant.Code = EIA_PLANT_, COMID), by = "Plant.Code") %>%
- left_join(rename(st_drop_geometry(HUC12_COMIDs), huc12_comid = COMID),
- by = c("huc_12" = "HUC12")) %>%
- mutate(COMID = ifelse(is.na(COMID), huc12_comid, COMID)) %>%
- select(-huc12_comid)
-
- # Prepare TE for POI Creation
- TE_COMIDs <- TE_COMIDs_full %>%
- inner_join(select(st_drop_geometry(nhd), COMID, VPUID), by = "COMID") %>%
- filter(grepl(paste0("^", substr(vpu_codes, 1, 2), ".*"), .data$VPUID), COMID > 0) %>%
- switchDiv(., nhd) %>%
- group_by(COMID) %>%
- summarize(eia_id = paste0(unique(Plant.Code), collapse = " "), count = n()) %>%
- ungroup()
-
- if(nrow(TE_COMIDs) > 0){
- # Derive TE POIs
- tmp_POIs <- POI_creation(st_drop_geometry(TE_COMIDs), filter(nhd, poi == 1), "TE") %>%
- addType(., tmp_POIs, "TE", nexus = TRUE)
-
- # As a fail-safe, write out list of TE plants not assigned a POI
- if(nrow(filter(TE_COMIDs, !COMID %in% tmp_POIs$COMID)) > 0) {
- write_sf(filter(TE_COMIDs, !COMID %in% tmp_POIs$COMID),
- temp_gpkg, "unassigned_TE")
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- }
- } else {
- print ("no TEs in VPU")
- }
-
-} else {
- # Load TE POIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-#mapview(filter(tmp_POIs, Type_TE != ""), layer.name = "TE Plant POIs", col.regions = "blue")
-```
-
-```{r WB mods}
-
-# Waterbodies sourced from NHD waterbody layer for entire VPU
-WBs_VPU_all <- filter(readRDS(data_paths$waterbodies_path),
- COMID %in% nhd$WBAREACOMI) %>%
- filter(FTYPE != "SwampMarsh") %>%
- mutate(FTYPE = as.character(FTYPE),
- source = "NHDv2WB",
- wb_id = ifelse(GNIS_ID == " ", COMID, GNIS_ID)) %>%
- st_transform(geo_crs) %>%
- st_make_valid()
-
-write_sf(WBs_VPU_all, temp_gpkg, "wbs_draft")
-
-if(needs_layer(temp_gpkg, "WBs_layer_orig")){
- sf_use_s2(FALSE)
- ref_WB <- WBs_VPU_all %>%
- group_by(wb_id, GNIS_NAME) %>%
- sfheaders::sf_remove_holes() %>%
- summarize(do_union = TRUE, member_comid = paste(COMID, collapse = ",")) %>%
- st_make_valid() %>%
- ungroup() %>%
- mutate(area_sqkm = as.numeric(st_area(.)) / 1000000) %>%
- mutate(source = "NHDv2WB") %>%
- st_cast("MULTIPOLYGON")
- #sf_use_s2(TRUE)
-
- write_sf(ref_WB, temp_gpkg, "WBs_layer_orig")
-} else {
- ref_WB <- read_sf(temp_gpkg, "WBs_layer_orig")
-}
-```
-
-```{r resops}
-# # 1: Many based on original GNIS_ID
-if(!"Type_resops" %in% names(tmp_POIs)){
-
- # Unnest wb_poi_lst
- wb_table <- st_drop_geometry(ref_WB) %>%
- dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
- tidyr::unnest(cols = member_comid) %>%
- mutate(member_comid = as.character(member_comid)) %>%
- distinct()
-
- # TODO: get this file from data.json
- # ResOpsUS locations with attributes from the VPU NHDv2 wb set
- resops_wb_df <- read.csv("data/reservoir_data/istarf_xwalk_final_48_gfv11.csv") %>%
- # Subset to VPU, only one DAMID per waterbody
- filter(flowlcomid %in% nhd$COMID |
- wbareacomi %in% wb_table$member_comid) %>%
- dplyr::select(grand_id, nid_source_featureid, source = comi_srclyr,
- flowlcomid, wbareacomi, hr_permid, onoffnet) %>%
- mutate(wbareacomi = as.character(wbareacomi)) %>%
- # Link to waterbody table
- left_join(distinct(wb_table, member_comid, wb_id),
- by = c("wbareacomi" = "member_comid")) %>%
- left_join(select(st_drop_geometry(WBs_VPU_all), wbareacomi = COMID,
- wb_id2 = wb_id) %>%
- mutate(wbareacomi = as.character(wbareacomi)),
- by = "wbareacomi") %>%
- mutate(wb_id = ifelse(is.na(wb_id), wb_id2, wb_id),
- wbareacomi = ifelse(wbareacomi == -2,
- hr_permid, wbareacomi)) %>%
- select(-c(wb_id2))
-
- # POIs with waterbody IDs in reference waterbodies
- resops_wb_pois <- filter(ref_WB, wb_id %in% resops_wb_df$wb_id) %>%
- inner_join(select(st_drop_geometry(resops_wb_df), grand_id,
- NID_ID = nid_source_featureid,
- resops_flowlcomid = flowlcomid, wb_id),
- by = "wb_id") %>%
- #mutate(source = "ref_WB") %>%
- group_by(wb_id) %>%
- filter(n() == 1) %>%
- st_as_sf()
-
- # Add ResOPsUS locations to waterbody list with attributed NID and resops data
- if(nrow(resops_wb_pois) > 0){
- wb_poi_lst_filtered <- filter(ref_WB, !wb_id %in% resops_wb_pois$wb_id,
- !is.na(wb_id))
-
- wb_poi_lst <- data.table::rbindlist(list(wb_poi_lst_filtered, resops_wb_pois),
- fill = TRUE) %>%
- mutate(accounted = 0) %>%
- st_as_sf()
-
- }
-
- # Reach resopsus
- reach_resops <- filter(resops_wb_df, !wb_id %in% wb_poi_lst$wb_id,
- !source %in% c("NHDAREA", "HR ID AVAILABLE") |
- onoffnet == 0) %>%
- mutate(Type_WBOut = NA) %>%
- select(COMID = flowlcomid, resops = grand_id, Type_WBOut)
-
- # Existing reservoir-waterbody outlet POIs
- exist_POIs_WB <- filter(resops_wb_df, flowlcomid %in% tmp_POIs$COMID) %>%
- mutate(wb_id = ifelse(source == "NHDAREA", wbareacomi, wb_id)) %>%
- filter(!is.na(wb_id)) %>%
- select(COMID = flowlcomid, resops = grand_id, Type_WBOut = wb_id)
-
- # Resops POIs
- resops_pois <- rbind(reach_resops, exist_POIs_WB)
-
- # Resops defined by reach
- if(nrow(resops_pois) > 0){
- # Resops POIs with no reservoirs, defined by reach
- tmp_POIs <- POI_creation(resops_pois, filter(nhd, poi == 1), "resops") %>%
- addType(., tmp_POIs, "resops", nexus = TRUE)
-
- # Add waterbody attribute
- tmp_POIs <- tmp_POIs %>%
- left_join(select(resops_pois, COMID, Type_WBOut),
- by = "COMID") %>%
- mutate(Type_WBOut = ifelse(!nexus,
- Type_WBOut, NA))
-
- # Resops with reservoirs
- resops_wb_df <- resops_wb_df %>%
- mutate(accounted = ifelse(grand_id %in% tmp_POIs$Type_resops, 1, 0),
- source = ifelse(grand_id %in% reach_resops$resops, "REACH", source))
- }
-
- write_sf(wb_poi_lst, temp_gpkg, WBs_layer)
- write_sf(resops_wb_df, temp_gpkg, "wb_resops")
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- wb_poi_lst <- read_sf(temp_gpkg, WBs_layer)
- resops_wb_df <- read_sf(temp_gpkg, "wb_resops")
-}
-```
-
-```{r Hilari}
-if(!"Type_hilarri" %in% names(tmp_POIs)){
-
- # 1: Many based on original GNIS_ID
- wb_table <- st_drop_geometry(wb_poi_lst) %>%
- dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
- tidyr::unnest(cols = member_comid) %>%
- mutate(member_comid = as.integer(member_comid)) %>%
- distinct()
-
- # Hilarri POI Points
- hilarri_points <- read.csv("data/HILARRI/HILARRI_v2.csv",
- colClasses = "character") %>%
- mutate(nhdwbcomid = as.integer(nhdwbcomid)) %>%
- filter(!dataset %in% c('Power plant only; no reservoir or inventoried dam'),
- nhdv2comid %in% nhd$COMID) %>%
- left_join(select(wb_table, member_comid, wb_id),
- by = c("nhdwbcomid" = "member_comid"))
-
- # Waterbodies linked to hilarri information
- hil_wb_pois_rf <- wb_poi_lst %>%
- inner_join(select(st_drop_geometry(hilarri_points), hilarriid, nhdwbcomid,
- nidid_hill = nidid, wb_id),
- by = "wb_id") %>%
- group_by(wb_id) %>%
- mutate(hilarriid = paste0(hilarriid, collapse = ","),
- nidid_hill = paste0(nidid_hill, collapse = ",")) %>%
- ungroup() %>%
- distinct() %>%
- st_as_sf() %>%
- st_compatibalize(wb_poi_lst)
-
- # Add ResOPsUS locations to waterbody list
- if(nrow(hil_wb_pois_rf) > 0){
- wb_poi_lst <- wb_poi_lst %>%
- #filter(!is.na(resops_FlowLcomid)) %>%
- left_join(select(st_drop_geometry(hil_wb_pois_rf), wb_id, hilarriid,
- nidid_hill), by = "wb_id") %>%
- mutate(NID_ID = ifelse(is.na(NID_ID), nidid_hill, NID_ID)) %>%
- select(-nidid_hill) %>%
- distinct()
- }
-
- # Reach POIs
- reach_pois <- filter(hilarri_points, !hilarriid %in% wb_poi_lst$hilarriid) %>%
- select(COMID = nhdv2comid, hilarriid) %>%
- mutate(COMID = as.integer(COMID)) %>%
- group_by(COMID) %>%
- filter(row_number() == 1) %>%
- st_drop_geometry()
-
- # Make POIs for reach POIs
- tmp_POIs <- POI_creation(reach_pois, filter(nhd, poi == 1), "hilarri") %>%
- addType(., tmp_POIs, "hilarri", nexus = TRUE)
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(wb_poi_lst, temp_gpkg, WBs_layer)
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- wb_poi_lst <- read_sf(temp_gpkg, WBs_layer)
-}
-```
-
-```{r waterbody outlet POIs}
-# Derive or load Waterbody POIs ----------------------
-if("Type_WBOut" %in% names(tmp_POIs)) {
-
- # Hillari IDs
- hilarri_pois <- filter(tmp_POIs, !is.na(Type_hilarri))
-
- # Get NHDARea polygons already define
- nhd_area_vpu <- read_sf(data_paths$nhdplus_gdb, "NHDArea") %>%
- select(COMID, AREASQKM) %>%
- mutate(source = "NHDv2Area") %>%
- st_compatibalize(wb_poi_lst)
-
- # Non-nhdv2 waterbodies from resopsus
- other_wbs <- filter(resops_wb_df, !wb_id %in% wb_poi_lst$wb_id,
- source != "REACH") %>%
- select(grand_id, member_comid = wbareacomi, resops_flowlcomid = flowlcomid,
- source, accounted) %>%
- left_join(select(st_drop_geometry(hilarri_pois),
- COMID, hilarriid = Type_hilarri),
- by = c("resops_flowlcomid" = "COMID")) %>%
- group_by(resops_flowlcomid) %>%
- filter(row_number() == 1) %>%
- ungroup() %>%
- left_join(select(nhd_area_vpu, COMID) %>%
- mutate(COMID = as.character(COMID)),
- by = c("member_comid" = "COMID")) %>%
- st_as_sf() %>%
- mutate(wb_id = ifelse(source == "NHDAREA", member_comid, NA)) %>%
- st_drop_geometry()
-
- # copy empty geometries to wb_list for use in wb POI function
- if(nrow(other_wbs) > 0){
- wb_poi_list_fn <- data.table::rbindlist(list(wb_poi_lst,
- other_wbs),
- fill = TRUE) %>%
- distinct() %>%
- st_as_sf()
- } else {
- wb_poi_list_fn <- wb_poi_lst
- }
-
- # Final waterbody list with all requirements
- final_wb_list <- filter(wb_poi_list_fn,
- area_sqkm > wb_area_thresh |
- !is.na(resops_flowlcomid) |
- !is.na(hilarriid))
-
- new_path <- "?prefix=StagedProducts/Hydrography/NHDPlusHR/VPU/Current/GDB/"
- assign("nhdhr_file_list", new_path, envir = nhdplusTools:::nhdplusTools_env)
-
- # fix something here
- wb_layers <- wbout_POI_creaton(filter(nhd, poi == 1), final_wb_list, data_paths, tmp_POIs, proj_crs)
-
- if(!is.data.frame(wb_layers)){
- # write_sf(wb_layers$nhd_wb_table, temp_gpkg, "wb_flowpaths")
- #
- wbs <- wb_layers$WBs
- wb_pois <- wb_layers$POIs %>% filter(!is.na(Type_WBOut))
- missing_wb <- filter(wbs, !wb_id %in% wb_pois$Type_WBOut)
- print(nrow(missing_wb))
-
- double_wb <- wbs %>% group_by(wb_id) %>% filter(n() > 1)
- write_sf(double_wb, temp_gpkg, "double_wb")
-
- double_wb_pois <- wb_pois %>%
- group_by(Type_WBOut) %>%
- filter(n() > 1)
- write_sf(double_wb_pois, temp_gpkg, "double_wb_pois")
-
- wb_missing_poi <- filter(wbs,
- !wb_id %in% wb_pois$Type_WBOut)
- write_sf(wb_missing_poi, temp_gpkg, "wb_missing_poi")
-
- poi_missing_wb <- filter(wb_pois, !Type_WBOut %in% wb_layers$WBs$wb_id)
- write_sf(poi_missing_wb, temp_gpkg, "poi_missing_wb")
-
- #*************************************
- if(all(!is.na(wb_layers$events))){
- wb_events <- wb_layers$events %>%
- select(COMID, REACHCODE, REACH_meas, POI_identifier = wb_id,
- event_type, nexus) %>%
- st_compatibalize(., events)
-
- events <- rbind(events, wb_events)
- write_sf(events, temp_gpkg, split_layer)
- }
-
- if(all(!is.na(wb_layers$events))){
- # Write out events and outlets
- if(!needs_layer(temp_gpkg, split_layer)){
- events <- read_sf(temp_gpkg, split_layer) %>%
- rbind(st_compatibalize(wb_events,.)) %>%
- unique()
-
- write_sf(events, temp_gpkg, split_layer)
- } else {
- write_sf(wb_events, nav_gpkg, split_layer)
- }
- }
-
- tmp_POIs <- wb_layers$POIs
- # Write out waterbodies
- WB_VPU_pois <- wb_layers$WBs
- } else {
- tmp_POIs <- wb_layers
- WB_VPU_pois <- final_wb_list
- }
-
- #12047928
- wb_out_col <- wb_poi_collapse(tmp_POIs, nhd, events)
- tmp_POIs <- wb_out_col$POIs
-
- if(all(!is.na(wb_out_col$events_ret))){
- write_sf(wb_out_col$events_ret, temp_gpkg, split_layer)
- }
-
- nhd <- wb_layers$nhd_wb_table
- write_sf(nhd, nav_gpkg, nhd_flowline)
- write_sf(WB_VPU_pois, temp_gpkg, WBs_layer)
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- } else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
- WB_VPU_pois <- read_sf(temp_gpkg, WBs_layer)
-}
-
-#mapview(filter(tmp_POIs, !is.na(Type_WBOut)), layer.name = "Waterbody outlet POIs", col.regions = "red")
-```
-
-```{r AR POIs}
-# Derive or load Waterbody POIs ----------------------
-if(!"Type_AR" %in% names(tmp_POIs)) {
- # Sparrow AR Events
- ar_events <- readxl::read_xlsx(file.path(data_paths$USGS_IT_path, "ARevents_final7.xlsx")) %>%
- filter(fromComid > 0 | ToComid > 0) %>%
- select(COMID = NHDComid, AREventID) %>%
- filter(COMID %in% nhd$COMID)
-
- if(nrow(ar_events) > 0){
- # AR POIs
- tmp_POIs <- POI_creation(ar_events, nhd, "AR") %>%
- addType(., tmp_POIs, "AR", nexus = TRUE)
-
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- } else {
- print(paste0("No AR events in ", vpu_codes))
- }
-
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-```
-
-```{r Terminal POIs}
-# Derive or load Terminal POIs ----------------------
-if(!"Type_Term" %in% names(tmp_POIs)) {
-
- # Terminal POIs on levelpaths with upstream POIs
- term_paths <- filter(st_drop_geometry(nhd), Hydroseq %in% filter(nhd, COMID %in% tmp_POIs$COMID)$TerminalPa)
-
- # Non-POI levelpath terminal pois, but meet size criteria
- terminal_POIs <- st_drop_geometry(nhd) %>%
- filter(Hydroseq == TerminalPa | (toCOMID == 0 | is.na(toCOMID) | !toCOMID %in% COMID)) %>%
- filter(!COMID %in% term_paths$COMID, TotDASqKM >= min_da_km_terminal) %>%
- bind_rows(term_paths) %>%
- # Use level path identifier as Type ID
- select(COMID, LevelPathI)
-
- tmp_POIs <- POI_creation(terminal_POIs, nhd, "Term") %>%
- addType(., tmp_POIs, "Term", nexus = TRUE)
-
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_Term)), layer.name = "Terminal POIs", col.regions = "blue")
-```
-
-```{r Confluence POIs}
-# Derive POIs at confluences where they are absent ----------------------
-if(!"Type_Conf" %in% names(tmp_POIs)) {
-
- # Navigate upstream from each POI and determine minimally-sufficient network between current POI sets
- up_net <- unique(unlist(lapply(unique(tmp_POIs$COMID), NetworkNav, nhd)))
- finalNet <- unique(NetworkConnection(up_net, st_drop_geometry(nhd)))
-
- # Subset NHDPlusV2 flowlines to navigation results and write to shapefile
- nhd <- mutate(nhd, minNet = ifelse(COMID %in% finalNet, 1, 0))
-
- # Create new confluence POIs
- conf_COMIDs <- st_drop_geometry(filter(nhd, minNet == 1)) %>%
- # Downstream hydrosequence of 0 indicates
- # the flowline is terminating or
- # leaving the domain, so they
- # are excluded from this process
- filter(DnHydroseq > 0) %>%
- group_by(DnHydroseq) %>%
- filter(n()> 1) %>%
- mutate(Type_Conf = LevelPathI) %>%
- ungroup() %>%
- select(COMID, Type_Conf)
-
- tmp_POIs <- POI_creation(conf_COMIDs, filter(nhd, minNet == 1), "Conf") %>%
- addType(., tmp_POIs, "Conf", nexus = TRUE)
-
- write_sf(nhd, nav_gpkg, nhd_flowline)
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- nhd <- read_sf(nav_gpkg, nhd_flowline)
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_Conf)), layer.name = "Confluence POIs", col.regions = "blue")
-```
-
-```{r waterbody inlet POIs}
-# Derive or load Waterbody POIs ----------------------
-if(!"Type_WBIn" %in% names(tmp_POIs)) {
-
- wb_layers <- wbin_POIcreation(filter(nhd, minNet == 1), WB_VPU_pois,
- data_paths, proj_crs, split_layer, tmp_POIs)
- wb_in_col <- wb_inlet_collapse(wb_layers$POIs, nhd, events)
- tmp_POIs <- wb_in_col$POIs
-
- if(!all(is.na(wb_layers$events))) {
- wb_inlet_events <- wb_layers$events %>%
- select(COMID, REACHCODE, REACH_meas, POI_identifier,
- event_type, nexus)
-
- # Write out events and outlets
- if(!needs_layer(temp_gpkg, split_layer)){
- events <- read_sf(temp_gpkg, split_layer) %>%
- rbind(st_compatibalize(wb_inlet_events,.))
- write_sf(events, temp_gpkg, split_layer)
- } else {
- write_sf(wb_inlet_events, nav_gpkg, split_layer)
- }
- }
-
- #tmp_POIs$nexus <- ifelse(is.na(tmp_POIs$nexus), FALSE, tmp_POIs$nexus)
- #tmp_POIs <- wb_layers$POIs
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_WBIn)), layer.name = "Waterbody inlet POIs", col.regions = "blue") +
- mapview(filter(tmp_POIs, !is.na(Type_WBOut)), layer.name = "Waterbody outlet POIs", col.regions = "red")
-```
-
-
-```{r NID POIs}
-# Derive or load NID POIs ----------------------
-if(!"Type_NID" %in% names(tmp_POIs)) {
-
- # Read in NID shapefile
- NID_COMIDs <- read_sf(data_paths$NID_points_path, "Final_NID_2018") %>%
- st_drop_geometry() %>%
- filter(EROM != 0, FlowLcomid %in% filter(nhd, dend ==1)$COMID) %>%
- rename(COMID = FlowLcomid) %>%
- switchDiv(., nhd) %>%
- group_by(COMID) %>%
- summarize(Type_NID = paste0(unique(NIDID), collapse = " "))
-
- # Derive other NID POIs
- tmp_POIs <- POI_creation(NID_COMIDs, nhd, "NID") %>%
- addType(., tmp_POIs, "NID", nexus = FALSE, bind = FALSE)
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- # Load NID POIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-mapview(filter(tmp_POIs, Type_NID != ""), layer.name = "NID POIs", col.regions = "blue")
-```
-
-```{r HW DA POIs}
-if(!"Type_DA" %in% names(tmp_POIs)){
-
- # derive incremental segments from POIs
- inc_segs <- segment_increment(nhd,
- filter(st_drop_geometry(nhd),
- COMID %in% tmp_POIs$COMID)) %>%
- # bring over VAA data
- inner_join(select(atts_rds, COMID,
- DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO,
- MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE, StartFlag,
- AreaSqKM, TotDASqKM), by = "COMID")
-
- hw_segs <- inc_segs %>%
- group_by(POI_ID) %>%
- filter(any(StartFlag == 1)) %>%
- filter(any(TotDASqKM > max_da_km_hw)) %>%
- ungroup()
-
- #TODO Add magic numbers to config file
- hw_DA_splits <- hw_segs %>%
- st_drop_geometry() %>%
- #filter(.data$ID %in% cat$ID) %>%
- group_by(POI_ID) %>%
- arrange(-Hydroseq) %>%
- mutate(ind = att_group(TotDASqKM, min_da_km_hw)) %>%
- ungroup() %>%
- group_by(POI_ID, ind) %>%
- mutate(total_length = cumsum(LENGTHKM)) %>%
- ungroup() %>%
- group_by(POI_ID, ind) %>%
- mutate(set = cur_group_id()) %>%
- filter(TotDASqKM == max(TotDASqKM) &
- total_length > 5) %>%
- mutate(da_class = paste(POI_ID, ind, sep = "_")) %>%
- ungroup() %>%
- select(-ind) %>%
- filter(!COMID %in% tmp_POIs$COMID)
-
- if(nrow(hw_DA_splits) > 0) {
- tmp_POIs <- POI_creation(select(hw_DA_splits, COMID, da_class),
- filter(nhd, poi == 1), "DA") %>%
- addType(., tmp_POIs, "DA", nexus = TRUE)
- }
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-```
-
-This chunk breaks up potential aggregated segments where the elevation range of the are contributing to the segment exceeds 500-m
-```{r Elevation Break POIs}
-if(!"Type_elev" %in% names(tmp_POIs)){
-
- inc_segs <- segment_increment(filter(nhd, minNet == 1),
- filter(st_drop_geometry(nhd),
- COMID %in% tmp_POIs$COMID)) %>%
- # bring over VAA data
- inner_join(select(atts_rds, COMID,
- DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO,
- MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE, StartFlag,
- AreaSqKM, TotDASqKM), by = "COMID")
-
- elev_fp <- inc_segs %>%
- group_by(POI_ID) %>%
- arrange(Hydroseq) %>%
- # Get elevation info
- mutate(MAXELEVSMO = na_if(MAXELEVSMO, -9998), MINELEVSMO = na_if(MINELEVSMO, -9998),
- elev_diff_seg = max(MAXELEVSMO) - min(MINELEVSMO),
- total_length = cumsum(LENGTHKM)) %>%
- filter((max(MINELEVSMO) - min(MINELEVSMO)) > elev_diff) %>%
- mutate(inc_elev_diff = c(MINELEVSMO[1], (MINELEVSMO - lag(MINELEVSMO))[-1])) %>%
- mutate(inc_elev_diff = ifelse(inc_elev_diff == MINELEVSMO, 0, inc_elev_diff)) %>%
- ungroup()
-
- if(nrow(elev_fp) > 0){
- #TODO Add magic numbers to config file
- hw_elev_splits <- elev_fp %>%
- st_drop_geometry() %>%
- #filter(.data$ID %in% cat$ID) %>%
- group_by(POI_ID) %>%
- arrange(-Hydroseq) %>%
- mutate(ind = cs_group(inc_elev_diff, elev_diff/2)) %>%
- ungroup() %>%
- group_by(POI_ID, ind) %>%
- filter(TotDASqKM == max(TotDASqKM) &
- total_length > 5) %>%
- mutate(elev_class = paste(POI_ID, ind, sep = "_")) %>%
- ungroup() %>%
- select(-ind) %>%
- filter(!COMID %in% tmp_POIs$COMID)
-
- if(nrow(hw_elev_splits) > 0) {
- tmp_POIs <- POI_creation(select(hw_elev_splits, COMID, elev_class),
- filter(nhd, poi == 1),
- "elev") %>%
- addType(., tmp_POIs, "elev", nexus = TRUE)
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- }
- }
-
-
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-```
-
-```{r Time of travel POIs}
-if(all(is.na(tmp_POIs$Type_Travel))) {
-
- # derive incremental segments from POIs
- inc_segs <- segment_increment(nhd,
- filter(st_drop_geometry(nhd),
- COMID %in% tmp_POIs$COMID,
- COMID %in% nhd$COMID)) %>%
- # bring over VAA data
- inner_join(select(atts_rds, COMID, DnHydroseq, VA_MA, TOTMA, LENGTHKM,
- MAXELEVSMO, MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE,
- AreaSqKM, TotDASqKM), by = "COMID")
-
- # TT POIs
- tt_pois_split <- inc_segs %>%
- arrange(-Hydroseq) %>%
- # Should we substitute with a very small value
- mutate(VA_MA = ifelse(VA_MA < 0, NA, VA_MA)) %>%
- mutate(FL_tt_hrs = (LENGTHKM * ft_per_km)/ VA_MA / s_per_hr ) %>%
- group_by(POI_ID) %>%
- filter(sum(FL_tt_hrs) > travt_diff, max(TotDASqKM) > max_elev_TT_DA) %>%
- mutate(cum_tt = cumsum(FL_tt_hrs),
- hrs = sum(FL_tt_hrs))
-
- #TODO Add magic numbers to config file
- tt_splits <- tt_pois_split %>%
- st_drop_geometry() %>%
- group_by(POI_ID) %>%
- arrange(-Hydroseq) %>%
- mutate(ind = cs_group(FL_tt_hrs, travt_diff * 0.75)) %>%
- ungroup() %>%
- group_by(POI_ID, ind) %>%
- filter(TotDASqKM == max(TotDASqKM)) %>%
- mutate(tt_class = paste(POI_ID, ind, sep = "_")) %>%
- ungroup() %>%
- select(-ind) %>%
- filter(!COMID %in% tmp_POIs$COMID)
-
- if(nrow(tt_splits) > 0) {
- tmp_POIs <- POI_creation(select(tt_splits, COMID, tt_class),
- filter(nhd, poi == 1), "Travel") %>%
- addType(., tmp_POIs, "Travel", nexus = TRUE)
-
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- }
-
-}else{
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-```
-
-```{r Final POIs}
-# Derive final POI set ----------------------
-if(needs_layer(temp_gpkg, pois_all_layer)) {
-
- unCon_POIs <- filter(tmp_POIs, COMID %in% filter(nhd, AreaSqKM == 0)$COMID)
-
- # If any POIs happened to fall on flowlines w/o catchment
- if (nrow(unCon_POIs) >0){
- # For confluence POIs falling on Flowlines w/o catchments, derive upstream valid flowline,
- poi_fix <- DS_poiFix(tmp_POIs, filter(nhd, minNet == 1))
- new_POIs <- st_compatibalize(poi_fix$new_POIs, tmp_POIs)
- xWalk <- poi_fix$xWalk
-
- # POIs that didn't need to be moved
- tmp_POIs_fixed <- filter(tmp_POIs, nexus == TRUE |
- !COMID %in% c(poi_fix$xWalk$oldPOI, poi_fix$xWalk$COMID))
- # bind together
- final_POIs <- bind_rows(tmp_POIs_fixed, new_POIs) %>%
- mutate(Type_Term = ifelse(nexus == 1, NA, Type_Term)) %>%
- select(-dplyr::any_of(c("ID")))
-
- # Write out fixes
- write_sf(new_POIs, temp_gpkg, poi_moved_layer)
- write_sf(xWalk, temp_gpkg, poi_xwalk_layer)
- # write out final POIs
- write_sf(final_POIs, temp_gpkg, pois_all_layer)
- } else {
- # If no fixes designate as NA
- poi_fix <- NA
-
- tmp_POIs$nexus <- as.integer(tmp_POIs$nexus)
-
- # if a POI will be a nexus, it can not be terminal.
- tmp_POIs <- mutate(tmp_POIs, Type_Term = ifelse(nexus == 1, NA, Type_Term))
-
- # write out final POIs
- write_sf(tmp_POIs, temp_gpkg, pois_all_layer)
-
- }
-
-} else {
- # Need all three sets for attribution below
- final_POIs <- read_sf(temp_gpkg, pois_all_layer)
- new_POIs <- if(!needs_layer(temp_gpkg, poi_moved_layer)) read_sf(temp_gpkg, poi_moved_layer) else (NA)
- xWalk <- if(!needs_layer(temp_gpkg, poi_xwalk_layer)) read_sf(temp_gpkg, poi_xwalk_layer) else (NA)
- unCon_POIs <- filter(st_drop_geometry(filter(nhd, minNet == 1)),
- COMID %in% tmp_POIs$COMID, AreaSqKM == 0)
-}
-```
-
-```{r Draft nsegment generation}
-if(needs_layer(temp_gpkg, nsegments_layer)) {
-
- if("POI_ID" %in% colnames(nhd)){
- nhd <- select(nhd, -POI_ID)
- }
- # Sort POIs by Levelpath and Hydrosequence in upstream to downstream order
- seg_POIs <- filter(st_drop_geometry(nhd),
- COMID %in% tmp_POIs$COMID, COMID %in% filter(nhd, minNet == 1)$COMID)
- # derive incremental segments from POIs
- inc_segs <- segment_increment(filter(nhd, minNet == 1), seg_POIs)
-
- nhd_Final <- nhd %>%
- left_join(select(inc_segs, COMID, POI_ID), by = "COMID")
-
- # create and write out final dissolved segments
- nsegments_fin <- segment_creation(nhd_Final, xWalk)
-
- nhd_Final <- select(nhd_Final, -POI_ID) %>%
- left_join(distinct(st_drop_geometry(nsegments_fin$raw_segs), COMID, POI_ID), by = "COMID")
- nsegments <- nsegments_fin$diss_segs
-
- write_sf(nhd_Final, nav_gpkg, nhd_flowline)
- write_sf(nsegments, temp_gpkg, nsegments_layer)
-} else {
- # Read in NHDPlusV2 flowline simple features and filter by vector processing unit (VPU)
- final_POIs <- read_sf(temp_gpkg, pois_all_layer)
- nhd_Final <- read_sf(nav_gpkg, nhd_flowline)
- nsegments <- read_sf(temp_gpkg, nsegments_layer)
-}
-
-# Ensure that all the problem POIs have been taken care of
-sub <- nhd_Final %>% filter(COMID %in% final_POIs$COMID)
-print (paste0(nrow(sub[sub$AreaSqKM == 0,]), " POIs on flowlines with no local drainage contributions"))
-noDA_pois <- filter(final_POIs, COMID %in% filter(sub, AreaSqKM == 0)$COMID)
-write_sf(noDA_pois, temp_gpkg, "noDA_pois")
-```
-
-```{r POI Collapse}
-# number POIs
-final_POIs_prec <- mutate(final_POIs, id = row_number(), moved = NA) %>%
- write_sf(temp_gpkg, pois_all_layer) %>%
- write_sf(nav_gpkg, nav_poi_layer)
-collapse <- TRUE
-
-# TODO: document what this is doing!
-source("R/poi_move.R")
-
-check_dups <- final_POIs %>%
- group_by(COMID) %>%
- filter(n() > 1)
-
-if(nrow(filter(check_dups, all(c(0,1) %in% nexus))) != nrow(check_dups)){
- print("Multiple POI ids at same geometric location")
- no_dups <- filter(check_dups, all(c(0,1) %in% nexus))
- dups <- filter(check_dups, !id %in% no_dups$id)
- write_sf(dups, temp_gpkg, dup_pois)
-} else {
- print("All double COMIDs nexus for gage or WB splitting")
-}
-
-mapview(final_POIs, layer.name = "All POIs", col.regions = "red") +
- mapview(nsegments, layer.name = "Nsegments", col.regions = "blue")
-```
-
-```{r lookup}
-# Final POI layer
-POIs <- final_POIs %>%
- mutate(identifier = row_number())
-
-# Unique POI geometry
-final_POI_geom <- POIs %>%
- select(identifier) %>%
- cbind(st_coordinates(.)) %>%
- group_by(X, Y) %>%
- mutate(geom_id = cur_group_id()) %>%
- ungroup()
-
-final_POIs_table <- POIs %>%
- inner_join(select(st_drop_geometry(final_POI_geom), -X, -Y), by = "identifier") %>%
- select(-identifier)
-
-# POI data theme table
-pois_data_orig <- reshape2::melt(st_drop_geometry(select(final_POIs_table,
- -c(nexus, nonrefactor, id, moved))),
- id.vars = c("COMID", "geom_id")) %>%
- filter(!is.na(value)) %>%
- group_by(COMID, geom_id) %>%
- mutate(identifier = cur_group_id()) %>%
- rename(hy_id = COMID, poi_id = identifier, hl_reference = variable, hl_link = value) %>%
- distinct()
-
-if(exists("moved_pois_table")){
- pois_data_moved <- select(st_drop_geometry(moved_pois_table),
- hy_id = COMID, hl_link = new_val, hl_reference = moved_value) %>%
- inner_join(distinct(pois_data_orig, hy_id, geom_id, poi_id), by = "hy_id")
-
- pois_data <- data.table::rbindlist(list(pois_data_moved, pois_data_orig), use.names = TRUE) %>%
- filter(!hl_reference %in% c("id", "moved"))
-} else {
- pois_data <- pois_data_orig
-}
-
-# POI Geometry table
-poi_geometry <- select(final_POIs_table, hy_id = COMID, geom_id) %>%
- inner_join(distinct(pois_data, hy_id, geom_id, poi_id),
- by = c("hy_id" = "hy_id", "geom_id" = "geom_id")) %>%
- distinct() %>%
- st_as_sf()
-
-write_sf(pois_data, nav_gpkg, poi_data_table)
-write_sf(poi_geometry, nav_gpkg, poi_geometry_table)
-
-poi_geom_xy <- cbind(poi_geometry, st_coordinates(poi_geometry)) %>%
- st_drop_geometry()
-
-events_data <- events %>%
- arrange(COMID) %>%
- cbind(st_coordinates(.)) %>%
- st_drop_geometry() %>%
- group_by(COMID, REACHCODE, REACH_meas) %>%
- mutate(event_id = cur_group_id()) %>%
- rename(hy_id = COMID) %>%
- ungroup()
-
-nexi <- filter(final_POIs_table, nexus == 1) %>%
- cbind(st_coordinates(.)) %>%
- select(hy_id = COMID, X, Y) %>%
- inner_join(poi_geom_xy, by = c("hy_id" = "hy_id", "X" = "X", "Y" = "Y")) %>%
- inner_join(events_data, by = c("hy_id" = "hy_id", "X" = "X", "Y" = "Y"), multiple = "all") %>%
- select(hy_id, REACHCODE, REACH_meas, event_id, poi_id) %>%
- group_by(hy_id, REACHCODE) %>%
- filter(REACH_meas == min(REACH_meas)) %>%
- ungroup()
- #distinct(hy_id, REACHCODE, REACH_meas, event_id, poi_id)
-
-write_sf(select(events_data, -c(nexus, X, Y)), nav_gpkg, event_table)
-write_sf(nexi, nav_gpkg, event_geometry_table)
-
-# Load data
-if(needs_layer(nav_gpkg, lookup_table_refactor)) {
- full_cats <- readRDS(data_paths$fullcats_table)
-
- lookup <- dplyr::select(sf::st_drop_geometry(nhd_Final),
- NHDPlusV2_COMID = COMID,
- realized_catchmentID = COMID,
- mainstem = LevelPathI) %>%
- dplyr::mutate(realized_catchmentID = ifelse(realized_catchmentID %in% full_cats$FEATUREID,
- realized_catchmentID, NA)) %>%
- left_join(select(st_drop_geometry(poi_geometry), hy_id, poi_geom_id = geom_id),
- by = c("NHDPlusV2_COMID" = "hy_id"))
-
- sf::write_sf(lookup, nav_gpkg, lookup_table_refactor)
-}
-```
diff --git a/workspace/02_NHD_navigate_Sp.Rmd b/workspace/02_NHD_navigate_Sp.Rmd
deleted file mode 100644
index 336bc0f4d81f12b06d4c1166294bcf87b6b433c9..0000000000000000000000000000000000000000
--- a/workspace/02_NHD_navigate_Sp.Rmd
+++ /dev/null
@@ -1,822 +0,0 @@
----
-title: "NHD Navigate"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-This notebook Generate Segments and POIS from POI data sources and builds
-a minimally-sufficient stream network connecting all POis, as well as generating first-cut of
-national segment network.
-
-```{r setup_rmd, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=6,
- fig.height=4,
- cache=FALSE)
-```
-
-```{r setup}
-# Load custom functions
-source("R/utils.R")
-source("R/NHD_navigate.R")
-
-# increase timeout for data downloads
-options(timeout=600)
-
-# Load Configuration of environment
-source("R/config.R")
-
-# Gages output from Gage_selection
-gages <- read_sf(gage_info_gpkg, "Gages")
-# need some extra attributes for a few POI analyses
-atts <- readRDS(file.path(data_paths$nhdplus_dir, "nhdplus_flowline_attributes.rds"))
-
-sparrow_dir <- "data/sparrow"
-
-collapse <- TRUE
-```
-
-```{r huc12 POIs}
-# Derive or load HUC12 POIs
-if(needs_layer(temp_gpkg, nav_poi_layer)) {
-
- nhd <- read_sf(nav_gpkg, nhd_flowline)
- try(nhd <- select(nhd, -c(minNet, WB, struct_POI, struct_Net, POI_ID, dend, poi)), silent = TRUE)
-
- # Some NHDPlus VPUs include HUCs from other VPUs
- if(vpu == "02"){
- grep_exp <-"^02|^04"
- } else if (vpu == "08") {
- grep_exp <- "^03|^08"
- } else {
- grep_exp <- paste0("^", substr(vpu, start = 1, stop = 2))
- }
-
- # Join HUC12 outlets with NHD
- HUC12_COMIDs <- read_sf(data_paths$hu12_points_path, "hu_points") %>%
- filter(grepl(grep_exp, .data$HUC12)) %>%
- select(COMID, HUC12) %>%
- # Remove this when HUC12 outlets finished
- group_by(COMID) %>%
- filter(row_number() == 1) %>%
- ungroup()
-
- # Create POIs - some r05 HUC12 POIs not in R05 NHD
- huc12_POIs <- POI_creation(st_drop_geometry(HUC12_COMIDs), nhd, "HUC12")
- tmp_POIs <- huc12_POIs
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(huc12_POIs, temp_gpkg, nav_poi_layer)
- tmp_POIs <- huc12_POIs
-} else {
- # Load HUC12 POIs as the tmpPOIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
-}
-
-mapview(filter(tmp_POIs, Type_HUC12 != ""), layer.name = "HUC12 POIs", col.regions = "red")
-```
-
-```{r streamgage POIs}
-if(!"Type_Gages" %in% names(tmp_POIs)) {
-
- ref_gages <- read_sf("data/ref_gages.gpkg")
-
- # Previously identified streamgages within Gage_Selection.Rmd
- streamgages_VPU <- gages %>%
- rename(COMID = comid) %>%
- filter(COMID %in% nhd$COMID) %>%
- #st_drop_geometry() %>%
- switchDiv(., nhd)
-
- streamgages <- streamgages_VPU %>%
- group_by(COMID) %>%
- # If multiple gages per COMID, pick one with highest rank as rep POI_ID
- filter(gage_score == max(gage_score), !is.na(drain_area)) %>%
- ungroup() %>%
- select(COMID, site_no)
-
- # Derive TE POIs
- tmp_POIs <- POI_creation(st_drop_geometry(streamgages), nhd, "Gages") %>%
- addType(., tmp_POIs, "Gages", nexus = FALSE)
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_Gages)), layer.name = "Streamgage POIs", col.regions = "blue")
-```
-
-# R01 - missing one
-```{r Sparrow Cal POIs}
-if(!"Type_Sparrow" %in% names(tmp_POIs)) {
-
- # Load Sparrow calibration POIs
- sparrow_cal_pois <- read_sf("data/sparrow/sparrow_source.gpkg", "calibration_poi") %>%
- mutate(COMID = as.integer(COMID)) %>%
- filter(COMID %in% nhd$COMID) %>%
- select(COMID, MonitoringLocationIdentifier, site_no, station_nm,
- usgs_hy_id, distance_m, longitude, latitude, nat_id) %>%
- st_as_sf(coords = c("longitude", "latitude"), crs = 4326) %>%
- select(COMID, nat_id)
-
- # Derive TE POIs
- tmp_POIs <- POI_creation(st_drop_geometry(sparrow_cal_pois), nhd, "Sparrow") %>%
- addType(., tmp_POIs, "Sparrow", nexus = FALSE)
-
- missing_sparrow <- filter(sparrow_cal_pois, !nat_id %in% tmp_POIs$Type_Sparrow)
- if(nrow(missing_sparrow) > 0){write_sf(missing_sparrow, temp_gpkg, "missing_sparrow")}
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_Gages)), layer.name = "Streamgage POIs", col.regions = "blue")
-```
-
-```{r TE POIs}
-if(!"Type_TE" %in% names(tmp_POIs)) {
-
- if(vpu == "08"){
- nhd$VPUID <- "08"
- } else {
- nhd$VPUID <- substr(nhd$RPUID, 1, 2)
- }
-
- # Read in Thermoelectric shapefile
- TE_COMIDs <- read_sf(data_paths$TE_points_path, "2015_TE_Model_Estimates_lat.long_COMIDs") %>%
- mutate(COMID = as.integer(COMID)) %>%
- inner_join(., select(st_drop_geometry(nhd), COMID, VPUID), by = "COMID") %>%
- filter(grepl(paste0("^", substr(vpu, 1, 2), ".*"), .data$VPUID), COMID > 0) %>%
- switchDiv(., nhd) %>%
- group_by(COMID) %>%
- summarize(EIA_PLANT = paste0(unique(EIA_PLANT_), collapse = " "), count = n()) %>%
- ungroup() %>%
- select(COMID, EIA_PLANT)
-
- # Derive TE POIs
- tmp_POIs <- POI_creation(st_drop_geometry(TE_COMIDs), nhd, "TE") %>%
- addType(., tmp_POIs, "TE", nexus = FALSE, bind = TRUE)
-
- # As a fail-safe, write out list of TE plants not assigned a POI
- if(nrow(filter(TE_COMIDs, !COMID %in% tmp_POIs$COMID)) > 0) {
- write_sf(filter(TE_COMIDs, !COMID %in% tmp_POIs$COMID),
- temp_gpkg, "unassigned_TE")
- }
-
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- # Load TE POIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-
-mapview(filter(tmp_POIs, Type_TE != ""), layer.name = "TE Plant POIs", col.regions = "blue")
-```
-
-```{r waterbody outlet POIs}
-# Derive or load Waterbody POIs ----------------------
-if(!"Type_WBOut" %in% names(tmp_POIs)) {
-
- sparrow_wb_outlet <- read_sf("data/sparrow/sparrow_source.gpkg", "wb_outlets") %>%
- filter(COMID %in% nhd$COMID)
-
- sparrow_wb <- read_sf("data/sparrow/sparrow_source.gpkg", "waterbodies") %>%
- filter(COMID %in% nhd$WBAREACOMI)
-
- # Waterbodies sourced from NHD waterbody layer for entire VPU
- WBs_VPU_all <- filter(readRDS("data/NHDPlusNationalData/nhdplus_waterbodies.rds"),
- COMID %in% nhd$WBAREACOMI) %>%
- mutate(FTYPE = as.character(FTYPE)) %>%
- mutate(source = "NHDv2WB") %>%
- st_transform(crs)
-
- # Waterbody list that strictly meet the size criteria
- wb_lst <- st_drop_geometry(WBs_VPU_all) %>%
- dplyr::filter(FTYPE %in% c("LakePond", "Reservoir") & AREASQKM >= (min_da_km/2)) %>%
- dplyr::select(COMID) %>%
- filter(!COMID == 166410600) %>%
- rbind(dplyr::select(st_drop_geometry(sparrow_wb), COMID))
-
- if (file.exists(data_paths$resops_NID_CW)){
- # ResOpsUS locations in the VPU waterbody set
- resops_wb_df <- read.csv(data_paths$resops_NID_CW) %>%
- dplyr::filter(WBAREACOMI %in% WBs_VPU_all$COMID) %>%
- dplyr::select(DAM_ID, DAM_NAME, COMID = WBAREACOMI, FlowLcomid) %>%
- distinct()
-
- # Add ResOPsUS locations to waterbody list
- if(nrow(resops_wb_df) > 0){
- wb_lst <- rbind(wb_lst, select(resops_wb_df, COMID)) %>%
- distinct()
- }
- }
-
- # Waterbodies that meet the size criteria and/or are in ResOpsUS datasets
- WBs_VPU <- WBs_VPU_all %>%
- dplyr::filter(COMID %in% wb_lst$COMID)
-
- WBs_VPU <- filter(WBs_VPU, COMID != 666170) #1R16
-
- # Attribute flowlines that are in waterbodies
- nhd <- mutate(nhd, WB = ifelse(WBAREACOMI > 0 & WBAREACOMI %in% WBs_VPU$COMID, 1, 0))
-
- wbout_COMIDs <- nhd %>% #filter(nhd, dend == 1 & WB == 1)
- filter(WBAREACOMI %in% WBs_VPU$COMID) %>%
- filter(!WBAREACOMI %in% sparrow_wb_outlet$WB_COMID) %>%
- group_by(WBAREACOMI) %>%
- slice(which.min(Hydroseq)) %>%
- switchDiv(., nhd) %>%
- select(COMID, WBAREACOMI, LevelPathI) %>%
- st_drop_geometry() %>%
- rbind(select(st_drop_geometry(sparrow_wb_outlet), COMID, WBAREACOMI = WB_COMID))
-
- tmp_POIs <- POI_creation(wbout_COMIDs, nhd, "WBOut") %>%
- addType(., tmp_POIs, "WBOut", nexus = FALSE, bind = TRUE)
-
- # Write out waterbodies
- write_sf(WBs_VPU, nav_gpkg, WBs_layer)
-
- # Write specific ResOpsUS data to a separate sheet
- if(nrow(wb_lst) > 0){
- resops_POIs_df <- st_drop_geometry(tmp_POIs) %>%
- dplyr::select(COMID, Type_WBOut) %>%
- dplyr::filter(!is.na(Type_WBOut)) %>%
- dplyr::inner_join(select(resops_wb_df, -FlowLcomid), by = c("Type_WBOut" = "COMID"))
-
- write.csv(resops_POIs_df, file.path("data/reservoir_Data", paste0("resops_POIs_",vpu,".csv")))
- }
-
-
- wb_out <- filter(tmp_POIs, !is.na(Type_WBOut))
- missing_wb_out <- filter(sparrow_wb_outlet, !WB_COMID %in% wb_out$Type_WBOut)
- missing_wb_out_com <- filter(sparrow_wb_outlet,
- !COMID %in% wb_out$COMID)
- if(nrow(missing_wb_out) > 0){write_sf(missing_wb_out, temp_gpkg, "missing_sparrow_WB")}
- if(nrow(missing_wb_out_com) > 0){write_sf(missing_wb_out_com, temp_gpkg, "missing_sparrow_WBout")}
-
- sparrow_wb_ids <- select(sparrow_wb_outlet, COMID, WB_COMID, nat_id)
-
- tmp_POIs <- tmp_POIs %>%
- left_join(select(st_drop_geometry(sparrow_wb_ids), -COMID), by = c("Type_WBOut" = "WB_COMID")) %>%
- mutate(Type_Sparrow = ifelse(is.na(Type_Sparrow), nat_id, Type_Sparrow)) %>%
- select(-nat_id)
-
- write_sf(nhd, nav_gpkg, nhd_flowline)
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-} else {
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
- nhd <- read_sf(nav_gpkg, nhd_flowline)
- WBs_VPU <- read_sf(nav_gpkg, WBs_layer)
- resops_POIs_df <- read.csv(file.path("data/reservoir_Data", paste0("resops_POIs_",vpu,".csv")))
-}
-
-mapview(filter(tmp_POIs, !is.na(Type_WBOut)), layer.name = "Waterbody outlet POIs", col.regions = "red")
-```
-
-```{r NID POIs}
-# Derive or load NID POIs ----------------------
-if(all(is.na(tmp_POIs$Type_NID))) {
-
- sparrow_nid <- read_sf("data/sparrow/sparrow_source.gpkg", "nid_pois")
-
- sparrow_wb_nid <- sparrow_nid %>%
- #rename(COMID = ComID) %>%
- filter(COMID %in% nhd$COMID) %>%
- select(COMID, NIDID, nat_id)
-
- if(nrow(sparrow_wb_nid) > 0){
- # Determine which NID facilitites have been co-located with ResOps
- res_ops_table <- read.csv(data_paths$resops_NID_CW) %>%
- mutate(new_WBARECOMI = ifelse(is.na(WBAREACOMI) & is.na(NHDAREA), HR_NHDPLUSID, WBAREACOMI)) %>%
- mutate(new_WBARECOMI = ifelse(is.na(new_WBARECOMI) & is.na(HR_NHDPLUSID), NHDAREA, new_WBARECOMI)) %>%
- filter(new_WBARECOMI %in% tmp_POIs$Type_WBOut, !is.na(new_WBARECOMI)) %>%
- select(NID_ID = NID_Source_FeatureID, Type_WBOut = new_WBARECOMI) %>%
- filter()
-
- # Attribute those NID facilities precisely at the outlet
- if(nrow(res_ops_table) > 0){
- tmp_POIs <- tmp_POIs %>%
- left_join(res_ops_table, by = "Type_WBOut") %>%
- mutate(Type_NID = ifelse(!is.na(NID_ID), NID_ID, NA)) %>%
- select(-NID_ID)
-
- sparrow_wb_nid <- filter(sparrow_wb_nid, !NIDID %in% tmp_POIs$Type_NID)
- }
-
- # Derive other NID POIs
- tmp_POIs <- POI_creation(st_drop_geometry(sparrow_wb_nid), nhd, "NID") %>%
- addType(., tmp_POIs, "NID", nexus = FALSE, bind = TRUE) %>%
- left_join(select(st_drop_geometry(sparrow_wb_nid), NIDID, nat_id), by = c("Type_NID" = "NIDID")) %>%
- mutate(Type_Sparrow = ifelse(is.na(Type_Sparrow), nat_id, Type_Sparrow)) %>%
- select(-nat_id)
-
- sparrow_wb_nid_missing <- filter(sparrow_wb_nid, !nat_id %in% tmp_POIs$Type_Sparrow) %>%
- mutate(WB_Comid = paste("Sparrow_nid_", row_number()))
-
- if(nrow(sparrow_wb_nid_missing) > 0){write_sf(sparrow_wb_nid_missing, temp_gpkg, "missing_wb_nid")}
- # Write out geopackage layer representing POIs for given theme
- write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
- mapview(filter(tmp_POIs, Type_NID != ""), layer.name = "NID POIs", col.regions = "blue")
- }
-
-} else {
- # Load NID POIs if they already exist
- tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-}
-```
-
-
-```{r Diversion POIs}
-# # Derive POIs at confluences where they are absent ----------------------
-# if(needs_layer(temp_gpkg, "diversions")) {
-#
-# div_pois_source <- read_sf("data/sparrow/sparrow_source.gpkg", "div_poi") %>%
-# filter(COMID %in% nhd$COMID) %>%
-# select(COMID, nat_id)
-#
-# div_POIs <- POI_creation(st_drop_geometry(div_pois_source), nhd, "Div") %>%
-# mutate(Type_Sparrow = NA, nexus = NA) %>%
-# st_compatibalize(., tmp_POIs)
-#
-# tmp_POIs <- data.table::rbindlist(list(tmp_POIs,
-# select(div_POIs, -c(Type_Div))), fill = TRUE) %>%
-# st_as_sf() %>%
-# left_join(select(st_drop_geometry(div_pois_source), COMID, nat_id), by = "COMID") %>%
-# mutate(Type_Sparrow = ifelse(is.na(Type_Sparrow), nat_id, Type_Sparrow)) %>%
-# select(-nat_id)
-#
-# missing_div <- filter(div_pois_source, !nat_id %in% tmp_POIs$Type_Sparrow)
-# if(nrow(missing_div) > 0){write_sf(missing_div, temp_gpkg, "missing_div")}
-#
-# write_sf(div_pois_source, temp_gpkg, "diversions")
-# # Write out geopackage layer representing POIs for given theme
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-# } else {
-# # Load NID POIs if they already exist
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# }
-```
-
-```{r Confluence POIs}
-# # Derive POIs at confluences where they are absent ----------------------
-# if(all(is.na(tmp_POIs$Type_Conf)) | !"Type_Conf" %in% colnames(tmp_POIs)) {
-#
-# # Navigate upstream from each POI and determine minimally-sufficient network between current POI sets
-# up_net <- unique(unlist(lapply(unique(tmp_POIs$COMID), NetworkNav, nhd)))
-# finalNet <- unique(NetworkConnection(up_net, st_drop_geometry(nhd)))
-#
-# # Subset NHDPlusV2 flowlines to navigation results and write to shapefile
-# nhd <- mutate(nhd, minNet = ifelse(COMID %in% finalNet, 1, 0))
-#
-# # Create new confluence POIs
-# conf_COMIDs <- st_drop_geometry(filter(nhd, minNet == 1)) %>%
-# # Downstream hydrosequence of 0 indicates
-# # the flowline is terminating or
-# # leaving the domain, so they
-# # are excluded from this process
-# filter(DnHydroseq > 0) %>%
-# group_by(DnHydroseq) %>%
-# filter(n()> 1) %>%
-# mutate(Type_Conf = LevelPathI) %>%
-# ungroup() %>%
-# select(COMID, Type_Conf)
-#
-# tmp_POIs <- POI_creation2(conf_COMIDs, filter(nhd, minNet == 1), "Conf") %>%
-# addType2(., tmp_POIs, "Conf", nexus = FALSE, bind = TRUE)
-#
-# write_sf(nhd, nav_gpkg, nhd_flowline)
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-# } else {
-# nhd <- read_sf(nav_gpkg, nhd_flowline)
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# }
-#
-# mapview(filter(tmp_POIs, !is.na(Type_Conf)), layer.nameble = "Confluence POIs", col.regions = "blue")
-```
-
-```{r Terminal POIs}
-# # Derive or load Terminal POIs ----------------------
-# if(all(is.na(tmp_POIs$Type_Term))) {
-#
-# # Terminal POIs on levelpaths with upstream POIs
-# term_paths <- filter(st_drop_geometry(nhd), Hydroseq %in% filter(nhd, COMID %in% tmp_POIs$COMID)$TerminalPa)
-#
-# # Non-POI levelpath terminal pois, but meet size criteria
-# terminal_POIs <- st_drop_geometry(nhd) %>%
-# filter(Hydroseq == TerminalPa | (toCOMID == 0 | is.na(toCOMID) | !toCOMID %in% COMID)) %>%
-# filter(!COMID %in% term_paths$COMID, TotDASqKM >= min_da_km) %>%
-# bind_rows(term_paths) %>%
-# # Use level path identifier as Type ID
-# select(COMID, LevelPathI)
-#
-# tmp_POIs <- POI_creation2(terminal_POIs, nhd, "Term") %>%
-# addType2(., tmp_POIs, "Term", nexus = FALSE, bind = TRUE)
-#
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-# } else {
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# nhd <- read_sf(nav_gpkg, nhd_flowline)
-# }
-#
-# mapview(filter(tmp_POIs, !is.na(Type_Term)), layer.name = "Terminal POIs", col.regions = "blue")
-```
-
-```{r waterbody inlet POIs}
-# # Derive or load Waterbody POIs ----------------------
-# if(all(is.na(tmp_POIs$Type_WBIn))) {
-#
-# sparrow_inlets <- read_sf("data/sparrow/sparrow_source.gpkg", "wb_inlets") %>%
-# filter(COMID %in% nhd$COMID)
-#
-# WBs_VPU <- filter(WBs_VPU, COMID != 666170) #1R16
-#
-# wbout_COMIDs <- filter(tmp_POIs, !is.na(Type_WBOut))
-# nhd_out <- filter(nhd, COMID %in% wbout_COMIDs$COMID)
-#
-# # Create waterbody inlet POIs
-# wbin_COMIDs <- filter(nhd, WB == 0,
-# DnHydroseq %in% filter(nhd, WB == 1)$Hydroseq) %>%
-# select(-WBAREACOMI) %>%
-# switchDiv(., nhd) %>%
-# inner_join(st_drop_geometry(filter(nhd, minNet == 1)) %>%
-# select(Hydroseq, WBAREACOMI), by = c("DnHydroseq" = "Hydroseq")) %>%
-# select(COMID, WBAREACOMI, minNet) %>%
-# group_by(COMID) %>%
-# # Ensure the inlets are on the network defined by confluence POIs
-# filter(minNet == 1) %>%
-# select(COMID, WBAREACOMI)
-#
-# # Headwater Waterbodies that may need the network extended through the inlet
-# need_wbin <- st_drop_geometry(filter(WBs_VPU, source == "NHDv2WB")) %>%
-# dplyr::select(COMID)%>%
-# dplyr::filter(!COMID %in% wbin_COMIDs$WBAREACOMI)
-#
-# up_lp <- filter(nhd, LevelPathI %in% nhd_out$LevelPathI,
-# WBAREACOMI %in% need_wbin$COMID) %>%
-# group_by(WBAREACOMI) %>%
-# filter(n() > 1, StartFlag != 1) %>%
-# slice(which.min(Hydroseq))
-#
-# wbin_pois <- select(nhd, COMID, DnHydroseq, LevelPathI) %>%
-# inner_join(select(st_drop_geometry(up_lp), Hydroseq, WBAREACOMI, LevelPathI),
-# by = c("DnHydroseq" = "Hydroseq", "LevelPathI" = "LevelPathI")) %>%
-# select(COMID, WBAREACOMI) %>%
-# rbind(wbin_COMIDs)
-#
-# tmp_POIs <- POI_creation2(st_drop_geometry(wbin_pois), nhd, "WBIn") %>%
-# addType2(., tmp_POIs, "WBIn", nexus = FALSE, bind = TRUE)
-#
-# tmp_POIs <- tmp_POIs %>%
-# left_join(select(st_drop_geometry(sparrow_inlets), WB_COMID, nat_id),
-# by = c("Type_WBIn" = "WB_COMID"), multiple = "all") %>%
-# mutate(Type_Sparrow = ifelse(is.na(Type_Sparrow), nat_id, Type_Sparrow)) %>%
-# select(-nat_id)
-#
-# missing_wb_in <- filter(sparrow_inlets, !nat_id %in% tmp_POIs$Type_Sparrow |
-# !WB_COMID %in% tmp_POIs$Type_WBIn)
-#
-# if(nrow(missing_wb_in) > 0){write_sf(missing_wb_in, temp_gpkg, "missing_wbin")}
-# #tmp_POIs$nexus <- ifelse(is.na(tmp_POIs$nexus), FALSE, tmp_POIs$nexus)
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-# } else {
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# nhd <- read_sf(nav_gpkg, nhd_flowline)
-# }
-#
-# mapview(filter(tmp_POIs, !is.na(Type_WBIn)), layer.name = "Waterbody inlet POIs", col.regions = "blue") +
-# mapview(filter(tmp_POIs, !is.na(Type_WBOut)), layer.name = "Waterbody outlet POIs", col.regions = "red")
-```
-
-
-This chunk breaks up potential aggregated segments where the elevation range of the are contributing to the segment exceeds 500-m
-```{r Elevation Break POIs}
-# # derive incremental segments from POIs
-# inc_segs <- segment_increment(filter(nhd, minNet == 1),
-# filter(st_drop_geometry(nhd),
-# COMID %in% tmp_POIs$COMID, COMID %in% filter(nhd, minNet == 1)$COMID)) %>%
-# # bring over VAA data
-# inner_join(select(atts, COMID, DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO,
-# MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE,
-# AreaSqKM, TotDASqKM), by = "COMID")
-#
-# # Build dataframe for creation of points based on breaks
-# elev_pois_split <- inc_segs %>%
-# group_by(POI_ID) %>%
-# # Get elevation info
-# mutate(MAXELEVSMO = na_if(MAXELEVSMO, -9998), MINELEVSMO = na_if(MINELEVSMO, -9998),
-# elev_diff_seg = max(MINELEVSMO) - min(MINELEVSMO)) %>%
-# # Filter out to those incremental segments that need splitting above the defined elevation threshold
-# filter((max(MINELEVSMO) - min(MINELEVSMO)) > (elev_diff * 100)) %>%
-# # Do not aggregate on fake lfowlines
-# filter(AreaSqKM > 0, TotDASqKM > max_elev_TT_DA) %>%
-# # Order from upstream to downstream
-# arrange(desc(Hydroseq)) %>%
-# # Get attributes used for splitting
-# # csum_length = cumulative length US to DS along segment, cumsum_elev = cumulative US to DS elev diff along segment
-# # inc_elev = elevation range of each segment
-# # iter = estimated number of times we'd need to split existing agg flowlines, or number of rows in set
-# mutate(csum_length = cumsum(LENGTHKM),
-# inc_elev = cumsum(MINELEVSMO - MINELEVSMO),
-# #nc_elev_diff = c(inc_elev[1], (inc_elev - lag(inc_elev))[-1]),
-# iter = min(round(max(inc_elev) / (elev_diff * 100)), n()),
-# elev_POI_ID = NA) %>%
-# # Remove segments we can't break
-# filter(iter > 0, n() > 1) %>%
-# # Track original iteration number
-# mutate(orig_iter = iter) %>%
-# ungroup()
-#
-# if(nrow(elev_pois_split) > 0) {
-#
-# # For reach iteration
-# elev_POIs <- do.call("rbind", lapply(unique(elev_pois_split$POI_ID), split_elev,
-# elev_pois_split, elev_diff*100, max_elev_TT_DA)) %>%
-# filter(!elev_POI_ID %in% tmp_POIs$COMID, COMID == elev_POI_ID) %>%
-# mutate(Type_Elev = 1) %>%
-# select(COMID, Type_Elev) %>%
-# unique()
-#
-# if(nrow(elev_POIs) > 0){
-# tmp_POIs <- POI_creation(select(elev_POIs, COMID, Type_Elev), nhd, "Elev") %>%
-# addType(., tmp_POIs, "Elev")
-# }
-#
-#
-# } else {
-#
-# tmp_POIs$Type_Elev <- rep(NA, nrow(tmp_POIs))
-#
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-#
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# nhd <- read_sf(nav_gpkg, nhd_flowline)
-# }
-#
-# if(!all(is.na(tmp_POIs$Type_Elev)))
-# mapview(filter(tmp_POIs, Type_Elev == 1), layer.name = "Elevation break POIs", col.regions = "blue")
-```
-
-```{r Time of travel POIs}
-# if(all(is.na(tmp_POIs$Type_Travel))) {
-#
-# # derive incremental segments from POIs
-# inc_segs <- segment_increment(filter(nhd, minNet == 1),
-# filter(st_drop_geometry(nhd),
-# COMID %in% tmp_POIs$COMID, COMID %in% filter(nhd, minNet == 1)$COMID)) %>%
-# # bring over VAA data
-# inner_join(select(atts, COMID, DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO, MINELEVSMO,
-# WBAREACOMI, WBAreaType, FTYPE,
-# AreaSqKM, TotDASqKM), by = "COMID")
-#
-# # TT POIs
-# tt_pois_split <- inc_segs %>%
-# # Should we substitute with a very small value
-# mutate(VA_MA = ifelse(VA_MA < 0, NA, VA_MA)) %>%
-# mutate(FL_tt_hrs = (LENGTHKM * ft_per_km)/ VA_MA / s_per_hr ) %>%
-# group_by(POI_ID) %>%
-# filter(sum(FL_tt_hrs) > travt_diff, TotDASqKM > max_elev_TT_DA) %>%
-# # Sort upstream to downsream
-# arrange(desc(Hydroseq)) %>%
-# # Get cumulative sums of median elevation
-# mutate(csum_length = cumsum(LENGTHKM),
-# cumsum_tt = cumsum(FL_tt_hrs),
-# iter = min(round(sum(FL_tt_hrs) / travt_diff), n()),
-# tt_POI_ID = NA) %>%
-# # Only look to split segments based on travel time longer than 10 km
-# #filter(sum(LENGTHKM) > (split_meters/1000)) %>%
-# filter(iter > 0, n() > 1) %>%
-# # Track original iteration number
-# mutate(orig_iter = iter) %>%
-# ungroup()
-#
-# # For reach iteration
-# tt_POIs <- do.call("rbind", lapply(unique(tt_pois_split$POI_ID), split_tt,
-# tt_pois_split, travt_diff, max_elev_TT_DA)) %>%
-# filter(!tt_POI_ID %in% tmp_POIs$COMID, COMID == tt_POI_ID) %>%
-# mutate(Type_Travel = 1) %>%
-# select(COMID, Type_Travel) %>%
-# unique()
-#
-# tmp_POIs <- POI_creation2(select(tt_POIs, COMID, Type_Travel), nhd, "Travel") %>%
-# addType2(., tmp_POIs, "Travel", nexus = FALSE, bind = TRUE)
-#
-# write_sf(tmp_POIs, temp_gpkg, nav_poi_layer)
-# }else{
-# tmp_POIs <- read_sf(temp_gpkg, nav_poi_layer)
-# nhd <- read_sf(nav_gpkg, nhd_flowline)
-# }
-#
-# mapview(filter(tmp_POIs, Type_Travel == 1), layer.name = "Travel time break POIs", col.regions = "blue")
-```
-
-```{r Final POIs}
-# # Derive final POI set ----------------------
-# if(needs_layer(nav_gpkg, pois_all_layer)) {
-#
-# unCon_POIs <- filter(nhd, COMID %in% tmp_POIs$COMID, AreaSqKM == 0) %>%
-# distinct()
-#
-# # If any POIs happened to fall on flowlines w/o catchment
-# if (nrow(unCon_POIs) >0){
-# # For confluence POIs falling on Flowlines w/o catchments, derive upstream valid flowline,
-# poi_fix <- DS_poiFix2(tmp_POIs, nhd %>% distinct())
-# new_POIs <- st_compatibalize(poi_fix$new_POIs, tmp_POIs)
-# xWalk <- distinct(poi_fix$xWalk)
-# not_matched <- distinct(poi_fix$unmatched)
-#
-# # POIs that didn't need to be moved
-# tmp_POIs_fixed <- filter(tmp_POIs, nexus == TRUE |
-# !COMID %in% c(poi_fix$xWalk$oldPOI, poi_fix$xWalk$COMID))
-# # bind together
-# final_POIs <- bind_rows(tmp_POIs_fixed, select(poi_fix$new_POIs, -c(oldPOI, to_com)))
-#
-# # if a POI will be a nexus, it can not be terminal.
-# final_POIs <- mutate(final_POIs, Type_Term = ifelse(nexus == 1, NA, Type_Term))
-#
-# # Write out fixes
-# write_sf(new_POIs, temp_gpkg, poi_moved_layer)
-# write_sf(xWalk, temp_gpkg, poi_xwalk_layer)
-# # write out final POIs
-# write_sf(final_POIs, nav_gpkg, pois_all_layer)
-# write_sf(not_matched, temp_gpkg, "on_zeroDA")
-# } else {
-# # If no fixes designate as NA
-# xWalk <- NA
-#
-# tmp_POIs$nexus <- as.integer(tmp_POIs$nexus)
-#
-# # if a POI will be a nexus, it can not be terminal.
-# tmp_POIs <- mutate(tmp_POIs, Type_Term = ifelse(nexus == 1, NA, Type_Term))
-#
-# # write out final POIs
-# write_sf(tmp_POIs, temp_gpkg, pois_all_layer)
-# final_POIs <- tmp_POIs
-# }
-#
-# } else {
-# # Need all three sets for attribution below
-# final_POIs <- read_sf(nav_gpkg, pois_all_layer)
-# new_POIs <- if(!needs_layer(temp_gpkg, poi_moved_layer)) read_sf(temp_gpkg, poi_moved_layer) else (NA)
-# xWalk <- if(!needs_layer(temp_gpkg, poi_xwalk_layer)) read_sf(temp_gpkg, poi_xwalk_layer) else (NA)
-# unCon_POIs <- filter(st_drop_geometry(filter(nhd, minNet == 1)),
-# COMID %in% tmp_POIs$COMID, AreaSqKM == 0)
-# }
-```
-
-```{r Draft nsegment generation}
-# if(needs_layer(temp_gpkg, nsegments_layer)) {
-#
-# # Sort POIs by Levelpath and Hydrosequence in upstream to downstream order
-# seg_POIs <- filter(st_drop_geometry(nhd),
-# COMID %in% tmp_POIs$COMID, COMID %in% filter(nhd, minNet == 1)$COMID)
-# # derive incremental segments from POIs
-# inc_segs <- segment_increment(filter(nhd, minNet == 1), seg_POIs)
-#
-# nhd_Final <- nhd %>%
-# left_join(select(inc_segs, COMID, POI_ID), by = "COMID")
-#
-# # create and write out final dissolved segments
-# nsegments_fin <- segment_creation(nhd_Final, xWalk)
-#
-# nhd_Final <- select(nhd_Final, -POI_ID) %>%
-# left_join(select(st_drop_geometry(nsegments_fin$raw_segs), COMID, POI_ID), by = "COMID")
-# nsegments <- nsegments_fin$diss_segs
-#
-# # Produce the minimal POIs needed to derive the network based on LP and terminal outlets
-# strucFeat <- structPOIsNet(nhd_Final, final_POIs)
-# nhd_Final <- nhd_Final %>%
-# mutate(struct_POI = ifelse(COMID %in% strucFeat$struc_POIs$COMID, 1, 0),
-# struct_Net = ifelse(COMID %in% strucFeat$structnet$COMID, 1, 0))
-#
-# write_sf(nhd_Final, nav_gpkg, nhd_flowline)
-# write_sf(nsegments, temp_gpkg, nsegments_layer)
-# } else {
-# # Read in NHDPlusV2 flowline simple features and filter by vector processing unit (VPU)
-# final_POIs <- read_sf(nav_gpkg, pois_all_layer)
-# nhd_Final <- read_sf(nav_gpkg, nhd_flowline)
-# nsegments <- read_sf(temp_gpkg, nsegments_layer)
-# }
-#
-# # Ensure that all the problem POIs have been taken care of
-# sub <- nhd_Final %>% filter(COMID %in% final_POIs$COMID)
-# print (paste0(nrow(sub[sub$AreaSqKM == 0,]), " POIs on flowlines with no local drainage contributions"))
-# noDA_pois <- filter(final_POIs, COMID %in% filter(sub, AreaSqKM == 0)$COMID)
-# write_sf(noDA_pois, temp_gpkg, "noDA_pois")
-```
-
-# Start from here next time
-```{r POI Collapse}
-# # number POIs
-# final_POIs <- mutate(final_POIs, id = row_number(), moved = NA)
-# write_sf(final_POIs, nav_gpkg, pois_all_layer)
-#
-# # Load data
-# if(collapse){
-#
-# # Move HUC12 to other POIs
-# huc_to_poi <- poi_move(final_POIs, "Type_HUC12", .10, 2.5)
-# move_table <- huc_to_poi$moved_points %>%
-# mutate(move_cat = "HUC12 to other")
-#
-# # Gages to confluences
-# gage_to_conf <- poi_move(huc_to_poi$final_pois, "Type_Gages", .05, 2.5, "Type_Conf") # 47
-# move_table <- gage_to_conf$moved_points %>%
-# mutate(move_cat = "Gage to conf") %>%
-# rbind(move_table)
-#
-# # Gages to waterbody inlets
-# gage_to_wbin <- poi_move(gage_to_conf$final_pois, "Type_Gages", .05, 2.5, "Type_WBIn") # 2
-# move_table <- gage_to_wbin$moved_points %>%
-# mutate(move_cat = "Gage to WBin") %>%
-# rbind(move_table)
-#
-# # Gages to waterbody outlets
-# gage_to_wbout <- poi_move(gage_to_wbin$final_pois, "Type_Gages", .05, 2.5, "Type_WBOut") # 6
-# move_table <- gage_to_wbout$moved_points %>%
-# mutate(move_cat = "Gage to WBout") %>%
-# rbind(move_table)
-#
-# # Streamgage to term outlet
-# gage_to_term <- poi_move(gage_to_wbout$final_pois, "Type_Gages", .05, 2.5, "Type_Term")
-# # NID to waterbody outlet
-# nid_to_wbout <- poi_move(gage_to_wbout$final_pois, "Type_NID", .025, 1, "Type_WBOut")
-#
-# # Sparrow to confluence
-# sparrow_to_conf <- poi_move(gage_to_wbout$final_pois, "Type_Sparrow", .05, 2.5, "Type_Conf")
-# move_table <- sparrow_to_conf$moved_points %>%
-# mutate(move_cat = "Sparrow to Conf") %>%
-# rbind(move_table)
-#
-# # Sparrow to WBoutlet
-# sparrow_to_wbout <- poi_move(sparrow_to_conf$final_pois, "Type_Sparrow", .05, 2.5, "Type_WBOut")
-# # Sparrow to WBInlet
-# sparrow_to_wbin <- poi_move(gage_to_wbout$final_pois, "Type_Sparrow", .05, 2.5, "Type_WBIn")
-#
-# POIs <- sparrow_to_conf$final_pois
-# write_sf(POIs, nav_gpkg, final_poi_layer)
-# write_sf(move_table, temp_gpkg, "pois_collapsed")
-# } else {
-# write_sf(final_POIs, nav_gpkg, final_poi_layer)
-# POIs <- final_POIs
-# }
-```
-
-# ```{r lookup}
-# # Final POI layer
-# POIs <- POIs %>%
-# arrange(COMID) %>%
-# mutate(identifier = row_number())
-#
-# # Unique POI geometry
-# final_POI_geom <- POIs %>%
-# select(identifier) %>%
-# cbind(st_coordinates(.)) %>%
-# group_by(X, Y) %>%
-# mutate(geom_id = cur_group_id()) %>%
-# ungroup()
-#
-# final_POIs_table <- POIs %>%
-# inner_join(select(st_drop_geometry(final_POI_geom), -X, -Y), by = "identifier") %>%
-# select(-identifier)
-#
-# # POI data theme table
-# pois_data_table <- reshape2::melt(st_drop_geometry(select(final_POIs_table,
-# -nexus)),
-# id.vars = c("COMID", "geom_id")) %>%
-# filter(!is.na(value)) %>%
-# group_by(COMID, geom_id) %>%
-# mutate(identifier = cur_group_id()) %>%
-# rename(hy_id = COMID, poi_id = identifier, hl_reference = variable, hl_link = value) %>%
-# distinct()
-#
-# # POI Geometry table
-# poi_geometry_table <- select(final_POIs_table, hy_id = COMID, geom_id) %>%
-# inner_join(distinct(pois_data_table, hy_id, geom_id, poi_id),
-# by = c("hy_id" = "hy_id", "geom_id" = "geom_id")) %>%
-# distinct()
-#
-# write_sf(pois_data_table, nav_gpkg, "poi_data")
-# write_sf(poi_geometry_table, nav_gpkg, "poi_geometry")
-#
-# # Create xwalk table
-# if(needs_layer(nav_gpkg, lookup_table_refactor)) {
-# full_cats <- readRDS(data_paths$fullcats_table)
-#
-# lookup <- dplyr::select(sf::st_drop_geometry(nhd_Final),
-# NHDPlusV2_COMID = COMID,
-# realized_catchmentID = COMID,
-# mainstem = LevelPathI) %>%
-# dplyr::mutate(realized_catchmentID = ifelse(realized_catchmentID %in% full_cats$FEATUREID,
-# realized_catchmentID, NA)) %>%
-# left_join(select(st_drop_geometry(poi_geometry_table), hy_id, poi_geom_id = geom_id),
-# by = c("NHDPlusV2_COMID" = "hy_id"))
-#
-# sf::write_sf(lookup, nav_gpkg, lookup_table_refactor)
-# }
-#
-# ```
diff --git a/workspace/03_hyRefactor_flines.Rmd b/workspace/03_hyRefactor_flines.Rmd
deleted file mode 100644
index cabb6c3a42fccc4b00cc77f84ca78b55f1371437..0000000000000000000000000000000000000000
--- a/workspace/03_hyRefactor_flines.Rmd
+++ /dev/null
@@ -1,198 +0,0 @@
----
-title: "NHD Navigate"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-
-Project: GFv2.0
-Script purpose: Run hyRefactor workflow on flowline network
-Date: 2/29/2019
-Author: [Dave Blodgett](dblodgett@usgs.gov)
-Notes:
-
-```{r setup_0, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=6,
- fig.height=4,
- cache=FALSE)
-```
-
-Load functions and configuration.
-See `hyRefactory_config.R` for all constants.
-```{r setup}
-source("R/utils.R")
-source("R/config.R")
-source("R/user_vars.R")
-```
-
-Load and filter source NHD Flowline network. Bring in POIs
-```{r flowlines}
-nhd <- read_sf(out_refac_gpkg, nhd_flowline)
-
-#cats <- read_sf(out_refac_gpkg, nhd_catchment)
-
-POIs_data <- read_sf(nav_gpkg, poi_data_table)
-
-POIs <- read_sf(nav_gpkg, poi_geometry_table)
-
-POI_id <- st_drop_geometry(POIs)
-
-events <- read_sf(nav_gpkg, event_geometry_table)
-```
-
-Read POIs and add nhd outlets. Save to a non-spatial table.
-```{r refactor}
-POIs_ref <- POIs %>%
- inner_join(select(st_drop_geometry(nhd), TotDASqKM, COMID, DnHydroseq), by = c("hy_id" = "COMID"))
-
-# Also need to avoid modification to flowlines immediately downstream of POIs
-# This can cause some hydrologically-incorrect catchment aggregation
-POI_downstream <- filter(nhd, Hydroseq %in% POIs_ref$DnHydroseq, AreaSqKM > 0)
-
-# build final outlets set
-term_poi <- filter(POIs_data, hl_reference == "Type_Term")
-
-outlets <- POIs_ref %>%
- mutate(type = ifelse(poi_id %in% term_poi$poi_id, "terminal", "outlet"))
-
-# derive list of unique terminal paths
-TerminalPaths <- unique(nhd$TerminalPa)
-
-# Need to avoid refactoring catchments that are long and thing and
-# reasonably large. They cause problems in a downstream step.
-avoid <- dplyr::filter(nhd, (sqrt(AreaSqKM) / LENGTHKM) > 3 & AreaSqKM > 1)
-
-# attribute flowline network used for refactor
-nhd <- mutate(nhd, refactor = ifelse(TerminalPa %in% TerminalPaths, 1, 0))
-write_sf(nhd, out_refac_gpkg, nhd_flowline)
-
-# Prep flowlines for refactor
-nhdplus_flines <- sf::st_zm(filter(nhd, refactor == 1)) %>%
- st_as_sf()
-
-if(!needs_layer(nav_gpkg, event_geometry_table)){
- events <- read_sf(nav_gpkg, event_geometry_table)
-
- events_ref <- filter(events, hy_id %in% nhdplus_flines$COMID) %>%
- rename(COMID = hy_id) %>%
- distinct(COMID, REACHCODE, REACH_meas,
- poi_id, geom) %>%
- arrange(poi_id) %>%
- mutate(event_identifier = row_number())
-
- outlets <- rename(outlets, COMID = hy_id) %>%
- filter(!poi_id %in% events_ref$poi_id)
-} else {
- events_ref <- NULL
-}
-
-if(needs_layer(out_refac_gpkg, refactored_layer)) {
-
- tf <- paste0("temp/refactored_", rpu_code,".gpkg")
- tr <- paste0("temp/reconciled_", rpu_code, ".gpkg")
-
- unlink(list(tf, tr))
- refactor_nhdplus(nhdplus_flines = dplyr::select(nhdplus_flines, -FTYPE), # Select controls whether prepare_nhdplus is used.
- split_flines_meters = split_meters,
- split_flines_cores = para_split_flines,
- collapse_flines_meters = combine_meters,
- collapse_flines_main_meters = combine_meters,
- out_refactored = tf,
- out_reconciled = tr,
- three_pass = TRUE,
- purge_non_dendritic = FALSE,
- events = events_ref,
- exclude_cats = c(outlets$COMID,
- avoid$COMID, POI_downstream$COMID),
- warn = TRUE)
-
- write_sf(st_transform(read_sf(tf), proj_crs), out_refac_gpkg, refactored_layer)
- write_sf(st_transform(read_sf(tr), proj_crs), out_refac_gpkg, reconciled_layer)
-
- unlink(list(tf, tr))
- rm(tf, tr)
-}
-```
-
-```{r lookup}
-# create lookup for ref flowlines to use in the non-dendritic steps
-refactor_lookup <- st_drop_geometry(read_sf(out_refac_gpkg, reconciled_layer)) %>%
- dplyr::select(ID, member_COMID) %>%
- dplyr::mutate(member_COMID = strsplit(member_COMID, ",")) %>%
- tidyr::unnest(cols = member_COMID) %>%
- dplyr::mutate(NHDPlusV2_COMID = as.integer(member_COMID)) %>% # note as.integer truncates
- dplyr::rename(reconciled_ID = ID)
-
-if(is.character(refactor_lookup$reconciled_ID)) refactor_lookup$reconciled_ID <- as.integer(refactor_lookup$reconciled_ID)
-
-lookup_table <- tibble::tibble(NHDPlusV2_COMID = unique(as.integer(refactor_lookup$member_COMID))) %>%
- dplyr::left_join(refactor_lookup, by = "NHDPlusV2_COMID")
-
-readr::write_csv(lookup_table, lookup_table_file)
-write_sf(lookup_table, out_refac_gpkg, lookup_table_refactor)
-
-if(needs_layer(out_refac_gpkg, outlets_layer)) {
-
- # Join refactored to original NHD
- refactored <- read_sf(out_refac_gpkg, refactored_layer) %>%
- select(member_COMID = COMID, Hydroseq, event_identifier, event_REACHCODE) %>%
- inner_join(select(st_drop_geometry(nhd), orig_COMID = COMID, Hydroseq), by = "Hydroseq")
-
- if(nrow(events_ref) > 0){
- # Subset for events
- refactored_events <- refactored %>%
- filter(!is.na(event_REACHCODE), !is.na(event_identifier)) %>%
- mutate(event_identifier = as.numeric(event_identifier))
-
- event_outlets <- events_ref %>%
- inner_join(st_drop_geometry(refactored_events), by = "event_identifier") %>%
- select(hy_id = COMID, event_id = event_identifier, poi_id, member_COMID)%>%
- inner_join(select(lookup_table, -NHDPlusV2_COMID), by = "member_COMID")
-
- # subset for refactored outlets (non-events)
- refactored_outlets <- filter(refactored,
- !member_COMID %in% event_outlets$member_COMID)
-
- # get ref_COMId for other outlets
- outlets_ref <- outlets %>%
- filter(!poi_id %in% event_outlets$poi_id) %>%
- inner_join(lookup_table,
- by = c("COMID" = "NHDPlusV2_COMID")) %>%
- group_by(COMID) %>%
- filter(member_COMID == max(member_COMID)) %>%
- select(hy_id = COMID, poi_id, member_COMID, reconciled_ID, type)
-
- outlets_ref_COMID <- data.table::rbindlist(list(outlets_ref, event_outlets),
- fill = TRUE) %>%
- st_as_sf()
- } else {
- # get ref_COMId for other outlets
- outlets_ref_COMID <- outlets %>%
- inner_join(lookup_table,
- by = c("COMID" = "NHDPlusV2_COMID")) %>%
- group_by(COMID) %>%
- filter(member_COMID == max(member_COMID)) %>%
- select(hy_id = COMID, poi_id, member_COMID, reconciled_ID, type)
- }
-
- write_sf(outlets_ref_COMID, out_refac_gpkg, outlets_layer)
-} else {
- outlets_ref_COMID <- read_sf(out_refac_gpkg, outlets_layer)
-}
-
-check_dups_poi <- outlets_ref_COMID %>%
- group_by(reconciled_ID) %>%
- filter(n() > 1) %>%
- ungroup()
-
-if(nrow(check_dups_poi) > 1){
- print("Double-check for double POIs")
- write_sf(check_dups_poi, out_refac_gpkg, paste0(dup_pois, "_", rpu_code))
-} else {
- print("no double POIs detected")
-}
-```
-
diff --git a/workspace/04-1_hyRefactor_cats.Rmd b/workspace/04-1_hyRefactor_cats.Rmd
deleted file mode 100644
index e920d7a8b7af7953e907cf6cf0fcb49bf3d3fcca..0000000000000000000000000000000000000000
--- a/workspace/04-1_hyRefactor_cats.Rmd
+++ /dev/null
@@ -1,76 +0,0 @@
----
-title: "Reconcile Catchments"
-output: html_document
----
-
-Project: GFv2.0
-Script purpose: Run hyRefactor workflow on catchments
-Date: 2/29/2019
-Author: [Dave Blodgett](dblodgett@usgs.gov)
-Notes: Assumes that hyRefactor_flines.Rmd has previously been run.
-
-```{r setup_0, echo=FALSE, cache=FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=10,
- fig.height=8)
-```
-
-Load functions and configuration.
-See `config.R` for all constants.
-```{r libs}
-source("R/utils.R")
-source("R/config.R")
-source("R/user_vars_ww.R")
-source("R/NHD_navigate.R")
-source("R/user_vars.R")
-```
-
-This reconcile-catchments step splits and combines catchment boundaries according to the process that was completed in refactor flines.
-```{r reconcile_catchments}
-if(needs_layer(out_refac_gpkg, divide_layer)) {
-
- rpu_string <- paste0("rpu_", rpu_code)
- fdr <- data_paths$fdr[[rpu_string]]
- fac <- data_paths$fac[[rpu_string]]
-
- fdr_temp <- terra::rast(fdr)
- raster_crs <- terra::crs(fdr_temp)
-
- # reconciled have no ID applied in refactoring flowlines
- reconciled <- st_transform(read_sf(out_refac_gpkg, reconciled_layer), raster_crs)
- # refactored has the original COMIDs and other attributes
- refactored <- st_transform(read_sf(out_refac_gpkg, refactored_layer), raster_crs) %>%
- distinct(.keep_all = T)
-
- cats <- st_transform(read_sf(out_refac_gpkg, nhd_catchment), raster_crs)
-
- divides <- reconcile_catchment_divides(catchment = cats,
- fline_ref = refactored,
- fline_rec = reconciled,
- fdr = fdr,
- fac = fac,
- para = para_reconcile,
- cache = cache_split,
- keep = NULL)
-
- if(exists("divides")) {
-
- load(cache_split)
-
- split_cats <- bind_rows(split_cats[lengths(split_cats) > 0])
-
- split_cats$areasqkm <- as.numeric(units::set_units(sf::st_area(split_cats), "km^2"))
-
- write_sf(sf::st_transform(split_cats, proj_crs), out_refac_gpkg, split_divide_layer)
-
- rm(split_cats)
- }
-
- unlink(cache_split)
- write_sf(sf::st_transform(divides, proj_crs), out_refac_gpkg, divide_layer)
-}
-
-sf::st_layers(out_refac_gpkg)
-```
\ No newline at end of file
diff --git a/workspace/04-2_aggregate_cats.Rmd b/workspace/04-2_aggregate_cats.Rmd
deleted file mode 100644
index bb49aa1f076d253620ad695f2bfbb06b7441571f..0000000000000000000000000000000000000000
--- a/workspace/04-2_aggregate_cats.Rmd
+++ /dev/null
@@ -1,222 +0,0 @@
----
-title: "hyRefactor Catchments"
-output: html_document
----
-
-Project: GFv2.0
-Script purpose: Run hyRefactor workflow on catchments
-Date: 2/29/2019
-Author: [Dave Blodgett](dblodgett@usgs.gov)
-Notes: Assumes that hyRefactor_flines.Rmd has previously been run.
-
-```{r setup_0, cache=FALSE, echo = FALSE}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=10,
- fig.height=8)
-```
-
-Load functions and configuration.
-See `hyRefactory_config.R` for all constants.
-```{r setup}
-source("R/utils.R")
-source("R/config.R")
-source("R/user_vars.R")
-source("R/NHD_navigate.R")
-source("R/user_vars.R")
-```
-
-Derive set of outlets to aggregate catchments for. There are three sets of
-locations loaded below: POIs, outlets, and events. These are reconciled
-into a single set of HRU outlets and all identifiers mapped
-to the id scheme used by the refactored network. "mapped_outlets_all" is the
-result of this block.
-```{r POIs/outlets}
-# Load nhd and outlets
-nhd <- read_sf(out_refac_gpkg, nhd_flowline)
-
-# Load outlets
-outlets_POI <- read_sf(out_refac_gpkg, outlets_layer) %>%
- distinct() %>%
- filter(hy_id %in% nhd$COMID)
-
-POIs_data <- read_sf(nav_gpkg, poi_data_table)
-
-# reconciled have no ID applied in refactoring flowlines
-reconciled <- st_transform(read_sf(out_refac_gpkg, reconciled_layer), proj_crs)
-refactored <- st_drop_geometry(read_sf(out_refac_gpkg, refactored_layer)) %>%
- select(COMID, Hydroseq) %>%
- mutate(COMID = as.integer(COMID))
-
-divides <- st_transform(read_sf(out_refac_gpkg, divide_layer), proj_crs)
-
-lookup <- read_sf(out_refac_gpkg, lookup_table_refactor) %>%
- inner_join(select(st_drop_geometry(nhd), COMID, TotDASqKM), by = c("NHDPlusV2_COMID" = "COMID"))
-
-highest_DA <- lookup %>%
- inner_join(refactored, by = c("NHDPlusV2_COMID" = "COMID")) %>%
- group_by(reconciled_ID) %>%
- filter(Hydroseq == min(Hydroseq))
-```
-
-```{r agg_catchments I}
-if(needs_layer(out_agg_gpkg, agg_cats_layer)){
-
- # https://github.com/r-spatial/sf/issues/1094#issuecomment-988933580 for why this is here.
- sf::st_geometry(divides[sf::st_is_empty(divides),]) <-
- sf::st_cast(sf::st_geometry(divides[sf::st_is_empty(divides),]), "MULTIPOLYGON")
-
- # POI outlets
- outlets <- select(st_drop_geometry(outlets_POI), ID = reconciled_ID, type)
-
- # Identify reconciled flowpaths that are terminal and above DA threshold
- reconciled_DA <- filter(reconciled, TotDASqKM > aggregate_da_thresh_sqkm, is.na(toID))
-
- # Ones not in existing pois
- missing_outlets <- filter(reconciled_DA, !ID %in% outlets$ID) %>%
- pull(ID)
-
- # bind missing outlets, re-assign mis-attributed terminals
- if(length(missing_outlets) > 0){
- outlets <- bind_rows(outlets,
- data.frame(ID = missing_outlets,
- type = rep("terminal", length(missing_outlets))))
- write_sf(filter(reconciled, ID %in% missing_outlets), out_agg_gpkg, "missing_outlets")
-
- }
-
- # Identify reconciled flowpaths that are terminal and below DA threshold
- reconciled_DA <- filter(reconciled, TotDASqKM <= aggregate_da_thresh_sqkm, is.na(toID))
-
- # Ones not in existing pois
- extra_outlets <- filter(reconciled_DA, !ID %in% outlets$ID) %>%
- pull(ID)
-
- extra_nets <- hydroloom::sort_network(select(sf::st_drop_geometry(reconciled),
- ID, toID), outlets = extra_outlets)
-
- # remove extra network from contention
- reconciled <- filter(reconciled, !ID %in% extra_nets$ID)
-
- outlets <- outlets %>%
- left_join(select(st_drop_geometry(reconciled), ID, toID), by = "ID") %>%
- mutate(type = ifelse(is.na(toID), "terminal", "outlet")) %>%
- mutate(type = ifelse(type == "terminal" & !is.na(toID), "outlet", type)) %>%
- select(-toID)
-
- outlets <- filter(outlets, ID %in% reconciled$ID) %>%
- distinct()
-
- agg_cats <- aggregate_catchments(flowpath = reconciled,
- divide = divides,
- outlets = outlets,
- da_thresh = aggregate_da_thresh_sqkm,
- only_larger = TRUE,
- post_mortem_file = cache_split)
-
- agg_cats$cat_sets$set <- sapply(agg_cats$cat_sets$set, paste, collapse = ",")
- agg_cats$fline_sets$set <- sapply(agg_cats$fline_sets$set, paste, collapse = ",")
-
- write_sf(agg_cats$cat_sets, out_agg_gpkg, agg_cats_layer)
- write_sf(agg_cats$fline_sets, out_agg_gpkg, agg_fline_layer)
-
- # Get physical geometry of reconciled FL end node whose ID is an aggregated outlet
- rec_outlets <- filter(st_drop_geometry(reconciled), ID %in% agg_cats$fline_sets$ID) %>%
- cbind(get_node(filter(reconciled, ID %in% agg_cats$fline_sets$ID))) %>%
- st_as_sf()
-
- # Build final POI set
- POIs_att <- select(rec_outlets, ID, toID) %>%
- # Bring over POI information
- inner_join(st_drop_geometry(outlets_POI), by = c("ID" = "reconciled_ID")) %>%
- select(-c(type, member_COMID))
-
- POIs_missing <- filter(select(rec_outlets, -toID), !ID %in% POIs_att$ID) %>%
- inner_join(st_drop_geometry(agg_cats$fline_sets), by = "ID") %>%
- arrange(ID) %>%
- mutate(poi_id = max(POIs_att$poi_id) + row_number()) %>%
- select(ID, toID, poi_id, event_id = event_identifier, Type_Term = orig_levelpathID) %>%
- inner_join(select(highest_DA, NHDPlusV2_COMID, reconciled_ID), by = c("ID" = "reconciled_ID")) %>%
- select(ID, toID, hy_id = NHDPlusV2_COMID, poi_id, event_id, Type_Term) %>%
- mutate(Type_Term = ifelse(is.na(toID), Type_Term, NA),
- Type_Con = ifelse(!is.na(toID), 1, NA)) %>%
- st_as_sf()
-
-
- if(nrow(POIs_missing) > 0){
- final_POIs <- data.table::rbindlist(list(POIs_att, select(POIs_missing,
- -c(Type_Term, Type_Con))), fill = TRUE) %>%
- st_as_sf()
- } else {
- final_POIs <- POIs_att
- }
-
-
- unaggregated_outlets <- filter(outlets_POI, !reconciled_ID %in% final_POIs$ID)
- double_outlets <- final_POIs %>% group_by(ID) %>% filter(n() > 1)
-
- # Write out
- write_sf(final_POIs, out_agg_gpkg, mapped_outlets_layer)
- write_sf(unaggregated_outlets, out_agg_gpkg, "unmapped_outlets")
- write_sf(double_outlets, out_agg_gpkg, "double_outlets")
-} else {
- agg_cats <- list(cat_sets = read_sf(out_agg_gpkg, agg_cats_layer),
- fline_sets = read_sf(out_agg_gpkg, agg_fline_layer))
-
- final_POIs <- read_sf(out_agg_gpkg, mapped_outlets_layer)
-}
-
-```
-
-```{r Long form POIs}
-POIs <- final_POIs %>%
- arrange(ID)
-
-final_POI_geom <- POIs %>%
- select(ID) %>%
- cbind(st_coordinates(.)) %>%
- group_by(ID, X, Y) %>%
- mutate(geom_id = cur_group_id()) %>%
- ungroup()
-
-final_POIs_table <- POIs %>%
- inner_join(select(st_drop_geometry(final_POI_geom), -X, -Y), by = "ID") %>%
- distinct()
-
-write_sf(final_POIs_table, out_agg_gpkg, poi_data_table)
-```
-
-
-```{r lookup table}
-refactor_lookup <- dplyr::select(st_drop_geometry(reconciled), ID, member_COMID) %>%
- dplyr::mutate(member_COMID = strsplit(member_COMID, ",")) %>%
- tidyr::unnest(cols = member_COMID) %>%
- dplyr::mutate(NHDPlusV2_COMID = as.integer(member_COMID)) %>% # note as.integer truncates
- dplyr::rename(reconciled_ID = ID)
-
-aggregate_lookup_fline <- dplyr::select(st_drop_geometry(agg_cats$fline_sets), ID, set) %>%
- dplyr::mutate(set = strsplit(set, ",")) %>%
- tidyr::unnest(cols = set) %>%
- dplyr::rename(aggregated_flowpath_ID = ID, reconciled_ID = set)
-
-aggregate_lookup_catchment <- dplyr::select(st_drop_geometry(agg_cats$cat_sets), ID, set) %>%
- dplyr::mutate(set = strsplit(set, ",")) %>%
- tidyr::unnest(cols = set) %>%
- dplyr::rename(aggregated_divide_ID = ID, reconciled_ID = set)
-
-if(is.character(aggregate_lookup_catchment$reconciled_ID)) aggregate_lookup_catchment$reconciled_ID <- as.integer(aggregate_lookup_catchment$reconciled_ID)
-if(is.character(aggregate_lookup_fline$reconciled_ID)) aggregate_lookup_fline$reconciled_ID <- as.integer(aggregate_lookup_fline$reconciled_ID)
-
-lookup_table <- tibble::tibble(NHDPlusV2_COMID = unique(as.integer(refactor_lookup$member_COMID))) %>%
- dplyr::left_join(refactor_lookup, by = "NHDPlusV2_COMID") %>%
- dplyr::left_join(aggregate_lookup_fline, by = "reconciled_ID") %>%
- dplyr::left_join(aggregate_lookup_catchment, by = "reconciled_ID")
-
-readr::write_csv(lookup_table, lookup_table_file)
-write_sf(lookup_table, out_agg_gpkg, lookup_table_refactor)
-
-sf::st_layers(out_agg_gpkg)
-
-mapview::mapview(list(agg_cats$cat_sets, agg_cats$fline_sets, final_POIs))
-```
diff --git a/workspace/04_merge.Rmd b/workspace/04_merge.Rmd
deleted file mode 100644
index 1ca27838dd81d5c3788b4b52f923895692bb3d40..0000000000000000000000000000000000000000
--- a/workspace/04_merge.Rmd
+++ /dev/null
@@ -1,15 +0,0 @@
-This notebook is used for creation of national scale output.
-
-The outputs are not used later in the workflow.
-
-```{r}
-library(sf)
-library(hyfabric)
-
-source("R/utils.R")
-source("R/config.R")
-
-in_gpkg <- "reference_"
-
-Merge_VPU(final_poi_layer, in_gpkg, gf_gpkg_conus)
-```
diff --git a/workspace/05-1_merge.Rmd b/workspace/05-1_merge.Rmd
deleted file mode 100644
index 5a8202306c61905921e72b1ad8c762a7120ee402..0000000000000000000000000000000000000000
--- a/workspace/05-1_merge.Rmd
+++ /dev/null
@@ -1,94 +0,0 @@
----
-title: "07-1_merge.Rmd"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-title: 07-1_merge.Rmd
-Project: GFv2.0
-Date: 4/2022
-Author: [David Blodgett](dblodgett@usgs.gov)
-Script purpose: Merge refactored outputs into VPU basis.
-
-
-```{r rmd, echo=F, message=F, warning=FALSE, fig.width=4}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=10,
- fig.height=8)
-```
-
-```{r setup}
-# Load custom functions
-source("R/utils.R")
-source("R/config.R")
-
-```
-
-For a given VPU bind RPUs into a single geopackage for an entire VPU. This step is intended to be run after Refactor flowlines/cats. For a given VPU, this binds the results of aggregated from the associated RPUs into a single layer and writes them out to a single geopackage for the non-dendritic work.
-
-```{r refactor}
-if(needs_layer(rfc_gpkg, divide_layer)) {
-
- # Thematic POIs
- POIs <- read_sf(nav_gpkg, poi_data_table) %>%
- select(-geom_id)
-
- sf::write_sf(POIs, gf_gpkg, poi_data_table)
-
- merged_layers <- merge_refactor(rpu_codes$rpuid,
- rpu_vpu_out,
- lookup_table_refactor,
- reconciled_layer,
- divide_layer,
- split_divide_layer,
- agg_fline_layer,
- agg_cats_layer,
- mapped_outlets_layer)
-
- sf::write_sf(select(merged_layers[[lookup_table_refactor]],
- -aggregated_flowpath_ID,
- -aggregated_divide_ID),
- rfc_gpkg, lookup_table_refactor)
-
- sf::write_sf(merged_layers[[reconciled_layer]],
- rfc_gpkg, reconciled_layer)
-
- sf::write_sf(merged_layers[[divide_layer]],
- rfc_gpkg, divide_layer)
-
- sf::write_sf(merged_layers[[split_divide_layer]],
- rfc_gpkg, split_divide_layer)
-
- sf::write_sf(merged_layers[[mapped_outlets_layer]], gf_gpkg, mapped_outlets_layer)
-
- merged_layers[[agg_cats_layer]] <- merged_layers[[agg_cats_layer]] %>%
- mutate(areasqkm = as.numeric(units::set_units(sf::st_area(.), "km^2")))
-
- sf::write_sf(merged_layers[[agg_cats_layer]], gf_gpkg, agg_cats_layer)
-
- merged_layers[[agg_fline_layer]] <- merged_layers[[agg_fline_layer]] %>%
- mutate(lengthkm = as.numeric(units::set_units(sf::st_length(.), "km"))) %>%
- left_join(select(sf::st_drop_geometry(merged_layers[[agg_cats_layer]]), ID, areasqkm), by = "ID")
-
- sf::write_sf(merged_layers[[agg_fline_layer]], gf_gpkg, agg_fline_layer)
-
- sf::write_sf(merged_layers[[lookup_table_refactor]],
- gf_gpkg, lookup_table_refactor)
-
- st_drop_geometry(merged_layers[[reconciled_layer]]) %>%
- select(id = ID, toID = toID, lengthkm = LENGTHKM, levelpathid = LevelPathID) %>%
- left_join(select(st_drop_geometry(merged_layers[[divide_layer]]),
- id = ID, areasqkm), by = "id") %>%
- relocate(id, toID, lengthkm, areasqkm, levelpathid) %>%
- write_sf(rfc_gpkg, catchment_network_table)
-
- st_drop_geometry(merged_layers[[agg_fline_layer]]) %>%
- select(id = ID, toid = toID, lengthkm, areasqkm) %>%
- left_join(distinct(select(merged_layers[[lookup_table_refactor]],
- id = aggregated_flowpath_ID,
- levelpathid = LevelPathID))) %>%
- sf::write_sf(gf_gpkg, catchment_network_table)
-}
-```
diff --git a/workspace/05-2_NonDend.Rmd b/workspace/05-2_NonDend.Rmd
deleted file mode 100644
index e70088705e9dc629d40968ab231ec677ea33ad74..0000000000000000000000000000000000000000
--- a/workspace/05-2_NonDend.Rmd
+++ /dev/null
@@ -1,412 +0,0 @@
----
-title: "07-2_NonDend.Rmd"
-output: html_document
-editor_options:
- chunk_output_type: console
----
-title: NonDend.Rmd
-Project: GFv2.0
-Date: 7/2020
-Author: [Marilyn Santiago, Andrew Bock](msant@usgs.gov, abock@usgs.govb)
-Script purpose:: To provide workflow for aggregating non-dendritic catchments
-Coastal zero-order and frontal catchments are accounted for first, followed by
-endorheic basins and sinks.
-
-
-```{r rmd, echo=F, message=F, warning=FALSE, fig.width=4}
-knitr::opts_chunk$set(
- collapse = TRUE,
- comment = "#>",
- fig.width=10,
- fig.height=8)
-```
-
-```{r setup}
-# set to true to output extra layers.
-debug <- FALSE
-
-# Load custom functions
-source("R/utils.R")
-source("R/config.R")
-source("R/user_vars.R")
-source("R/non_dend.R")
-source("R/user_vars.R")
-
-# Read in full VPU NHD set
-if (vpu_codes == "20"){
- full_nhd <- readRDS(file.path(data_paths$islands_dir,
- "NHDPlusNationalData/nhdplus_flowline.rds")) %>%
- st_transform(crs)
-} else {
- full_nhd <- readRDS(data_paths$VAA_rds)
-}
-
-# Elevation Data
-elev <- data_paths$elev_cm[grepl(paste0("Ned", substr(vpu_codes, 1, 2)),
- data_paths$elev_cm, ignore.case = TRUE)]
-
-if (vpu_codes == "08"){
- elev$rpu_03g <- data_paths$elev_cm$rpu_03g
-}
-
-# HUC extraction for specific NHD+ vpus
-if(vpu_codes == "02"){
- grep_exp <-"^02|^04"
-} else if (vpu_codes == "08") {
- grep_exp <- "^03|^08"
-} else {
- grep_exp <- paste0("^", substr(vpu_codes, start = 1, stop = 2))
- elev <- append(elev, list(rpu_03g = data_paths$elev_cm$rpu_03g))
-}
-
-cat_rpu_table <- readRDS(data_paths$fullcats_table)
-
-# get full flowline set including coastlines
-vpu_nhd <- full_nhd %>%
- filter(grepl(paste0("^", grep_exp, ".*"), .data$VPUID)) %>%
- align_nhdplus_names(.)
-
-vpu_WBD <- readRDS(file.path(data_paths$nhdplus_dir, "HUC12.rds")) %>%
- filter(grepl(paste0("^", grep_exp, ".*"), .data$HUC_12))
-
-nhd <- st_transform(read_sf(nav_gpkg, nhd_flowline), proj_crs)
-cats <- st_transform(read_sf(nav_gpkg, nhd_catchment), proj_crs)
-divides <- st_transform(read_sf(rfc_gpkg, divide_layer), proj_crs)
-lookup <- read_sf(gf_gpkg, lookup_table_refactor)
-
-```
-
-This next section intersects HUC12 for a given VPU with NHD+ catchments and catchment divides.
-
-See __get_HUC12_Xwalk__ in __R/utils.R__
-```{r Load HUC12 / xWalk information}
-if(needs_layer(ND_gpkg, xwalk_layer)){
-
- # Read in full NHD cats
- cats <- filter(cats, full_cats == 1)
- cats <- sf::st_make_valid(cats)
- divides <- sf::st_make_valid(divides)
-
- # Intersect NHD catchments and divides with HUC12
- nhd_wbd_int <- get_HUC12_Xwalk(vpu_codes, cats, divides,
- file.path(data_paths$nhdplus_dir,
- "CrosswalkTable_NHDplus_HU12.csv"),
- file.path(data_paths$nhdplus_dir, "HUC12.rds"))
-
- # Bring over divides/HUC12 intersection information into divides layer
- xwalk_divides_wbd <- st_drop_geometry(nhd_wbd_int$divides_HUC12) %>%
- select(-c(ACRES, HU_12_MOD))
-
- divides <- divides %>%
- left_join(distinct(xwalk_divides_wbd) %>%
- group_by(ID) %>%
- filter(intArea == max(intArea)) %>%
- ungroup() %>%
- select(ID, HUC_12_int, intArea, AreaHUC12),
- by = "ID")
-
- # Bring over divides/HUC12 intersection information into divides layer
- xwalk_nhd_wbd <- st_drop_geometry(nhd_wbd_int$cats_HUC12) %>%
- select(-c(ACRES, HU_12_MOD))
-
- rm(nhd_wbd_int)
-
- cats <- cats %>%
- left_join(distinct(xwalk_nhd_wbd) %>%
- group_by(FEATUREID) %>%
- slice(which.max(intArea)) %>%
- ungroup() %>%
- select(FEATUREID, HUC_12_int, intArea, AreaHUC12),
- by = "FEATUREID") %>%
- st_transform(proj_crs)
-
- # All intersecting NHD cat / divides / HUC12 geometries (1: many)
- write_sf(xwalk_nhd_wbd, ND_gpkg, xwalk_layer)
- write_sf(xwalk_divides_wbd, ND_gpkg, divides_xwalk)
-
- # Cats with the HUC_12 value (HUC_12_int) that is the max overlap
- write_sf(cats, ND_gpkg, nhd_catchment)
- write_sf(divides, ND_gpkg, divide_layer)
-} else {
- xwalk_nhd_wbd <- read_sf(ND_gpkg, xwalk_layer)
- xwalk_divides_wbd <- read_sf(ND_gpkg, divides_xwalk)
- cats <- read_sf(ND_gpkg, nhd_catchment)
- divides <- read_sf(ND_gpkg, divide_layer)
-}
-```
-
-This next step takes catchment divides and:
-
-1. Adds a field that indicates how a divide without an aggregated catchment ID assigned in hyRefactor::aggregate_catchments was aggregated (*__aggStep__*)
-2. Identifies internal sinks and non-dendritic areas entirely surrounded by a single aggregated catchment, and assigns those the catchment ID (see __dissolve_holes__ in __non_dend.R__ function)
-
-```{r First-cut}
-if(needs_layer(ND_gpkg, divides_nd)){
-
- # Bind divide with lookup, identify aggregation step
- divides_lu <- divides %>%
- left_join(distinct(select(lookup, reconciled_ID, aggregated_divide_ID)),
- by = c("ID" = "reconciled_ID")) %>%
- filter(!is.na(ID) & !is.na(aggregated_divide_ID)) %>%
- rename(POI_ID = aggregated_divide_ID) %>%
- # attribute that hyrefactor was the step used to aggregate these catchments
- mutate(aggStep = "hyRef")
-
- # Identify cats witin the full catchment set not refactored or aggregated, add
- # to divides data frame
- cats_miss <- cats %>%
- left_join(select(lookup, NHDPlusV2_COMID, member_COMID, reconciled_ID ,
- POI_ID = aggregated_divide_ID),
- by = c("FEATUREID" = "NHDPlusV2_COMID")) %>%
- filter(is.na(POI_ID), !member_COMID %in% divides_lu$member_COMID) %>%
- mutate(aggStep = NA) %>%
- distinct() %>%
- left_join(select(cat_rpu_table, FEATUREID, rpu = RPUID)) %>%
- #filter(!reconciled_ID %in% divides_lu$ID) %>%
- select(-member_COMID) %>%
- mutate(areasqkm = as.numeric(st_area(.)/1000000)) %>%
- select(ID = reconciled_ID, member_COMID = FEATUREID, rpu, HUC_12_int, intArea, AreaHUC12, POI_ID, aggStep)
-
- divides_lu <- divides_lu %>%
- select(-areasqkm) %>%
- rbind(cats_miss) %>%
- # resolve terminal non-POI outlets where we can
- nhdplusTools:::check_valid() %>%
- st_cast("POLYGON")
-
- # clean_geometry(divides_lu, ID = "POI_ID", keep = 1.0, crs = st_crs(divides_lu))
- divides_lu <- dissolve_holes(divides_lu)
- rm(cats_miss)
-
- # DEBUG:
- # HRU layer
- if(debug) {
- protoHRUs <- divides_lu %>%
- group_by("POI_ID") %>%
- summarize(do_union = TRUE) %>%
- sfheaders::sf_remove_holes(.) %>%
- st_make_valid()
- write_sf(protoHRUs, ND_gpkg, HRU_layer)
- rm(protoHRUs)
- }
-
- write_sf(divides_lu, ND_gpkg, divides_nd)
-} else {
- divides_lu <- read_sf(ND_gpkg, divides_nd)
-}
-```
-
-This next section takes divides not assigned an aggregated ID (*__POI_ID__*) and determines if they can be grouped on the basis of their HUC12/HUC10 ID. See __assign_HUC10/12__ in __non_dend.R__. This assigns a temporary aggregated ID that reflects the HUC10/12 the divides overlap with.
-
-```{r HUC12 cats}
-# Check for HUC12 aggregation assignments
-if(!"HUC_12" %in% unique(divides_lu$aggStep)){
- print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
-
- # This will crate aggregated IDs for NHD catchments that match HUC12 footprint if aggregated together
- # The Coefficient of Areal correpsondence - is the last argument
- if("AREASQKM" %in% names(xwalk_nhd_wbd)) {
- xwalk_nhd_wbd <- rename(xwalk_nhd_wbd,
- AreaSqKM = AREASQKM)
- }
-
- divides_lu <- assign_HUC12(divides_lu, xwalk_nhd_wbd,
- filter(vpu_nhd, FTYPE != "Coastline"), CAC_thresh)
-
- # Determine if any unaggregated catchments match HUC10 footprint (mostly in the west)
- divides_lu <- assign_HUC10(divides_lu, xwalk_nhd_wbd,
- filter(vpu_nhd, FTYPE != "Coastline"), CAC_thresh) %>%
- select(-comid_char)
-
- if(debug) {
- # DEBUG:
- # HRU layer
- protoHRUs <- divides_lu %>%
- group_by(POI_ID) %>%
- summarize(do_union = TRUE) %>%
- sfheaders::sf_remove_holes(.) %>%
- st_make_valid()
- write_sf(protoHRUs, ND_gpkg, HRU_layer)
- rm(protoHRUs)
- }
-
- # Update missing_cats
- write_sf(divides_lu, ND_gpkg, divides_nd)
-} else {
- divides_lu <- read_sf(ND_gpkg, divides_nd)
-}
-```
-
-Deal with unaggregated catchment divides that are coastal if they exist within VPU
-
-Note these are primarily assigned the HUC12 as the temporary aggregated ID, but they differ from above in that they don't meet the Areal Correspondence threshold.
-
-Note that in this case it can involve ugly multi-part HRUs which we may want to split to single part.
-
-```{r Coastal Cats}
-# aggregate frontal hucs of same type
-if("Coastline" %in% unique(vpu_nhd$FTYPE)){
- print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
-
- # Only run through if coastal catchments are present
- if(!"coastal" %in% unique(divides_lu$aggStep)){
-
- # Function to create coastal catchments by HUC12 and catch inflows.
- divides_lu <- coastal_cats(divides_lu, vpu_nhd, vpu_WBD)
-
- if(debug) {
- # DEBUG:
- # HRU layer
- protoHRUs <- divides_lu %>%
- group_by(POI_ID) %>%
- summarize(do_union = TRUE) %>%
- sfheaders::sf_remove_holes(.) %>%
- st_make_valid()
- # Write out updates
- write_sf(protoHRUs, ND_gpkg, HRU_layer)
- rm(protoHRUs)
- }
-
-
- # Update missing_cats
- write_sf(divides_lu, ND_gpkg, divides_nd)
- } else {
- divides_lu <- read_sf(ND_gpkg, divides_nd)
- }
-} else {
- print ("No Coastlines in VPU")
-}
-vpu_nhd <- filter(vpu_nhd, FTYPE != "Coastline")
-```
-
-
-This is where alot of the more complex steps happen. For most VPUs, there are not of catchments left to aggregate after this step.
-
-1, Determine where network terminals below the drainage area threshold used to derive the hyRefactor outlets contribute to (__assignable_cats__ in __non_dend.R__)
-2. Assign other cats by the basis of HUC12 and HUC12 of bordering catchments (__assignable_cats__)
-3. Uses the FAC grid to assign the rest ( __assign_holes__ )
-```{r FixingtheHoles}
-if(needs_layer(ND_gpkg, missing_cats)){
- print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
-
- if(sum(is.na(divides_lu$POI_ID)) > 0){
-
- # Handle nhd sinks
- # arrange divides_lu by member_COMID and populate with RowID for easy iteration within next two steps
- divides_lu <- divides_lu %>%
- arrange(member_COMID, POI_ID) %>%
- mutate(row_ID = row_number()) %>%
- arrange(row_ID)
-
- HUC_sinks <- NHD_sinks(divides_lu, area_thresh = min_da_km_terminal/2,
- HUC12_table =file.path(data_paths$nhdplus_dir, "HUC12.rds"),
- NHD_sinks = read_sf(data_paths$nhdplus_gdb, "Sink"))
-
- if(length(HUC_sinks) == 2){
- divides_lu <- HUC_sinks$divides_poi
- sinks_table <- HUC_sinks$sink_cats_table
- }
-
- # Scan for terminals that may have been refactored
- missing_ds <- filter(divides_lu, is.na(POI_ID))
- term_refactored <- lapply(missing_ds$member_COMID, function(x){
- ds_ref <- get_DM(vpu_nhd,x, include = F)
- if(length(ds_ref) == 0){
- return(filter(missing_ds, member_COMID == x))
- }
-
- lookup_test <- filter(lookup, NHDPlusV2_COMID %in% ds_ref)
- divides_test <- filter(divides_lu, ID %in% lookup_test$reconciled_ID) %>%
- filter(!is.na(POI_ID))
-
- print(unique(divides_test$POI_ID))
-
- if(length(unique(divides_test$POI_ID)) == 1){
- return(filter(missing_ds, member_COMID == x) %>%
- mutate(POI_ID = unique(divides_test$POI_ID)))
- } else {
- return(filter(missing_ds, member_COMID == x))
- }
-
- })
-
- term_refactored <- data.table::rbindlist(term_refactored[lengths(term_refactored) > 1],
- fill = TRUE) %>%
- st_as_sf()
-
- divides_lu <- filter(divides_lu, !member_COMID %in% term_refactored$member_COMID) %>%
- rbind(term_refactored)
-
- if(sum(is.na(divides_lu$POI_ID)) > 0) {
- divides_dem <- miss_term_assign(divides_lu, vpu_nhd, elev)
-
- divides_lu <- divides_lu %>%
- left_join(select(divides_dem, member_COMID, agg_ID),
- by = "member_COMID") %>%
- mutate(POI_ID = ifelse(!is.na(agg_ID), agg_ID, POI_ID),
- aggStep = ifelse(!is.na(agg_ID), "boundary DEM", aggStep)) %>%
- select(-agg_ID)
-
- if(exists("sinks_table")){
- sinks_table_fin <- filter(sinks_table, !member_COMID %in% divides_dem$member_COMID)
- sinks_table_fin <- data.table::rbindlist(list(sinks_table_fin,
- divides_dem), fill = TRUE)
- } else {
- sinks_table_fin <- divides_dem
- }
-
- write_sf(sinks_table_fin, ND_gpkg, ND_table)
- }
-
- } else {
- print ("all unaggregated catchments assigned")
- }
-
- divides_lu <- dissolve_holes(divides_lu)
- if(sum(is.na(divides_lu$POI_ID)) > 0){
- write_sf(filter(divides_lu, is.na(POI_ID)), ND_gpkg, missing_cats)
- }
-
- # Prob HRU - filter(all_hrus, POI_ID == 140402000209)
- all_hrus <- filter(divides_lu, !is.na(POI_ID)) %>%
- group_by(POI_ID) %>%
- summarize(do_union = TRUE) %>%
- sfheaders::sf_remove_holes(.) %>%
- nhdplusTools:::check_valid(.)
-
- write_sf(divides_lu, ND_gpkg, divides_nd)
- write_sf(all_hrus, ND_gpkg, HRU_layer)
-} else {
- divides_lu <- read_sf(ND_gpkg, divides_nd)
- all_hrus <- read_sf(ND_gpkg, HRU_layer)
-}
-```
-
-```{r Manual checks}
-noagg_divides <- read_sf(ND_gpkg, missing_cats) %>%
- select(row_ID, POI_ID_noagg = POI_ID) %>%
- st_drop_geometry()
-
-if(all(!is.na(noagg_divides$POI_ID_noagg))){
- print ("all unaggregated divides accounted for")
-
- divides_lu <- divides_lu %>%
- left_join(noagg_divides, by = "row_ID") %>%
- mutate(POI_ID = ifelse(!is.na(POI_ID_noagg), POI_ID_noagg, POI_ID),
- aggStep = ifelse(!is.na(aggStep), "manual", aggStep)) %>%
- select(-POI_ID_noagg)
-
- # Prob HRU - filter(all_hrus, POI_ID == 140402000209)
- all_hrus <- filter(divides_lu, !is.na(POI_ID)) %>%
- group_by(POI_ID) %>%
- summarize(do_union = TRUE) %>%
- sfheaders::sf_remove_holes(.) %>%
- nhdplusTools:::check_valid(.)
-
- write_sf(divides_lu, ND_gpkg, divides_nd)
- write_sf(all_hrus, ND_gpkg, HRU_layer)
-} else {
- print ("account for unaggregated divides")
-}
-
-```
diff --git a/workspace/R/00_get_data_functions.R b/workspace/R/00_get_data_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..81c4318fa0b0be1fba6ac01c721aeb9b7fdb1352
--- /dev/null
+++ b/workspace/R/00_get_data_functions.R
@@ -0,0 +1,118 @@
+#' get_sb_file
+#' @param item sciencebase item id
+#' @param item_files character vector of file names. "all" will download all files.
+#' @param out_destination character path to save files into
+#' @param unzip logical if TRUE, files ending with .7z will be un7zipped
+#' @param check_path character path to check, if it exists, it will be returned invisibly
+#' @return path that data was saved to
+get_sb_file <- function(item, item_files, out_destination, unzip = TRUE, check_path = NULL) {
+
+ if(!is.null(check_path) && file.exists(check_path)) return(invisible(check_path))
+
+ check_auth()
+
+ if(length(item_files) == 1 && item_files == "all") {
+ item_files <- sbtools::item_list_files(item)$fname
+ }
+
+ if(!dir.exists(out_destination)) dir.create(out_destination, showWarnings = FALSE, recursive = TRUE)
+
+ out_files <- file.path(out_destination, item_files)
+
+ missing <- out_files[!file.exists(out_files)]
+
+ if(length(missing) > 0) {
+ sbtools::item_file_download(item,
+ names = basename(missing),
+ destinations = missing)
+ }
+
+ if(unzip) {
+
+ un7zip_fs <- missing[grepl("7z$|zip$", missing)]
+
+ for(f in un7zip_fs) {
+ system(paste0(sevenz, " e -o", out_destination, " ", f))
+ }
+
+ }
+
+ if(!is.null(check_path) && file.exists(check_path)) return(invisible(check_path))
+
+ if(!is.null(check_path))
+ stop("did not create ", check_path)
+
+ invisible(out_destination)
+
+}
+
+#' download a file
+#' @param url character url where the file can be retrieved
+#' @param out_path character path the directory to save the downloaded file
+#' @param check_path character path to check that should exist when done
+#' @param file_name character name to use instead of basename of url
+#' @param unzip logical whether to try to unzip the file
+download_file <- function(url, out_path, check_path = NULL, unzip = TRUE, file_name = NULL) {
+
+ if(!is.null(check_path) && file.exists(check_path)) return(invisible(check_path))
+
+ dir.create(out_path, showWarnings = FALSE, recursive = TRUE)
+
+ if(is.null(file_name)) file_name <- basename(url)
+
+ out <- file.path(out_path, file_name)
+
+ if(!file.exists(out)) {
+ httr::RETRY("GET", url, httr::write_disk(out))
+
+ if(unzip & grepl("7z$|zip$", out))
+ system(paste0(sevenz, " x ", out, " -o", out_path))
+
+ }
+
+ if(!is.null(check_path) && file.exists(check_path)) return(invisible(check_path))
+
+ if(!is.null(check_path))
+ stop("did not create ", check_path)
+}
+
+#' make flow direction and flow accumulation file list
+#' @param fdr_fac_dir directory where flow direction and flow accumulation are
+#' @return list containing all flow direction and flow accumulation files
+make_fdr_fac_list <- function(fdr_fac_dir) {
+ if(!dir.exists(fdr_fac_dir))
+ download_elev("FDRFAC", fdr_fac_dir)
+
+ dirs <- unique(dirname(list.files(fdr_fac_dir, recursive = TRUE, full.names = TRUE)))
+
+ fdr <- dirs[grepl(".*/fdr$", dirs)]
+ fac <- dirs[grepl(".*/fac$", dirs)]
+
+ out <- list(fdr = list(), fac = list())
+
+ rpu <- substr(fdr, (nchar(fdr) - 6), (nchar(fdr) - 4))
+
+ out$fdr <- as.list(setNames(fdr, paste0("rpu_", rpu)))
+ out$fac <- as.list(setNames(fac, paste0("rpu_", rpu)))
+
+ out
+}
+
+make_nhdplus_elev_list <- function(elev_dir) {
+
+ if(!dir.exists(elev_dir))
+ download_elev("DEM", elev_dir)
+
+ dirs <- unique(dirname(list.files(elev_dir, recursive = TRUE, full.names = TRUE)))
+
+ elev_cm <- dirs[grepl(".*/elev_cm$", dirs)]
+
+ out <- list(elev_cm = list())
+
+ rpu <- substr(elev_cm, (nchar(elev_cm) - 10), (nchar(elev_cm) - 8))
+
+ out$elev_cm <- as.list(setNames(elev_cm, paste0("rpu_", rpu)))
+
+ out
+
+}
diff --git a/workspace/R/01_prep_functions.R b/workspace/R/01_prep_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..a5288ec064c7c20980f92840d4086b97f41e2e46
--- /dev/null
+++ b/workspace/R/01_prep_functions.R
@@ -0,0 +1,578 @@
+#' prepare SWIM gages
+#' @description reads SWIM gageinfo dbf as created in gage info pre process and
+#' swim points data to create a set of SWIM gages that will be used later.
+#' @param SWIM_dbf_file character path tp summary file as created in gageinfo step.
+#' @param SWIM_points_file character path to SWIM source data
+#' @param ref_gages sf data.frame gages from USGS nldi dataset / ref gages
+#' @param gages_add character vector of gages to not filter out.
+#' @param POR_start Date to use as period of record start date
+#' @param min_obs minimum number of observations
+#' @return list of three data frames for use later and in mapping output of this
+#' function.
+prepare_SWIM <- function(SWIM_dbf_file, SWIM_points_file, ref_gages,
+ gages_add,
+ POR_start = as.Date("1979-10-01"),
+ min_da_km_gages = 5,
+ min_obs = 90) {
+ # Read gagesIII dbf that is a POR summary produced from 00_gage_info.Rmd
+ gagesIII_db_full <- read.dbf(file = SWIM_dbf_file, as.is = TRUE) %>%
+ rename(total_obs = count_nu, total_poss_obs = TPdays1)
+
+ # Read in shapefile
+ gagesIII_sf_full <- read_sf(SWIM_points_file, "SWIM_gage_loc") %>%
+ st_zm(drop = TRUE) %>%
+ # Use site_no as the authoritative station ID name
+ rename(site_no = Gage_no) %>%
+ # Drop fields in NLDI gages
+ select(-c(COMID, REACHCODE, REACH_meas)) %>%
+ # Join to NLDI reference gages
+ left_join(select(st_drop_geometry(ref_gages), id, comid = nhdpv2_COMID,
+ reachcode = nhdpv2_REACHCODE,
+ reach_meas = nhdpv2_REACH_measure),
+ by = c("site_no" = "id"))
+
+ # Read Gages III shapefile
+ gagesIII_sf <- gagesIII_sf_full %>%
+ # Get rid of invalid COMIDs, for multiple site IDs get one with the furthest reach measure downstream
+ filter(comid > 0, site_no %in% gagesIII_db_full$site_no) %>%
+ # There are some rows with dupslicate site_no, drainage area, and POR infomrmation
+ group_by(site_no) %>%
+ slice(which.min(reach_meas)) %>%
+ # There were some duplicate rows that needed to be removed
+ select(site_no, comid, reachcode, reach_meas) %>%
+ distinct()
+
+ # Start documenting gages that are dropped out; these gages have no mean daily Q
+ document_dropped_gage(filter(select(st_drop_geometry(gagesIII_sf_full), site_no),
+ !site_no %in% gagesIII_sf$site_no),
+ "GAGES-III", "No Q or COMID")
+
+ # First subset
+ gagesIII_db <- gagesIII_db_full %>%
+ # Get rid of inital fields we are not interested in,
+ select(-c(agency_cd, ts_id)) %>%
+ # Constrain by date and/or POR
+ filter(end_date > POR_Start | total_obs > min_obs,
+ # remove site codes associated with canals, ditchest, etc
+ !site_tp_cd %in% c("ST-CA", "ST-DCH", "FA-STS"),
+ # keep sites with daily mean streamflow parameter
+ stat_cd == "00003") %>%
+ distinct()
+
+ # Gages that don't fit the POR requirement, or are non-ST site types
+ document_dropped_gage(filter(select(st_drop_geometry(gagesIII_sf), site_no),
+ !site_no %in% gagesIII_db$site_no),
+ "GAGES-III", "Non-ST; POR")
+
+ # scan for potential canals/ditches among the remaining ST site types
+ potCanalsIII <- gagesIII_db %>%
+ # Flag station_nm with the follwing words
+ filter(grepl(paste(c("DITCH", "ditch", "CANAL", "canal", "CN", "DIV", "div"),
+ collapse = "|"), station_nm)) %>%
+ # Remove the station_nm with the following
+ filter(!grepl(paste(c("RIVER AT", "RIVER BELOW", "RIVER BL", "R AB", "R BL", "R ABV"),
+ collapse = "|"),
+ station_nm, ignore.case = TRUE)) %>%
+ # These have been manually checked and are located in gage_mod.R
+ filter(!site_no %in% gages_add)
+
+ # Write out for manual checking
+ if(!file.exists("temp/GagestoCheck_GAGESIII.csv")){
+ write.csv(potCanalsIII, "temp/GagestoCheck_GAGESIII.csv")
+ }
+
+ # Subset further by streamgages below the minimum drainage area critera
+ gagesIII_db_fin <- gagesIII_db %>%
+ filter(!site_no %in% potCanalsIII$site_no, drain_area > (min_da_km_gages * sqkm_sqmi))
+
+ # Write out gages that dropped to document.
+ document_dropped_gage(select(potCanalsIII, site_no), "GAGES-III", "ST; Pot. Canal")
+ document_dropped_gage(gagesIII_db %>%
+ filter(!site_no %in% potCanalsIII$site_no,
+ drain_area < min_da_km_gages) %>%
+ select(site_no),
+ "GAGES-III", "below DA")
+
+ # Join shapefile to POR table
+ gagesIII_final <- gagesIII_sf %>%
+ inner_join(gagesIII_db_fin, by = "site_no") %>%
+ select(-c(coord_acy_, huc_cd, parm_cd, stat_cd, missing_da, site_tp_cd)) %>%
+ mutate(source = "gagesIII") %>%
+ # deal with one duplicate row
+ group_by(site_no) %>%
+ filter(total_obs == max(total_obs)) %>%
+ ungroup() %>%
+ st_transform()
+
+ return(list(final = gagesIII_final, full = gagesIII_sf_full,
+ filtered = gagesIII_sf, db = gagesIII_db_full, potCanals = potCanalsIII))
+}
+
+#' prepare gage locations from NHDPlusV2
+#' @param NHDPlusV2_gageloc_file gageloc info as prepared in 00_gage_info
+#' @param NHDPlusV2_gdb character path to national NHDPlus geo database
+#' @param SWIM SWIM gage list of data.frames
+#' @param ref_gages USGS stream gages from reference gages / NLDI
+#' @param min_da_km_gages minimum drainage area for gages to consider
+#' @return list of data.frames for later use
+prepare_gage_location <- function(NHDPlusV2_gageloc_file, NHDPlusV2_gdb,
+ SWIM, ref_gages,
+ min_da_km_gages = 5) {
+ # Read gages3 dbf that is a POR summary produced from 00_gage_info.Rmd
+ gageloc_db_full <- read.dbf(file = NHDPlusV2_gageloc_file, as.is = TRUE) %>%
+ rename(total_obs = count_nu, total_poss_obs = TPdays1)
+
+ # Read in shapefile
+ gageloc_sf_full <- read_sf(NHDPlusV2_gdb, "Gage") %>%
+ # Drop Z geometries
+ st_zm(drop = TRUE) %>%
+ rename(site_no = SOURCE_FEA) %>%
+ select(-c(FLComID, REACHCODE, Measure)) %>%
+ # Disregard locations already removed in GAGESIII
+ filter(!site_no %in% SWIM$full$site_no) %>%
+ # Update index information with NLDI gages
+ left_join(select(st_drop_geometry(ref_gages), site_no = id,
+ comid = nhdpv2_COMID, reachcode = nhdpv2_REACHCODE,
+ reach_meas = nhdpv2_REACH_measure ), by = "site_no")
+
+ # Subset to locations with streamflow
+ gageloc_sf <- gageloc_sf_full %>%
+ # Get rid of invalid COMIDs, for multiple site IDs get one with the furthest reach measure downstream
+ filter(site_no %in% gageloc_db_full$site_no) %>%
+ # Like GAGES-III, multiple site_no
+ group_by(site_no) %>%
+ slice(which.min(reach_meas)) %>%
+ # There were some duplicate rows that needed to be removed
+ select(site_no, comid, reachcode, reach_meas) %>%
+ distinct()
+
+ # Start documenting gages that are dropped out; these gages have no mean daily Q
+ document_dropped_gage(filter(select(st_drop_geometry(gageloc_sf_full), site_no),
+ !site_no %in% gageloc_sf$site_no),
+ "GageLoc", "No Q, COMID")
+
+ # do the same exercise with GageLoc, but with more site type attributes to filter out
+ gageloc_db <- gageloc_db_full %>%
+ filter(end_date > POR_Start | total_obs > min_obs,
+ !site_tp_cd %in%
+ c("ST-CA", "ST-DCH", "FA-STS", "SB_TSM", "FA-DV", "FA-STS", "FA-CS",
+ "FA-WWD", "FA-OF", "GW"), stat_cd == "00003") %>%
+ # Some sites are listed twice with same information but different agencies,
+ select(-c(agency_cd, ts_id)) %>%
+ distinct(site_no, drain_area, dec_lat_va, dec_long_v, .keep_all = T)
+
+ # Gages that don't fit the POR requirement, or are non-ST site types
+ document_dropped_gage(filter(select(gageloc_db_full, site_no),
+ !site_no %in% gageloc_db$site_no),
+ "GageLoc", "Non-ST; POR")
+
+ # scan for potential canals/ditches
+ potCanals_gageloc <- gageloc_db %>%
+ filter(grepl(paste(c("DITCH", "ditch", "CANAL", "canal", "CN", "DIV", "div"),
+ collapse = "|"), station_nm)) %>%
+ filter(!site_no %in% gages_add)
+
+ # Write out for manual checking
+ if(!file.exists("temp/GagestoCheck_GageLoc.csv")){
+ write.csv(potCanals_gageloc, "temp/GagestoCheck_GageLoc.csv")
+ } else {
+ potCanals_gageloc <- read.csv("temp/GagestoCheck_GageLoc.csv")
+ }
+
+ gageloc_db_fin <- gageloc_db %>%
+ filter(!site_no %in% potCanals_gageloc$site_no, drain_area >
+ (min_da_km_gages * sqkm_sqmi))
+
+ # Gages that are ST site types, but reside on canals, artificial waterbodies.
+ document_dropped_gage(select(potCanals_gageloc, site_no), "GageLoc", "ST; Pot. Canal")
+ document_dropped_gage(gageloc_db_fin %>%
+ filter(!site_no %in% potCanals_gageloc$site_no,
+ drain_area < min_da_km_gages) %>% select(site_no),
+ "GageLoc", "below DA")
+
+ # NHD gages shpafile
+ gageloc_final <- gageloc_sf %>%
+ inner_join(gageloc_db_fin, by = "site_no") %>%
+ select(-c(coord_acy_, huc_cd, parm_cd, stat_cd, missing_da, site_tp_cd)) %>%
+ st_as_sf(coords = c("dec_long_v", "dec_lat_va")) %>%
+ mutate(source = "GageLoc") %>%
+ # deal with one duplicate row
+ group_by(site_no) %>%
+ filter(total_obs == max(total_obs)) %>%
+ ungroup() %>%
+ st_sf() %>%
+ st_compatibalize(SWIM$final)
+
+ list(final = gageloc_final, filtered = gageloc_sf, full = gageloc_sf_full,
+ db = gageloc_db_full, potCanals = potCanals_gageloc)
+}
+
+#' prepare GFv11 gages
+#' @param gfv11_gages_rds rds copy of POIs that are gages from gfv11
+#' @param gfv11_gages_dbf dbf of gf gages as output from 00_gage_info
+#' @param usgs_ref_gages USGS stream gages from reference gages / NLDI
+#' @param NHDPlusV2_gages list of data.frames from prepare_gage_locations
+#' @param SWIM list of data.frames from prepare_SWIM
+#' @param reference_flowlines sf data.frame containing reference flowlines
+#' @return list with one "final" data.frame for use in later steps
+prepare_gfv11_gages <- function(gfv11_gages_rds, gfv11_gages_dbf, usgs_ref_gages,
+ NHDPlusV2_gages, SWIM, reference_flowlines) {
+
+ # Integrate GFv11 locations not included in GagesLoc and/or gagesIII
+ gfv11_sf_full <- readRDS(gfv11_gages_rds) %>%
+ st_zm(drop = TRUE) %>%
+ st_transform(st_crs(NHDPlusV2_gages$final))
+
+ # Filter to sites not in GagesIII or GageLoc
+ gfv11_db_full <- read.dbf(file = gfv11_gages_dbf, as.is = TRUE) %>%
+ #filter(site_no %in% gfv11_sf_full$site_no) %>%
+ select(-c(agency_cd, site_tp_cd, coord_acy_, huc_cd, parm_cd, stat_cd, ts_id, missing_da)) %>%
+ rename(total_obs = count_nu, total_poss_obs = TPdays1)
+
+ # Remove transboundary
+ gfv11_sf <- gfv11_sf_full %>%
+ # Remove streamgages assocaited with transboundary
+ filter(nchar(NHD_Unit) < 4,
+ !Type_Gage %in% c(SWIM$final$site_no, NHDPlusV2_gages$final$site_no)) %>%
+ select(site_no = Type_Gage, NHDPlusID) %>%
+ # join to get comid, reachcode, measure data
+ left_join(st_drop_geometry(NHDPlusV2_gages$full), by = "site_no") %>%
+ # Know from previous work 3 locations with no COM/RC/M
+ left_join(select(st_drop_geometry(reference_flowlines), COMID, REACHCODE, FromMeas),
+ by = c("NHDPlusID" = "COMID")) %>%
+ # bring over RC/M for 3 gages missing them
+ mutate(comid = ifelse(is.na(comid), NHDPlusID, comid),
+ reachcode = ifelse(is.na(reachcode), REACHCODE, reachcode),
+ reach_meas = ifelse(is.na(reach_meas), FromMeas, reach_meas)) %>%
+ select(-c(NHDPlusID, REACHCODE, FromMeas)) %>%
+ # Update index information with NLDI gages
+ left_join(select(st_drop_geometry(usgs_ref_gages),
+ id, nhdpv2_COMID, nhdpv2_REACHCODE, nhdpv2_REACH_measure),
+ by = c("site_no" = "id")) %>%
+ mutate(comid = ifelse(!is.na(nhdpv2_COMID), nhdpv2_COMID, comid),
+ reachcode = ifelse(!is.na(nhdpv2_REACHCODE),
+ nhdpv2_REACHCODE, reachcode),
+ reach_meas = ifelse(!is.na(nhdpv2_REACH_measure),
+ nhdpv2_REACH_measure, reach_meas)) %>%
+ select(site_no, comid, reachcode, reach_meas) %>%
+ filter(!is.na(comid)) %>%
+ st_sf()
+
+ # get NWIS, non-GF lat lon for GFv11 gages
+ gfv11_nwis <- dataRetrieval::readNWISsite(gfv11_sf$site_no) %>%
+ filter(agency_cd == "USGS") %>%
+ select(site_no, dec_long_va, dec_lat_va) %>%
+ st_as_sf(coords = c("dec_long_va", "dec_lat_va"), crs = 4269)
+
+ # Bring NWIS geometries over to GFv11 data
+ gfv11_sf_final <- st_drop_geometry(gfv11_sf) %>%
+ inner_join(gfv11_nwis, by = "site_no") %>%
+ st_as_sf()
+
+ # Build list of STAID - Drainage area for use in the GFv11 section
+ # combine DA data from dbf outputs from 00_get_data
+ DA_data <- rbind(select(gfv11_db_full, site_no, drain_area),
+ select(NHDPlusV2_gages$db, site_no, drain_area),
+ select(SWIM$db, site_no, drain_area)) %>%
+ dplyr::filter(!is.na(drain_area)) %>%
+ dplyr::rename(drain_area_full = drain_area) %>%
+ dplyr::filter(site_no %in% gfv11_sf_final$site_no) %>%
+ distinct()
+
+ # final Gfv11 file, rebuild geometry
+ gfv11_final <- gfv11_sf_final %>%
+ left_join(gfv11_db_full, by = "site_no") %>%
+ mutate(source = "GFv11") %>%
+ left_join(DA_data, by = "site_no") %>%
+ dplyr::mutate(drain_area = if_else(is.na(drain_area), drain_area_full, drain_area)) %>%
+ select(-drain_area_full) %>%
+ st_compatibalize(SWIM$final)
+
+ # Gages that don't fit the POR requirement, or are non-ST site types
+ document_dropped_gage(filter(st_drop_geometry(gfv11_sf) %>% select(site_no), !site_no %in% gfv11_db_full$site_no),
+ "GFv11", "No Q")
+
+ return(list(final = gfv11_final))
+}
+
+#' finalize gage selections
+#' @param NHDPlusV2_gages list of data.frames from prepare_gage_locations
+#' @param SWIM list of data.frames from prepare_SWIM
+#' @param gfv11_gages list with finalized gfv11 gages
+#' @param gages_ii_ref data.frame of gages_ii reference gages
+#' @param gage_info_gpkg character path to output gages to
+#' @param gage_info_csv character path to output gages to
+#' @param gage_info_csvt character path to output gages to
+#' @param geo_crs coordinate reference system for gage output
+finalize_gages <- function(SWIM, NHDPlusV2_gages, gfv11_gages, gages_ii_ref,
+ gage_info_gpkg, gage_info_csv, gage_info_csvt,
+ geo_crs = 4326) {
+
+ # Bind them together
+ gage_final <- data.table::rbindlist(list(SWIM$final, NHDPlusV2_gages$final,
+ gfv11_gages$final)) %>%
+ st_as_sf()
+
+ # which gagesii_ref gages are missing from final set
+ missing_gagesii_ref <- filter(gages_ii_ref, !id %in% gage_final$site_no) %>%
+ rename(site_no = id, comid = nhdpv2_COMID, reachcode = nhdpv2_REACHCODE,
+ reach_meas = nhdpv2_REACH_measure) %>%
+ inner_join(NHDPlusV2_gages$db, by = "site_no") %>%
+ select(-c(agency_cd, site_tp_cd, coord_acy_, huc_cd, parm_cd, stat_cd, ts_id, missing_da)) %>%
+ st_compatibalize(gage_final)
+
+ # Append those with data to gage_final
+ gage_final <- data.table::rbindlist(list(gage_final, missing_gagesii_ref), fill = TRUE) %>%
+ st_as_sf()
+
+ # Rank multiple gages that occur on same COMID
+ gage_final_ranked <- gage_final %>%
+ filter(!is.na(comid)) %>%
+ group_by(comid) %>%
+ mutate(n = n()) %>%
+ # Arrange by number of days
+ arrange(total_obs, .by_group = TRUE) %>%
+ # Populate by rank (1 - lowest number of days to n(highest))
+ mutate(gage_score = ifelse(n > 1, row_number(), 1)) %>%
+ # If a reference gage is one of gages, bump that to the top
+ rowwise() %>%
+ mutate(gage_score = ifelse(n > 1,
+ ifelse(!is.na(gagesII_cl) && gagesII_cl == "Ref",
+ max(gage_score) + 1, gage_score), gage_score)) %>%
+ ungroup() %>%
+ # Some gages have multiple gages with same days (inlets/outlets around dam)
+ # This further prioritizes to the gage with the smallest reach measure (furthest downstream)
+ group_by(comid, total_obs) %>%
+ mutate(n = n()) %>%
+ arrange(reach_meas, .by_group = TRUE) %>%
+ rowwise() %>%
+ mutate(gage_score = ifelse(n > 1,
+ ifelse(reach_meas == min(reach_meas), max(gage_score) + 1, gage_score), gage_score)) %>%
+ ungroup() %>%
+ group_by(comid) %>%
+ mutate(n = n()) %>%
+ arrange(end_date, -reach_meas) %>%
+ rowwise() %>%
+ mutate(gage_score = ifelse(n > 1,
+ ifelse(end_date == max(end_date), max(gage_score) + 1, gage_score), gage_score)) %>%
+ ungroup() %>%
+ select(-n) %>%
+ st_transform(geo_crs)
+
+ # conver to emtpy strings
+ write_sf(gage_final_ranked, gage_info_gpkg, "Gages")
+
+ # Format csv and csvt file
+ # Convert geometry to WKT format
+ gage_final_ranked <- st_as_sf(gage_final_ranked, wkt = "geometry")
+
+ # Format to WKT geometry field
+ gage_final_ranked$WKT <- paste0("POINT", noquote('('), data.frame(st_coordinates(gage_final_ranked))$X, ' ',
+ data.frame(st_coordinates(gage_final_ranked))$Y, noquote(')'))
+
+ # Classes of columns
+ gage_final_ranked_csvt <- unlist(sapply(st_drop_geometry(gage_final_ranked), class))
+ # replace names
+ gage_final_ranked_csvt <- gage_final_ranked_csvt[names(gage_final_ranked_csvt) != "WKT"]
+ gage_final_ranked_csvt <- gsub("character", "String", gage_final_ranked_csvt)
+ gage_final_ranked_csvt <- gsub("numeric", "Real", gage_final_ranked_csvt)
+ gage_final_ranked_csvt <- gsub("Date", "Date (YYYY-MM-DD)", gage_final_ranked_csvt)
+
+ # write csv
+ write.csv(st_drop_geometry(gage_final_ranked), gage_info_csv, row.names = F, quote = F)
+
+ # Write csvt
+ csvt_names <- as.matrix(t(unname(gage_final_ranked_csvt)))
+ write.table(csvt_names, file = gage_info_csvt, sep = ",",
+ col.names = FALSE, row.names = F)
+
+ return(list(final = gage_final_ranked))
+}
+
+#' prepare vpu base layers
+#' @param reg_gpkg character path to geopackage containing reference fabric for this vpu
+#' @param nav_gpkg character path to geopackage where vpu base layers will be written
+#' @param vpu vpu that will be written into output list
+#' @param full_cat_table table of all catchments for each vpu
+#' @param rpu_vpu data.frame ontaining all rpu-vpu pairs
+#' @return a list with the vpu and three tables for flowlines, waterbodies, and catchments
+prepare_vpu_base_layers <- function(ref_gpkg, nav_gpkg, vpu, full_cat_table, rpu_vpu) {
+
+ fline <- read_sf(ref_gpkg, "flowlines")
+ catchment <- read_sf(ref_gpkg, "catchments")
+ waterbodies <- read_sf(ref_gpkg, "waterbodies")
+
+ # we can remove truely degenerate COMIDs
+ # for 0 upstream area and no catchment area
+ degen_comid <- fline[fline$TotDASqKM == 0 &
+ !fline$COMID %in% catchment$featureid, ]$COMID
+
+ # need to make sure we don't disconnect anything.
+ keep_tocomid <- fline$toCOMID[!fline$COMID %in% degen_comid]
+
+ if(length(degen_comid[degen_comid %in% keep_tocomid]) > 0) stop("this will break the network")
+
+ fline <- fline[!fline$COMID %in% degen_comid, ]
+
+ # there are some duplicates with enhd
+ nhd <- fline %>%
+ group_by(COMID) %>%
+ filter(row_number() == 1) %>%
+ ungroup() %>%
+ make_standalone()
+
+ # Filter and write dendritic/non-coastal subset to gpkg
+ # This will be iterated over to produce the final network after POIs identified
+ zero_order <- filter(nhd, TerminalFl == 1 & TotDASqKM < min_da_km_gages)
+ non_dend <- unique(unlist(lapply(zero_order$COMID, \(x, nhdDF) get_UM(nhdDF, x), nhdDF = st_drop_geometry(nhd))))
+ nhd <- nhd %>%
+ mutate(dend = ifelse(!COMID %in% non_dend, 1, 0),
+ poi = ifelse(!COMID %in% non_dend & TotDASqKM >= min_da_km_gages, 1, 0))
+
+ cat_network <- st_drop_geometry(nhd)
+ names(cat_network) <- tolower(names(cat_network))
+ cat_network <- select(cat_network, comid, tocomid, lengthkm, areasqkm, totdasqkm,
+ hydroseq, levelpathi, terminalpa, dnlevelpat, dnhydroseq,
+ reachcode, frommeas, tomeas, pathlength, arbolatesu,
+ ftype, fcode, vpuid, rpuid, wbareacomi)
+
+ write_sf(nhd, nav_gpkg, nhd_flowline)
+ write_sf(cat_network, nav_gpkg, nhd_network)
+ write_sf(waterbodies, nav_gpkg, nhd_waterbody)
+
+ rpus <- rpu_vpu[rpu_vpu$vpuid == vpu,]$rpuid
+
+ cats_rpu <- full_cat_table %>%
+ filter(RPUID %in% rpus)
+
+ cats <- catchment %>%
+ rename(FEATUREID = featureid,
+ AREASQKM = areasqkm) %>%
+ mutate(VPUID = vpu) %>%
+ left_join(select(cats_rpu, FEATUREID, RPUID), by = c("FEATUREID")) %>%
+ filter(FEATUREID %in%
+ unique(c(nhd$COMID,
+ full_cat_table$FEATUREID[full_cat_table$RPUID %in% rpus]))) %>%
+ mutate(hy_cats = ifelse(FEATUREID %in% nhd$COMID, 1, 0),
+ full_cats = ifelse(FEATUREID %in% cats_rpu$FEATUREID, 1, 0)) %>%
+ filter(full_cats == 1 | hy_cats == 1) %>%
+ st_sf()
+
+ write_sf(cats, nav_gpkg, nhd_catchment)
+
+ rpu_list <- setNames(rep(list(list()), length(rpus)), rpus)
+
+ for(rpu_code in rpus) {
+
+ out_refac_gpkg <- file.path("cache", paste0(rpu_code, "_refactor.gpkg"))
+
+ nhd_sub <- subset_rpu(nhd, rpu_code, run_make_standalone = TRUE) %>%
+ st_sf()
+
+ write_sf(nhd_sub, out_refac_gpkg, nhd_flowline)
+
+ cats_rpu <- full_cat_table %>%
+ filter(RPUID == rpu_code)
+
+ catchments <- cats %>%
+ mutate(hy_cats = ifelse(FEATUREID %in% nhd_sub$COMID, 1, 0),
+ full_cats = ifelse(FEATUREID %in% cats_rpu$FEATUREID, 1, 0)) %>%
+ filter(full_cats == 1 | hy_cats == 1) %>%
+ st_sf()
+
+ write_sf(catchments, out_refac_gpkg, nhd_catchment)
+
+ rpu_list[[rpu_code]] <- list(flowline = nhd_sub, catchment = catchments)
+
+ }
+
+ return(list(vpu = vpu, flowline = nhd, catchment = cats, catchment_network = cat_network, waterbodies = waterbodies, rpus = rpu_list))
+}
+
+#' prepare rpu vpu output list
+#' @param vpu_base list of data as output from prepare_vpu_base_layers
+#' @param rpu_vpu data.frame ontaining all rpu-vpu pairs
+#' @returns list of outputs from a vpu and rpus that make it up
+prep_rpu_vpu_out_list <- function(vpu_base, rpu_vpu) {
+
+ nhd <- vpu_base$flowline
+ vpu <- vpu_base$vpu
+
+ out_vpu <- nhd %>%
+ st_drop_geometry() %>%
+ select(COMID, toCOMID) %>%
+ filter(!toCOMID %in% COMID & !toCOMID == 0)
+
+ rpus <- rpu_vpu[rpu_vpu$vpuid == vpu,]$rpuid
+
+ rpu_list <- setNames(rep(list(list()), length(rpus)), rpus)
+
+ for(rpu_code in rpus) {
+
+ nhd_sub <- vpu_base$rpus[[rpu_code]]$flowline
+
+ rpu_list[[rpu_code]] <- nhd_sub %>%
+ st_drop_geometry() %>%
+ select(COMID, toCOMID) %>%
+ filter(!toCOMID %in% COMID & !toCOMID == 0)
+ }
+ return(list(vpu = vpu, vpu_out = out_vpu, rpu_out = rpu_list))
+}
+
+#' prepare rpu vpu out
+#' @param rpu_vpu_out_list list of rpu vpu outlets
+#' @param fline reference flowlines
+#' @returns table of flowlines that are rpu and/or vpu outlets
+prep_rpu_vpu_out <- function(rpu_vpu_out_list, fline) {
+
+ make_df <- function(x, d, n) {
+ y <- d[[x]]
+ nr <- nrow(y)
+ na <- names(d)[x]
+ o <- data.frame(d = rep(na, nr),
+ COMID = d[[x]]$COMID,
+ toCOMID = d[[x]]$toCOMID)
+ names(o) <- c(n, "COMID", "toCOMID")
+ o
+ }
+
+ out_rpu <- unlist(lapply(unname(rpu_vpu_out_list), \(x) x$rpu_out), recursive = FALSE)
+ out_vpu <- lapply(rpu_vpu_out_list, \(x) x$vpu_out)
+
+ names(out_vpu) <- sapply(rpu_vpu_out_list, \(x) x$vpu)
+
+ rpu <- do.call(rbind, lapply(1:length(out_rpu), make_df, d = out_rpu, n = "rpu"))
+
+ vpu <- do.call(rbind, lapply(1:length(out_vpu), make_df, d = out_vpu, n = "vpu"))
+
+ out_rpu_vpu <- left_join(rpu, vpu, by = "COMID")
+
+ out_rpu_vpu <- select(out_rpu_vpu, RPUID = rpu, VPUID = vpu, COMID = COMID, toCOMID = toCOMID.x)
+
+ out_rpu_vpu <- left_join(out_rpu_vpu, select(sf::st_drop_geometry(fline), COMID, toRPUID = RPUID, toVPUID = VPUID),
+ by = c("toCOMID" = "COMID"))
+
+ out_rpu_vpu
+
+}
+
+#' make combined waterbodies
+#' @param nhdplus_gdb NHDPlusV2 Geodatabase path
+#' @param proj_crs projected crs to use
+#' @return sf data.frame combining the NHDWaterbody and NHDArea layers
+#'
+make_combined_waterbodies <- function(nhdplus_gdb, proj_crs) {
+ data.table::rbindlist(
+ list(
+
+ read_sf(nhdplus_gdb, "NHDWaterbody") |>
+ st_transform(proj_crs) |>
+ mutate(layer = "NHDWaterbody"),
+
+ read_sf(nhdplus_gdb, "NHDArea") |>
+ st_transform(proj_crs) |>
+ mutate(layer = "NHDArea")
+
+ ), fill = TRUE) |>
+ st_as_sf()
+}
diff --git a/workspace/R/02_POI_creation_functions.R b/workspace/R/02_POI_creation_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..495edc6d7559f428cf6c1aec747cb85eb3033755
--- /dev/null
+++ b/workspace/R/02_POI_creation_functions.R
@@ -0,0 +1,2476 @@
+#' create hu12 POIs
+#' @param data hu12_points
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+#' @param vpu vpu that is being executed
+#' @returns hu12 poi set
+create_hu12_pois <- function(data, flowline, poi_name, vpu) {
+
+ # Some NHDPlus VPUs include HUCs from other VPUs
+ if(vpu == "02"){
+ grep_exp <-"^02|^04"
+ } else if (vpu == "08") {
+ grep_exp <- "^03|^08"
+ } else {
+ grep_exp <- paste0("^", substr(vpu, start = 1, stop = 2))
+ }
+
+ # Join HUC12 outlets with NHD
+ HUC12_COMIDs <- data %>%
+ filter(grepl(grep_exp, .data$HUC12)) %>%
+ select(COMID, HUC12) %>%
+ # Remove this when HUC12 outlets finished
+ group_by(COMID) %>%
+ filter(row_number() == 1) %>%
+ ungroup()
+
+ # Create POIs - some r05 HUC12 POIs not in R05 NHD
+ list(POIs = POI_creation(st_drop_geometry(HUC12_COMIDs), filter(flowline, poi == 1), poi_name),
+ HUC12_COMIDs = HUC12_COMIDs, vpu = vpu)
+
+}
+
+#' create gage pois
+#' @param gages as output from 01_prep finalize gages
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+#' @param POIs pois from previous target
+#' @param min_da_km_gages minimum drainage area for gages to be included
+#' @param combine_meters length to be used later in the workflow to combine flowlines
+#' @param reach_meas_thresh a threshold used to determine if a gage will split a flowline or not
+#'
+create_gage_pois <- function(gages, flowline, poi_name, POIs,
+ min_da_km_gages = 5,
+ combine_meters, reach_meas_thresh) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # Previously identified streamgages within Gage_Selection.Rmd
+ streamgages_VPU <- gages %>%
+ rename(COMID = comid) %>%
+ filter(COMID %in% flowline$COMID) %>%
+ inner_join(st_drop_geometry(st_drop_geometry(flowline), COMID, Divergence), by = "COMID") %>%
+ switchDiv(., flowline) %>%
+ filter(drain_area > min_da_km_gages)
+
+ streamgages <- streamgages_VPU %>%
+ group_by(COMID) %>%
+ # If multiple gages per COMID, pick one with highest rank as rep POI_ID
+ filter(gage_score == max(gage_score), !is.na(drain_area)) %>%
+ ungroup()
+
+ # Derive GAGE POIs; use NHD as we've already filtered by NWIS DA in the Gage selection step
+ gages_POIs <- gage_POI_creation(POIs, streamgages, filter(flowline, poi == 1),
+ combine_meters, reach_meas_thresh, poi_name)
+
+ POIs <- gages_POIs$POIs
+
+ events <- rename(gages_POIs$events, POI_identifier = Type_Gages)
+
+ unassigned_gages <- filter(streamgages_VPU, !site_no %in% POIs$Type_Gages) %>%
+ rename(nhd_reachcode = REACHCODE)
+
+ if(nrow(unassigned_gages)> 0) {
+ # Start documenting gages that are dropped out; these gages have no mean daily Q
+ document_dropped_gage(select(unassigned_gages, site_no),
+ "Gages_info", paste0("VPU ", vpu, "; low gage score"))
+ }
+
+ list(POIs = POIs, events = events, unassigned_gages = unassigned_gages, vpu = vpu)
+
+}
+
+#' Creates POIs for gages using refactor criteria
+#' @param POIs (sf data.frame) current data frame of POIs
+#' @param gages_info (sf data.frame) VPU specific streamgages from 01_gage_selection
+#' @param nhd (sf data.frame) flowline data.frame
+#' @param combine_meters (integer) refactor threshold (m) for if if two adjacent fl should be combined
+#' @reach_meas_thresh (integer) threshold added or substracted from reach_meas to determine if a gage will split fl
+#'
+#' @return (sf data.frame) dataframe of gage POIs
+#'
+gage_POI_creation <- function(POIs, gages_info, nhd, combine_meters, reach_meas_thresh, poi_name){
+
+ # Create streamgage POIs
+ gage_POIs <- POI_creation(select(st_drop_geometry(gages_info), COMID, site_no), nhd, poi_name) %>%
+ st_compatibalize(., POIs)
+
+ # Avoid these for refactoring
+ avoid <- dplyr::filter(nhd, (sqrt(AreaSqKM) / LENGTHKM) > 3 & AreaSqKM > 1)
+
+ # Create events for streamgages for flowline splitting
+ events <- gages_info %>%
+ # bring over NHD information
+ inner_join(select(st_drop_geometry(gage_POIs), Type_Gages), by = c("site_no" = "Type_Gages")) %>%
+ # Get over the NHD attributes
+ #inner_join(select(st_drop_geometry(nhd), AreaSqKM, REACHCODE, LENGTHKM, COMID, FromMeas, ToMeas),
+ # by = "COMID") %>%
+ # Apply reach measure thresholds
+ filter(reach_meas - FromMeas > reach_meas_thresh & AreaSqKM > 2 &
+ ToMeas - reach_meas > reach_meas_thresh & LENGTHKM > (combine_meters / m_per_km)) %>%
+ select(COMID, REACHCODE = reachcode, REACH_meas = reach_meas, Type_Gages = site_no) %>%
+ filter(!COMID %in% avoid$COMID) %>%
+ mutate(event_type = "streamgage") %>%
+ st_compatibalize(., POIs) %>%
+ mutate(nexus = TRUE)
+
+ # Reset gage flag if even is created
+ gage_POIs_nonevent <- filter(gage_POIs, !Type_Gages %in% events$Type_Gages) %>%
+ addType(., POIs, poi_name, nexus = FALSE, bind = TRUE)
+
+ if(nrow(events) > 0){
+ POIs <- data.table::rbindlist(list(gage_POIs_nonevent,
+ select(events, COMID, Type_Gages, nexus)), fill = TRUE) %>%
+ mutate(nexus = ifelse(is.na(nexus), FALSE, nexus)) %>%
+ st_as_sf()
+ } else {
+ events <- NA
+ POIs <- mutate(POIs, nexus = FALSE)
+ }
+
+
+ return(list(events = events, POIs = POIs))
+}
+
+#' create thermo electric POIs
+#' @param te_points point locations of thermo electric plants
+#' @param te_attributes attributes for te_points
+#' @param POIs pois from previous target
+#' @param HUC12_COMIDs HUC12_COMIDs from hu12 poi step
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+#'
+create_thermo_electric_pois <- function(te_points, te_attributes, POIs, HUC12_COMIDs,
+ flowline, poi_name) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ if(vpu == "08"){
+ flowline$VPUID <- "08"
+ } else {
+ flowline$VPUID <- substr(flowline$RPUID, 1, 2)
+ }
+
+ # Read in Thermoelectric shapefile for 2015 estimates
+ TE_v1 <- te_points
+ # Read in Thermoelectric Plants csv for updated estimates
+ TE_v2 <- te_attributes %>%
+ mutate(Plant.Code = as.integer(Plant.Code))
+
+ # Bind hydrographic address information together and get final COMIDs
+ TE_COMIDs_full <- TE_v2 %>%
+ filter(water_source %in% c("sw_fresh", "gw_fresh", "gw_sw_mix")) %>%
+ left_join(select(st_drop_geometry(TE_v1),
+ Plant.Code = EIA_PLANT_, COMID), by = "Plant.Code") %>%
+ left_join(rename(st_drop_geometry(HUC12_COMIDs), huc12_comid = COMID),
+ by = c("huc_12" = "HUC12")) %>%
+ mutate(COMID = ifelse(is.na(COMID), huc12_comid, COMID)) %>%
+ select(-huc12_comid)
+
+ # Prepare TE for POI Creation
+ TE_COMIDs <- TE_COMIDs_full %>%
+ inner_join(select(st_drop_geometry(flowline), COMID, VPUID), by = "COMID") %>%
+ filter(grepl(paste0("^", substr(vpu, 1, 2), ".*"), .data$VPUID), COMID > 0) %>%
+ switchDiv(., flowline) %>%
+ group_by(COMID) %>%
+ summarize(eia_id = paste0(unique(Plant.Code), collapse = " "), count = n()) %>%
+ ungroup()
+
+ unassigned_plants <- filter(TE_COMIDs, !COMID %in% POIs$COMID)
+
+ if(nrow(TE_COMIDs) > 0){
+ # Derive TE POIs
+ POIs <- POI_creation(st_drop_geometry(TE_COMIDs), filter(flowline, poi == 1), poi_name) %>%
+ addType(., POIs, "TE", nexus = TRUE)
+
+ }
+
+ list(POIs = POIs, unassigned_plants = unassigned_plants, vpu = vpu)
+}
+
+#' make waterbodies layer
+#' @param combined_waterbodies nhdplus area and waterbody layers combined together
+#' @param
+make_waterbodies_layer <- function(combined_waterbodies, flowline, geo_crs = 4326) {
+
+ # Waterbodies sourced from NHD waterbody layer for entire VPU
+ WBs_VPU_all <- filter(combined_waterbodies,
+ COMID %in% flowline$WBAREACOMI) %>%
+ filter(FTYPE != "SwampMarsh") %>%
+ mutate(FTYPE = as.character(FTYPE),
+ source = "NHDv2WB",
+ wb_id = ifelse(GNIS_ID == " ", COMID, GNIS_ID)) %>%
+ st_transform(geo_crs) %>%
+ st_make_valid()
+
+ old_sf_use_s2 <- sf_use_s2(FALSE)
+
+ ref_WB <- WBs_VPU_all %>%
+ group_by(wb_id, GNIS_NAME) %>%
+ sfheaders::sf_remove_holes() %>%
+ summarize(do_union = TRUE, member_comid = paste(COMID, collapse = ",")) %>%
+ st_make_valid() %>%
+ ungroup() %>%
+ mutate(area_sqkm = as.numeric(st_area(.)) / 1000000) %>%
+ mutate(source = "NHDv2WB") %>%
+ st_cast("MULTIPOLYGON")
+
+ sf_use_s2(old_sf_use_s2)
+
+ list(wbs_draft = WBs_VPU_all, WBs_layer_orig = ref_WB)
+}
+
+#' create resops POIs
+#' @param POIs POIs as created by previous step
+#' @param wbs waterbodies table
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+#'
+create_resops_pois <- function(POIs, wbs, istarf_xwalk, flowline, poi_name = "resops") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # Unnest wb_poi_lst
+ wb_table <- st_drop_geometry(wbs$WBs_layer_orig) %>%
+ dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
+ tidyr::unnest(cols = member_comid) %>%
+ mutate(member_comid = as.character(member_comid)) %>%
+ distinct()
+
+ # ResOpsUS locations with attributes from the VPU NHDv2 wb set
+ resops_wb_df <- istarf_xwalk %>%
+ # Subset to VPU, only one DAMID per waterbody
+ filter(flowlcomid %in% flowline$COMID |
+ wbareacomi %in% wb_table$member_comid) %>%
+ dplyr::select(grand_id, nid_source_featureid, source = comi_srclyr,
+ flowlcomid, wbareacomi, hr_permid, onoffnet) %>%
+ mutate(wbareacomi = as.character(wbareacomi)) %>%
+ # Link to waterbody table
+ left_join(distinct(wb_table, member_comid, wb_id),
+ by = c("wbareacomi" = "member_comid")) %>%
+ left_join(select(st_drop_geometry(wbs$wbs_draft), wbareacomi = COMID,
+ wb_id2 = wb_id) %>%
+ mutate(wbareacomi = as.character(wbareacomi)),
+ by = "wbareacomi") %>%
+ mutate(wb_id = ifelse(is.na(wb_id), wb_id2, wb_id),
+ wbareacomi = ifelse(wbareacomi == -2,
+ hr_permid, wbareacomi)) %>%
+ select(-c(wb_id2))
+
+ # POIs with waterbody IDs in reference waterbodies
+ resops_wb_pois <- filter(wbs$WBs_layer_orig, wb_id %in% resops_wb_df$wb_id) %>%
+ inner_join(select(st_drop_geometry(resops_wb_df), grand_id,
+ NID_ID = nid_source_featureid,
+ resops_flowlcomid = flowlcomid, wb_id),
+ by = "wb_id") %>%
+ #mutate(source = "ref_WB") %>%
+ group_by(wb_id) %>%
+ filter(n() == 1) %>%
+ st_as_sf()
+
+ # Add ResOPsUS locations to waterbody list with attributed NID and resops data
+ if(nrow(resops_wb_pois) > 0){
+ wb_poi_lst_filtered <- filter(wbs$WBs_layer_orig, !wb_id %in% resops_wb_pois$wb_id,
+ !is.na(wb_id))
+
+ wb_poi_lst <- data.table::rbindlist(list(wb_poi_lst_filtered, resops_wb_pois),
+ fill = TRUE) %>%
+ mutate(accounted = 0) %>%
+ st_as_sf()
+
+ } else {
+
+ wb_poi_lst <- mutate(wbs$WBs_layer_orig, accounted = 0)
+
+ }
+
+ # Reach resopsus
+ reach_resops <- filter(resops_wb_df, !wb_id %in% wb_poi_lst$wb_id,
+ !source %in% c("NHDAREA", "HR ID AVAILABLE") |
+ onoffnet == 0) %>%
+ mutate(Type_WBOut = NA) %>%
+ select(COMID = flowlcomid, resops = grand_id, Type_WBOut)
+
+ # Existing reservoir-waterbody outlet POIs
+ exist_POIs_WB <- filter(resops_wb_df, flowlcomid %in% POIs$COMID) %>%
+ mutate(wb_id = ifelse(source == "NHDAREA", wbareacomi, wb_id)) %>%
+ filter(!is.na(wb_id)) %>%
+ select(COMID = flowlcomid, resops = grand_id, Type_WBOut = wb_id)
+
+ # Resops POIs
+ resops_pois <- rbind(reach_resops, exist_POIs_WB)
+
+ # Resops defined by reach
+ if(nrow(resops_pois) > 0){
+ # Resops POIs with no reservoirs, defined by reach
+ POIs <- POI_creation(resops_pois, filter(flowline, poi == 1), poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+
+ # TODO: investigate many to many join
+ # Add waterbody attribute
+ POIs <- POIs %>%
+ left_join(select(resops_pois, COMID, Type_WBOut),
+ by = "COMID") %>%
+ mutate(Type_WBOut = ifelse(!nexus,
+ Type_WBOut, NA))
+
+ # Resops with reservoirs
+ resops_wb_df <- resops_wb_df %>%
+ mutate(accounted = ifelse(grand_id %in% POIs$Type_resops, 1, 0),
+ source = ifelse(grand_id %in% reach_resops$resops, "REACH", source))
+ }
+ list(wb_pois = wb_poi_lst, wb_resops = resops_wb_df, POIs = POIs, vpu = vpu)
+
+}
+
+#' create hilarri pois
+#' @param POIs POIs as created by previous step
+#' @param wbs waterbodies table
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+create_hilarri_pois <- function(POIs, hilarri_data, wb_poi_lst, flowline, poi_name = "hilarri") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ old_sf_use_s2 <- sf::sf_use_s2(FALSE)
+ on.exit(sf::sf_use_s2(old_sf_use_s2))
+ # 1: Many based on original GNIS_ID
+ wb_table <- st_drop_geometry(wb_poi_lst) %>%
+ dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
+ tidyr::unnest(cols = member_comid) %>%
+ mutate(member_comid = as.integer(member_comid)) %>%
+ distinct()
+
+ # Hilarri POI Points
+ hilarri_points <- hilarri_data %>%
+ mutate(nhdwbcomid = as.integer(nhdwbcomid)) %>%
+ filter(!dataset %in% c('Power plant only; no reservoir or inventoried dam'),
+ nhdv2comid %in% flowline$COMID) %>%
+ left_join(select(wb_table, member_comid, wb_id),
+ by = c("nhdwbcomid" = "member_comid"))
+
+ # Waterbodies linked to hilarri information
+ hil_wb_pois_rf <- wb_poi_lst %>%
+ inner_join(select(st_drop_geometry(hilarri_points), hilarriid, nhdwbcomid,
+ nidid_hill = nidid, wb_id),
+ by = "wb_id") %>%
+ group_by(wb_id) %>%
+ mutate(hilarriid = paste0(hilarriid, collapse = ","),
+ nidid_hill = paste0(nidid_hill, collapse = ",")) %>%
+ ungroup() %>%
+ distinct() %>%
+ st_as_sf() %>%
+ st_compatibalize(wb_poi_lst)
+
+ # Add ResOPsUS locations to waterbody list
+ if(nrow(hil_wb_pois_rf) > 0){
+ wb_poi_lst <- wb_poi_lst %>%
+ #filter(!is.na(resops_FlowLcomid)) %>%
+ left_join(select(st_drop_geometry(hil_wb_pois_rf), wb_id, hilarriid,
+ nidid_hill), by = "wb_id") %>%
+ mutate(NID_ID = ifelse(is.na(NID_ID), nidid_hill, NID_ID)) %>%
+ select(-nidid_hill) %>%
+ distinct()
+ }
+
+ # Reach POIs
+ reach_pois <- filter(hilarri_points, !hilarriid %in% wb_poi_lst$hilarriid) %>%
+ select(COMID = nhdv2comid, hilarriid) %>%
+ mutate(COMID = as.integer(COMID)) %>%
+ group_by(COMID) %>%
+ filter(row_number() == 1) %>%
+ st_drop_geometry()
+
+ # Make POIs for reach POIs
+ POIs <- POI_creation(reach_pois, filter(flowline, poi == 1), poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+
+ list(POIs = POIs, wb_pois = wb_poi_lst, vpu = vpu)
+
+}
+
+#' create waterbody outlet pois
+#' @param POIs POIs from previous step
+#' @param NHDPlus_NHDArea NHDArea features from NHDPlusV2
+#' @param wb_poi_lst wb_pois from hilarri output list
+#' @param resops_wb_df wb_resops from resops output list
+#' @param flowline flowlines to attach pois to
+#' @param events events from gage output list
+#' @param proj_crs projected crs for overall project
+#' @param gages gages from gage_info_gpkg
+#' @param poi_name name for poi set
+create_wb_outlet_pois <- function(POIs,
+ NHDPlus_NHDArea,
+ wb_poi_lst,
+ resops_wb_df,
+ flowline,
+ events,
+ proj_crs,
+ gages,
+ poi_name,
+ nhdplushr_dir) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # Hillari IDs
+ hilarri_pois <- filter(POIs, !is.na(Type_hilarri))
+
+ # Get NHDARea polygons already define
+ nhd_area_vpu <- NHDPlus_NHDArea %>%
+ select(COMID, AREASQKM) %>%
+ mutate(source = "NHDv2Area") %>%
+ st_compatibalize(wb_poi_lst)
+
+ # Non-nhdv2 waterbodies from resopsus
+ other_wbs <- filter(resops_wb_df, !wb_id %in% wb_poi_lst$wb_id,
+ source != "REACH") %>%
+ select(grand_id, member_comid = wbareacomi, resops_flowlcomid = flowlcomid,
+ source, accounted) %>%
+ left_join(select(st_drop_geometry(hilarri_pois),
+ COMID, hilarriid = Type_hilarri),
+ by = c("resops_flowlcomid" = "COMID")) %>%
+ group_by(resops_flowlcomid) %>%
+ filter(row_number() == 1) %>%
+ ungroup() %>%
+ left_join(select(nhd_area_vpu, COMID) %>%
+ mutate(COMID = as.character(COMID)),
+ by = c("member_comid" = "COMID")) %>%
+ st_as_sf() %>%
+ mutate(wb_id = ifelse(source == "NHDAREA", member_comid, NA)) %>%
+ st_drop_geometry()
+
+ # copy empty geometries to wb_list for use in wb POI function
+ if(nrow(other_wbs) > 0){
+ wb_poi_list_fn <- data.table::rbindlist(list(wb_poi_lst,
+ other_wbs),
+ fill = TRUE) %>%
+ distinct() %>%
+ st_as_sf()
+ } else {
+ wb_poi_list_fn <- wb_poi_lst
+ }
+
+ # Final waterbody list with all requirements
+ final_wb_list <- filter(wb_poi_list_fn,
+ area_sqkm > wb_area_thresh |
+ !is.na(resops_flowlcomid) |
+ !is.na(hilarriid))
+
+ new_path <- "?prefix=StagedProducts/Hydrography/NHDPlusHR/VPU/Current/GDB/"
+ assign("nhdhr_file_list", new_path, envir = nhdplusTools:::nhdplusTools_env)
+
+ # fix something here
+ wb_layers <- wbout_POI_creaton(filter(flowline, poi == 1), final_wb_list,
+ NHDPlus_NHDArea, POIs, proj_crs, wb_poi_lst, poi_name, nhdplushr_dir)
+
+ wb_events <- poi_missing_wb <- wb_missing_poi <- double_wb <- double_wb_pois <- NULL
+
+ if(!is.data.frame(wb_layers)){
+ # write_sf(wb_layers$nhd_wb_table, temp_gpkg, "wb_flowpaths")
+ #
+ wbs <- wb_layers$WBs
+ wb_pois <- wb_layers$POIs %>% filter(!is.na(Type_WBOut))
+ missing_wb <- filter(wbs, !wb_id %in% wb_pois$Type_WBOut)
+ print(nrow(missing_wb))
+
+ double_wb <- wbs %>% group_by(wb_id) %>% filter(n() > 1)
+
+ double_wb_pois <- wb_pois %>%
+ group_by(Type_WBOut) %>%
+ filter(n() > 1)
+
+ wb_missing_poi <- filter(wbs,
+ !wb_id %in% wb_pois$Type_WBOut)
+
+ poi_missing_wb <- filter(wb_pois, !Type_WBOut %in% wb_layers$WBs$wb_id)
+
+ #*************************************
+ if(all(!is.na(wb_layers$events))){
+ wb_events <- wb_layers$events %>%
+ select(COMID, REACHCODE, REACH_meas, POI_identifier = wb_id,
+ event_type, nexus) %>%
+ st_compatibalize(., events)
+
+ events <- rbind(events, wb_events)
+ }
+
+ POIs <- wb_layers$POIs
+ # Write out waterbodies
+ WB_VPU_pois <- wb_layers$WBs
+ } else {
+ POIs <- wb_layers
+ WB_VPU_pois <- final_wb_list
+ }
+
+ #12047928
+ wb_out_col <- wb_poi_collapse(POIs, flowline, events, gages)
+ POIs <- wb_out_col$POIs
+
+ if(all(!is.na(wb_out_col$events_ret))){
+ events <- wb_out_col$events_ret
+ }
+
+ list(POIs = POIs, wb_out_col = wb_out_col,
+ all_events = events, wb_events = wb_events,
+ double_wb = double_wb, double_wb_pois = double_wb_pois,
+ wb_missing_poi = wb_missing_poi, poi_missing_wb = poi_missing_wb,
+ updated_flowline = wb_layers$nhd_wb_table, WB_VPU_pois = WB_VPU_pois, vpu = vpu)
+}
+
+#' Creates Waterbody POIs, calls a few other functions
+#' @param nhd (sf data.frame) flowline data.frame
+#' @param wb_table (sf data.frame)
+#' @param nhdplus_area (sf data.frame) NHDPlus Area features
+#' @param crs (integer) CRS to use (epsg code)
+#' @param wb_poi_lst TODO
+#' @param poi_name name for pois to be created
+#' @param nhdplushr_dir directory containing NHDPlusHR data
+#'
+#' @return (sf data.frame) dataframe of waterbody outlet POIs
+#'
+wbout_POI_creaton <- function(nhd, wb_table, nhdplus_area, POIs, crs,
+ wb_poi_lst, poi_name, nhdplushr_dir){
+
+ wb_components_table <- st_drop_geometry(wb_table) %>%
+ dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
+ tidyr::unnest(cols = member_comid) %>%
+ mutate(member_comid = as.integer(member_comid)) %>%
+ distinct()
+
+ # R17, some wierd stuff going on in the waterbodies
+ if("947070203" %in% wb_components_table$member_comid){
+ wb_components_table <- wb_components_table %>%
+ filter(!wb_id %in% c(1503847, 1513298))
+ }
+
+ # Bring wb_id to NHD data frame
+ if(("wb_id") %in% colnames(nhd)){
+ nhd <- select(nhd, -wb_id)
+ }
+
+ nhd <- nhd %>%
+ left_join(distinct(st_drop_geometry(wb_components_table), wb_id, member_comid) %>%
+ mutate(member_comid = as.numeric(member_comid)),
+ by = c("WBAREACOMI" = "member_comid"))
+
+
+ # Resops that are either NHDArea or MHD HR source and are missing in the
+ # nhd attributiong table
+ resops_wb_other_sources <- filter(wb_table, source ==
+ "HR ID AVAILABLE" | (source == "NHDAREA" &
+ !wb_id %in% nhd$wb_id) &
+ accounted == 0)
+
+ # Resops that are not accounted for and NHDv2 waterbody or NHDArea sourced
+ resops_main <- filter(wb_table, !is.na(resops_flowlcomid) &
+ !wb_id %in% resops_wb_other_sources$wb_id,
+ accounted == 0)
+
+ # Remaining WB that don't have outlet COMID defined and aren't in ResOPsUS
+ WB_outlet <- filter(wb_table, is.na(resops_flowlcomid),
+ !wb_id %in% POIs$Type_WBOut)
+
+ # Size-based waterbody outlet POIs ot in NHDArea, HR, or
+ # manually defined with ResOPS
+ wbout_COMIDs <- nhd %>%
+ filter(wb_id %in% WB_outlet$wb_id) %>%
+ group_by(wb_id) %>%
+ slice(which.min(Hydroseq)) %>%
+ ungroup() %>%
+ switchDiv(., nhd) %>%
+ select(COMID, wb_id) %>%
+ mutate(wbtype = "size") %>%
+ st_drop_geometry() %>%
+ distinct()
+
+ # ResOpsUS defined outlets
+ resops_main_outlets <- select(st_drop_geometry(resops_main), COMID = resops_flowlcomid,
+ wb_id) %>%
+ mutate(wbtype = "resops")
+
+ # combine together
+ wbout_coms <- distinct(rbind(wbout_COMIDs, resops_main_outlets))
+
+ # Get NHDArea and HI-Res waterbodies for ResOpsUS locaitons
+ WBs_VPU_areaHR <- HR_Area_coms(nhd, resops_wb_other_sources, nhdplus_area, crs, nhdplushr_dir)
+
+ # if there are no HR/Area waterbodies generated
+ if(all(is.na(WBs_VPU_areaHR))){
+ POIs <- POI_creation(wbout_coms,
+ nhd, "wb_id") %>%
+ addType(., POIs, "wb_id", nexus = TRUE) %>%
+ mutate(Type_WBOut = ifelse(is.na(Type_WBOut), Type_wb_id, Type_WBOut)) %>%
+ select(-Type_wb_id) %>%
+ left_join(select(st_drop_geometry(resops_main), grand_id, resops_flowlcomid),
+ by = c("COMID" = "resops_flowlcomid")) %>%
+ mutate(Type_resops = ifelse(!is.na(grand_id), grand_id, Type_resops)) %>%
+ select(-grand_id)
+ } else {
+ # WBarea out comids
+ wbareaout_coms <- select(st_drop_geometry(nhd), COMID, Hydroseq) %>%
+ inner_join(filter(WBs_VPU_areaHR$nhd_wb_table, !is.na(outlet)),
+ by = c("COMID" = "comid")) %>%
+ group_by(wb_id) %>%
+ filter(Hydroseq == min(Hydroseq)) %>% #, row_number() == 1
+ ungroup() %>%
+ inner_join(select(WBs_VPU_areaHR$wb, -source), by = "wb_id") %>%
+ filter(source != "NHDHR") %>%
+ select(COMID, wb_id) %>%
+ mutate(wbtype = "resops")
+
+ if(nrow(wbareaout_coms) > 0){
+ wbout_coms <- rbind(wbout_coms, wbareaout_coms)
+ }
+
+ POIs <- POI_creation(select(wbout_coms, COMID, wb_id),
+ nhd, poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE) %>%
+ mutate(Type_WBOut = ifelse(is.na(Type_WBOut) & (!nexus | is.na(nexus)),
+ Type_wb_id, Type_WBOut)) %>%
+ select(-Type_wb_id) %>%
+ left_join(select(st_drop_geometry(resops_main), grand_id, resops_flowlcomid),
+ by = c("COMID" = "resops_flowlcomid")) %>%
+ mutate(Type_resops = ifelse(!is.na(grand_id) & (!nexus | is.na(nexus)),
+ grand_id, Type_resops)) %>%
+ select(-grand_id)
+ }
+
+ # If the return is not NA
+ if(inherits(WBs_VPU_areaHR, "list")){
+ # Attribute flowlines that intersect NHDARea and/or NHD HR waterbodies with
+ # waterbody COMIDs
+ # For NHDHR, two waterbodies might be back to back and share an intersecting
+ # flowline, this may cause problems below, so deal with this case
+ WBs_VPU_areaHR$nhd_wb_table <- WBs_VPU_areaHR$nhd_wb_table %>%
+ left_join(select(st_drop_geometry(resops_wb_other_sources),
+ resops_flowlcomid, member_comid, grand_id),
+ by = c("comid" = "resops_flowlcomid",
+ "wb_comid" = "member_comid")) %>%
+ group_by(comid) %>%
+ filter(case_when(n() == 2 ~ !is.na(grand_id),
+ TRUE ~ n() == 1)) %>%
+ ungroup()
+
+ nhd <- nhd %>%
+ left_join(distinct(WBs_VPU_areaHR$nhd_wb_table, comid, wb_id_hr = wb_id),
+ by = c("COMID" = "comid")) %>%
+ mutate(wb_id = ifelse(!is.na(wb_id_hr), wb_id_hr, wb_id)) %>%
+ select(-wb_id_hr)
+
+ # NHD flowlines within the HR waterbodies
+ nhd_WBs <- filter(nhd, wb_id %in%
+ filter(WBs_VPU_areaHR$nhd_wb_table, source == "NHDHR")$wb_id)
+
+ if(nrow(nhd_WBs) > 0){
+ # Create outlet events for splitting HR and NHDArea waterbodies
+ wb_outlet_events <- WB_event(WBs_VPU_areaHR, nhd_WBs, "outlet") %>%
+ st_compatibalize(., POIs) %>%
+ mutate(nexus = TRUE, Type_resops = 2)
+
+ POIs <- data.table::rbindlist(list(POIs,
+ select(wb_outlet_events, COMID, Type_WBOut = wb_id, Type_resops, nexus)), fill = TRUE) %>%
+ st_as_sf()
+ } else {
+ wb_outlet_events <- NA
+ }
+
+ WBs_VPU_areaHR$wb <- WBs_VPU_areaHR$wb %>%
+ sfheaders::sf_remove_holes(.) %>%
+ st_compatibalize(wb_poi_lst)
+
+ WBs_VPU_areaHR$wb <- nhdplusTools::st_compatibalize(
+ WBs_VPU_areaHR$wb, wb_table)
+
+ wb_table_filtered <- wb_table %>%
+ filter(!st_is_empty(wb_table))
+
+ # Append NHDArea and NHDHR waterbodies to waterbody layer
+ WBs_VPU <- data.table::rbindlist(list(wb_table_filtered, WBs_VPU_areaHR$wb),
+ fill = TRUE) %>%
+ st_as_sf()
+
+ st_geometry(WBs_VPU) <- st_make_valid(st_geometry(WBs_VPU))
+
+ return(list(POIs = POIs, events = wb_outlet_events, WBs = WBs_VPU,
+ nhd_wb_table = nhd))
+
+ } else {
+ return(list(POIs = POIs, events = NA, WBs = wb_table,
+ nhd_wb_table = nhd))
+ }
+}
+
+#' Creates Waterbody POIs, calls a few other functions
+#' @param nhd (sf data.frame) flowline data.frame
+#' @param wb_lyr (sf data.frame) waterbodies to create inlet pois from
+#' @param events (sf data.frame) of events that waterbody inlets can be pulled from
+#' @param nhdplus_area (sf data.frame) NHDPlus Area features
+#' @param crs (integer) CRS to use (epsg code)
+#' @param POIs (sf data.frame) rolling POI data frame
+#' @param nhdplushr_dir directory containing NHDPlusHR data
+#'
+#' @return (sf data.frame) dataframe of WB inlet POIs
+#'
+wbin_POIcreation <- function(flowline, wb_lyr, events, nhdplus_area, crs,
+ POIs, poi_name = "WBIn", nhdplushr_dir){
+
+ wbout_COMIDs <- filter(POIs, !is.na(Type_WBOut))
+ WBs_in_POIs <- filter(wb_lyr, wb_id %in% wbout_COMIDs$Type_WBOut)
+
+ # Unnest to get list of waterbody COMIDS (member_comid)
+ wb_table <- st_drop_geometry(wb_lyr) %>%
+ dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
+ tidyr::unnest(cols = member_comid) %>%
+ mutate(member_comid = as.integer(member_comid)) %>%
+ distinct()
+
+ # # Attribute flowline if waterbody exists for POIs
+ # nhd_wb <- nhd %>%
+ # left_join(distinct(wb_table, wb_id, member_comid),
+ # by = c("WBAREACOMI" = "member_comid"))
+
+ # Create waterbody inlet POIs
+ wbin_COMIDs <- filter(flowline, is.na(wb_id) &
+ DnHydroseq %in% filter(flowline, !is.na(wb_id))$Hydroseq) %>%
+ select(-wb_id) %>%
+ switchDiv(., flowline) %>%
+ inner_join(st_drop_geometry(filter(flowline, minNet == 1)) %>%
+ select(wb_id, Hydroseq), by = c("DnHydroseq" = "Hydroseq")) %>%
+ select(COMID, wb_id, minNet) %>%
+ group_by(COMID) %>%
+ # Ensure the inlets are on the network defined by confluence POIs
+ filter(minNet == 1)
+
+ # Headwater Waterbodies that may need the network extended through the inlet
+ need_wbin <- st_drop_geometry(wb_lyr) %>%
+ #dplyr::select(COMID)%>%
+ dplyr::filter(!wb_id %in% wbin_COMIDs$wb_id)
+
+ if(nrow(need_wbin)>0){
+
+ nhd_inlet <- mutate(flowline, WB = ifelse(wb_id > 0 & wb_id %in% need_wbin$wb_id, 1, 0))
+
+ missing_wbin_COMIDs <- filter(nhd_inlet, WB == 0,
+ DnHydroseq %in% filter(nhd_inlet, WB == 1)$Hydroseq) %>%
+ select(-wb_id) %>%
+ switchDiv(., nhd_inlet) %>%
+ inner_join(st_drop_geometry(filter(nhd_inlet, minNet == 1)) %>%
+ select(Hydroseq, wb_id),
+ by = c("DnHydroseq" = "Hydroseq")) %>%
+ select(COMID, wb_id) %>%
+ group_by(COMID) %>%
+ filter(row_number() == 1) %>%
+ ungroup()
+
+ missing_wbin_COMIDs <- missing_wbin_COMIDs %>%
+ left_join(select(st_drop_geometry(nhd_inlet), COMID, TotDASqKM)
+ , by = c("COMID")) %>%
+ group_by(COMID) %>%
+ slice(which.max(TotDASqKM))%>%
+ ungroup() %>%
+ select(-TotDASqKM)
+
+ if(nrow(missing_wbin_COMIDs) > 0){
+ wbin_COMIDs <- data.table::rbindlist(list(wbin_COMIDs,
+ missing_wbin_COMIDs),
+ fill = TRUE) %>%
+ select(COMID, wb_id)
+ }
+ }
+
+ wbin_POIs <- POI_creation(filter(st_drop_geometry(wbin_COMIDs), !COMID %in% wbout_COMIDs$COMID),
+ flowline, "WBIn")
+
+ # Get NHDArea and HR waterbodies
+ WBs_VPU_areaHR <- HR_Area_coms(flowline,
+ filter(wb_lyr, source == "HR ID AVAILABLE"),
+ nhdplus_area, crs, nhdplushr_dir)
+
+ if(is.list(WBs_VPU_areaHR)) {
+ nhd_WBs <- filter(flowline, minNet == 1,
+ COMID %in% WBs_VPU_areaHR$nhd_wb_table$comid,
+ AreaSqKM > 0)
+ } else {
+ nhd_WBs <- NA
+ }
+
+ if(is.data.frame(nhd_WBs)){
+
+ # Get the outlet events again
+ wb_outlet_events <- events %>%
+ filter(event_type == "outlet")
+
+ # Drive the inlet events
+ nhd_inlet <- filter(nhd_WBs, !COMID %in% wb_outlet_events$COMID)
+
+ if("12" %in% unique(flowline$VPUID)){
+ nhd_inlet <- rbind(nhd_inlet, filter(nhd_WBs, COMID == 1304709))
+ }
+
+ if (nrow(nhd_inlet) > 0){
+ # Get inlet events and bind with outlets
+ wb_inlet_events <- WB_event(WBs_VPU_areaHR, nhd_inlet, "inlet") %>%
+ mutate(nexus = TRUE) %>%
+ inner_join(select(st_drop_geometry(flowline), COMID, Hydroseq, ToMeas), by = "COMID")
+
+ # Determine which events are close enough to the end of an upstream flowline to just use that geometry for the POI
+ wbin_fl_upstream <- filter(flowline, DnHydroseq %in% filter(flowline, COMID %in% wb_inlet_events$COMID)$Hydroseq) %>%
+ group_by(DnHydroseq) %>%
+ filter(n() == 1) %>%
+ ungroup()
+
+ if(nrow(wbin_fl_upstream) > 0){
+
+ wb_inlet_POIs <- filter(wb_inlet_events, REACH_meas < 5 | as.integer(REACH_meas) == as.integer(ToMeas),
+ COMID %in% wbin_fl_upstream$toCOMID) %>%
+ inner_join(select(st_drop_geometry(wbin_fl_upstream), usCOMID = COMID, toCOMID), by = c("COMID" = "toCOMID")) %>%
+ mutate(dsCOMID = COMID, COMID = usCOMID)
+
+ if(nrow(wb_inlet_POIs) > 0) {
+ wbin_POIs <- bind_rows(wbin_POIs, POI_creation(select(st_drop_geometry(wb_inlet_POIs), dsCOMID,
+ Type_WBIn = POI_identifier),
+ flowline, "WBIn"))
+
+ wb_inlet_events <- filter(wb_inlet_events, !COMID %in% wb_inlet_POIs$dsCOMID)
+ }
+ }
+
+ wbin_POIs <- addType(wbin_POIs, POIs, "WBIn", nexus = TRUE)
+
+ if(nrow(wb_inlet_events) > 0){
+
+ wb_inlet_events <- st_compatibalize(wb_inlet_events, wbin_POIs)
+ wbin_POIs <- data.table::rbindlist(list(wbin_POIs,
+ select(wb_inlet_events, COMID,
+ Type_WBIn = POI_identifier, nexus)),
+ fill = TRUE) %>%
+ st_as_sf()
+ }
+
+ return(list(POIs = wbin_POIs, events = wb_inlet_events))
+ } else {
+ print("no waterbody inlets events")
+ wbin_POIs <- addType(wbin_POIs, POIs, "WBIn")
+ return(list(POIs = wbin_POIs, events = NA))
+ }
+ } else {
+ wbin_POIs <- addType(wbin_POIs, POIs, "WBIn")
+ return(list(POIs = wbin_POIs, events = NA))
+ }
+
+}
+
+### USEDIN wbout_POI_creaton and wbin_POIcreation
+#' Retrieves waterbodies from NHDArea layer or NHD Hi-Res for ResOpsUs
+#' locations if absent from NHD waterbody
+#' @param nhd (sf data.frame) Fowlines for given VPU
+#' @param WBs (sf data.frame) waterbodiess for discretization within VPU
+#' @param nhdplus_area (sf data.frame) NHDPlus Area features
+#' @param crs coordinate reference system to use for analysis
+#' @param nhdplushr_dir directory containing NHDPlusHR data
+#'
+#' @return (list) wbs - sf data frame for NHDArea and HR waterbodies
+#' wb_table - table of flowlines and outlet info for each
+#' feature in wb
+HR_Area_coms <- function(nhd, WBs, nhdplus_area, crs, nhdplushr_dir){
+
+ # Pull out rows for VPU that are NHDArea
+ nhd_area_resops <- WBs %>%
+ filter(resops_flowlcomid %in% nhd$COMID, source == "NHDAREA")
+
+ # Pull out rows for VPU that are NHD HR
+ nhd_hr_wb_resops <- WBs %>%
+ filter(member_comid != 65000300139130) %>% # R09, in Canada
+ filter(resops_flowlcomid %in% nhd$COMID, source == "HR ID AVAILABLE") %>%
+ st_drop_geometry()
+
+ # Get reachcodes for waterbody outlets, so we have an idea of which
+ # NHD HR 4-digit geodatabase we may need to retrieve
+ RC <- filter(nhd, COMID %in% nhd_hr_wb_resops$resops_flowlcomid)$REACHCODE
+
+ # If no NHDArea or HR waterbodies needed return NULL
+ if (nrow(nhd_area_resops) == 0 & nrow(nhd_hr_wb_resops) == 0){
+ return(NA)
+ }
+
+ # If NHDArea feature needed retrieve from National GDB
+ if (nrow(nhd_area_resops) > 0){
+ nhd_area_vpu <- nhdplus_area %>%
+ filter(COMID %in% nhd_area_resops$member_comid) %>%
+ mutate(source = "NHDv2Area")
+
+ wb <- st_transform(nhd_area_vpu, crs)
+ }
+
+ # If NHDHR feature needed
+ if (nrow(nhd_hr_wb_resops) > 0){
+ # HUC04 we need to download
+ huc04 <- substr(RC, 1, 4)
+
+ # Download NHD HR HUC04 if we dont' have it, other wise load and
+ # Bind NHDHR waterbodies into one layer
+ hr_wb <- do.call("rbind", lapply(unique(huc04), function(x){
+ print(x)
+ vpu <- unique(substr(x, 1, 2))
+ nhd_file <- list.files(nhdplushr_dir, pattern = paste0(".*",x,".*\\.gdb$"),
+ recursive = TRUE, full.names = TRUE,include.dirs = TRUE)
+
+ if(length(nhd_file) < 1) {
+ download_nhdplushr(nhdplushr_dir, unique(huc04))
+ }
+
+ nhd_file <- list.files(nhdplushr_dir, pattern = paste0(".*",x,".*\\.gdb$"),
+ recursive = TRUE, full.names = TRUE,include.dirs = TRUE)
+
+ if(length(nhd_file) != 1) {
+ stop("something wrong with nhdplushr file in ", x)
+ }
+
+ # Format to similar to NHDArea/Waterbody layers
+ read_sf(nhd_file, "NHDWaterbody")})) #%>%
+
+ # convert to lower case and designate new shape field
+ names(hr_wb) <- tolower(names(hr_wb))
+ st_geometry(hr_wb) <- "shape"
+
+ hr_wb <- filter(hr_wb, permanent_identifier %in% WBs$member_comid) %>%
+ rename(GNIS_NAME = gnis_name, GNIS_ID = gnis_id,
+ Permanent_Identifier = permanent_identifier, AREASQKM = areasqkm,
+ FTYPE = ftype, FCODE = fcode, FDATE = fdate,
+ REACHCODE = reachcode) %>%
+ #select(-c(permanent_identifier, visibilityfilter, vpuid)) %>%
+ st_zm(.) %>%
+ st_as_sf() %>%
+ mutate(source = "NHDHR",
+ wb_id = ifelse(!is.na(GNIS_ID), GNIS_ID, Permanent_Identifier)) %>%
+ st_transform(crs)
+
+ # Bind or create new object
+ if(exists("wb")){
+ hr_wb <- st_compatibalize(hr_wb, wb)
+
+ wb <- data.table::rbindlist(list(wb, hr_wb), fill = TRUE) %>%
+ st_as_sf()
+ } else {
+ wb <- hr_wb
+ }
+
+ }
+
+ # # get the outlt rows from the table
+ # resops_outlet <- read.csv("data/reservoir_data/ISTARF-CONUS.csv") %>%
+ # filter(WBAREACOMI %in% wb$COMID | HR_NHDPLUSID %in% wb$COMID)
+
+ # Clear out columns not needed
+ WBs_sub <- WBs %>%
+ select(-any_of(c("COMID", "GNIS_ID")))
+
+ WBs_fin <- st_drop_geometry(WBs_sub) %>%
+ mutate(member_comid = member_comid) %>%
+ inner_join(select(wb, Permanent_Identifier, GNIS_ID, GNIS_NAME2 = GNIS_NAME),
+ by = c("member_comid" = "Permanent_Identifier")) %>%
+ mutate(wb_id = ifelse(GNIS_ID %in% c(NA, " "), member_comid, GNIS_ID),
+ GNIS_NAME = ifelse(is.na(GNIS_NAME), GNIS_NAME2, GNIS_NAME)) %>%
+ select(-c(GNIS_ID, GNIS_NAME2)) %>%
+ st_as_sf()
+
+ # Create table of all flowlines that intersect the waterbody
+ nhd_wb <- st_intersects(st_transform(nhd, st_crs(wb)), wb)
+ comid <- nhd[lengths(nhd_wb) > 0,]$COMID
+ nhd_wb_all <- nhd_wb[lengths(nhd_wb) > 0] %>%
+ purrr::set_names(comid) %>%
+ stack() %>%
+ # Ind is the default name for the set_names
+ rename(comid = ind, nhd_wb = values) %>%
+ mutate(wb_comid = wb[nhd_wb,]$Permanent_Identifier,
+ outlet = ifelse(comid %in% WBs_fin$resops_flowlcomid, "outlet", NA),
+ comid = as.integer(as.character(comid))) %>%
+ #left_join(select(wb_table, DAM_ID, DAM_NAME, resops_FlowLcomid),
+ # by = c("comid" = "resops_FlowLcomid")) %>%
+ left_join(select(st_drop_geometry(wb), wb_id, Permanent_Identifier, GNIS_ID,
+ source),
+ by = c("wb_comid" = "Permanent_Identifier"))
+
+ return(list(nhd_wb_table = nhd_wb_all, wb = WBs_fin))
+}
+
+### USEDIN wbout_POI_creaton and wbin_POIcreation
+#' Creates wb inlet and outlet events for splitting in hyRefactor
+#' for waterbodies derived from NHDArea and NHDHR waterbodies
+#' @param WBs (sf data.frame) return from HR_Area_coms
+#' @param nhd_wb (sf data.frame) flowlines that intersect waterbodies
+#' @param type (character) whether to derive inlet or outlet points
+#'
+#' @return (sf data.frame) dataframe of WB inlet and outlet points to split
+#'
+WB_event <- function(WBs, nhd_wb, type){
+ # split into features and table
+ WBs_table <- WBs$nhd_wb_table
+ WBs_layer <- WBs$wb
+
+ if (type == "outlet"){
+ # get the outlet comid from the ResOps Table
+ outlet_fl <- filter(nhd_wb, COMID %in% filter(WBs_table, outlet == "outlet")$comid)
+
+ # Get the downstream flowline for continuity
+ ds_fl <- filter(nhd_wb, Hydroseq %in% outlet_fl$DnHydroseq,
+ LevelPathI %in% outlet_fl$LevelPathI) %>%
+ rbind(outlet_fl) %>%
+ arrange(desc(Hydroseq)) %>%
+ group_by(LevelPathI) %>%
+ # union together
+ summarize(do_union = TRUE) %>%
+ st_cast("LINESTRING")
+
+ WBs_HR <- filter(WBs_layer, source == "HR ID AVAILABLE")
+
+ # For NHD HR waterbody outlets its a bit more complicated
+ if (nrow(WBs_HR) > 0){
+ # Get the flowlines intersecting the HR waterbody and find one with the
+ # max DA
+ outlet_wb_int <- nhd_wb[lengths(st_intersects(st_transform(nhd_wb, st_crs(WBs_HR)),
+ WBs_HR)) > 0,] %>%
+ group_by(wb_id) %>%
+ filter(TotDASqKM == max(TotDASqKM)) %>%
+ ungroup()
+
+ # get the ds flo with the same levepath (JIC)
+ ds_fl <- filter(nhd_wb, DnHydroseq %in% outlet_wb_int$Hydroseq,
+ LevelPathI %in% outlet_wb_int$LevelPathI)
+
+ outlet_fl <- rbind(outlet_wb_int, ds_fl)
+
+ # Cast flowlines within NHDHR waterbody to point
+ WB_FL_pnts <- outlet_wb_int %>%
+ st_cast("POINT") %>%
+ group_by(wb_id) %>%
+ mutate(pnt_id = row_number()) %>%
+ ungroup()
+
+ outlet_pnts <- do.call("rbind", lapply(unique(WB_FL_pnts$wb_id), function(x){
+ fl <- filter(WB_FL_pnts, wb_id == x)
+ wb <- filter(WBs_HR, wb_id == x)
+
+ # Determine which points intersect waterbody
+ WB_outlet_pnts <- fl[lengths(st_intersects(fl, wb)) > 0,] %>%
+ st_drop_geometry() %>%
+ group_by(wb_id) %>%
+ mutate(within_wb_id = row_number()) %>%
+ filter(within_wb_id >= max(within_wb_id)) %>%
+ ungroup() %>%
+ select(wb_id, orig_pnt_id = pnt_id, within_wb_id)
+
+ # Deriv new linestring by concating points from most upstream point
+ # within waterbody to downstream so we can split at FL/waterbody
+ # nexus
+ outlet_FL <- fl %>%
+ inner_join(WB_outlet_pnts, by = "wb_id") %>%
+ select(wb_id, pnt_id, orig_pnt_id, within_wb_id) %>%
+ filter(pnt_id >= orig_pnt_id) %>%
+ group_by(wb_id) %>%
+ summarize(do_union = F) %>%
+ st_cast("LINESTRING") %>%
+ filter(wb_id %in% wb$wb_id)
+
+ outlet_pnt <- sf::st_intersection(outlet_FL, WBs_HR) %>%
+ st_cast("MULTIPOINT") %>%
+ st_cast("POINT") %>% # was point
+ group_by(wb_id) %>%
+ filter(row_number() == max(row_number(), na.rm = T)) %>%
+ ungroup() %>%
+ mutate(id = row_number()) %>%
+ filter(wb_id == wb_id.1)
+ }))
+
+ # Derive the events
+ if(exists("wb_events")){
+ hr_events <- get_flowline_index(st_transform(nhd_wb, st_crs(outlet_pnts)),
+ outlet_pnts) %>%
+ inner_join(select(st_drop_geometry(nhd_wb), COMID, wb_id), by = "COMID") %>%
+ filter(wb_id %in% WBs_HR$wb_id) %>%
+ mutate(event_type = type) %>%
+ cbind(select(outlet_pnts, geom)) %>%
+ st_as_sf() %>%
+ st_transform(st_crs(wb_events)) %>%
+ st_compatibalize(., wb_events)
+
+ wb_events <- rbind(wb_events, hr_events) %>%
+ distinct()
+ } else {
+ wb_events <- do.call("rbind", lapply(unique(outlet_pnts$wb_id), function(x){
+ outlet_pnt <- filter(outlet_pnts, wb_id == x)
+ get_flowline_index(nhd_wb, outlet_pnt)})) %>%
+ left_join(distinct(st_drop_geometry(outlet_pnts), resops_flowlcomid, wb_id),
+ by = c("COMID" = "resops_flowlcomid")) %>%
+ mutate(event_type = type) %>%
+ cbind(select(outlet_pnts, geom)) %>%
+ st_as_sf()
+ }
+
+ }
+
+ # For inlet points its alot easier for both NHDARea and NHDHR
+ } else {
+ start_pts <- get_node(nhd_wb, position = "start") %>%
+ cbind(st_drop_geometry(nhd_wb))
+
+ inlet_FL <- nhd_wb[lengths(st_intersects(
+ st_transform(start_pts, st_crs(WBs_layer)), WBs_layer)) == 0,] %>%
+ rbind(filter(nhd_wb, Hydroseq %in% .$DnHydroseq,
+ LevelPathI %in% .$LevelPathI)) %>%
+ arrange(desc(Hydroseq)) %>%
+ unique()
+
+ inlet_ls <- inlet_FL %>%
+ group_by(LevelPathI) %>%
+ st_cast("POINT") %>%
+ summarize(do_union = F) %>%
+ st_cast("LINESTRING") %>%
+ ungroup()
+
+ inlet_pnts_int <- sf::st_intersection(
+ st_transform(inlet_ls, st_crs(WBs_layer)), WBs_layer) #%>%
+ #st_cast("LINESTRING")
+
+ int_point <- inlet_pnts_int[st_geometry_type(inlet_pnts_int) %in% c("POINT"),]
+ if(nrow(int_point) > 0){
+ inlet_fl <- inlet_pnts_int[st_geometry_type(inlet_pnts_int) %in% c("LINESTRING", "MULTILINESTRING"),] %>%
+ st_cast("LINESTRING")
+ inlet_pnts_int <- rbind(int_point, inlet_fl)
+ }
+
+ inlet_pnts <- inlet_pnts_int %>%
+ group_by(LevelPathI) %>%
+ st_cast("POINT") %>%
+ mutate(id = row_number()) %>%
+ filter(id == min(id), !is.na(wb_id)) %>%
+ ungroup()
+
+ wb_events <- get_flowline_index(st_transform(nhd_wb, st_crs(inlet_pnts)),
+ inlet_pnts) %>%
+ inner_join(select(st_drop_geometry(nhd_wb), COMID, wb_id, LevelPathI), by = "COMID") %>%
+ mutate(event_type = type) %>%
+ inner_join(select(inlet_pnts, LevelPathI), by = "LevelPathI") %>%
+ #group_by(COMID, LEVELPATHI) %>%
+ mutate(nexus = T) %>%
+ rename(POI_identifier = wb_id) %>%
+ select(-c(id, offset)) %>%
+ st_as_sf()
+ }
+ return(wb_events)
+}
+
+### used as part of waterbody poi vreation in the workflow
+#' Collapses POIs us/ds of waterbody POIs
+#' @param POIs (sf data.frame) rolling POI data frame
+#' @param nhd (sf data.frame) nhd flowlines
+#' @param events (sf data.frame) waterbody events
+#' @param gages gages from gage selection
+#'
+#' @return (sf data.frame) dataframe of wb inlet POIs collapsed
+wb_poi_collapse <- function(POIs, nhd, events, gages){
+ gage_dist_node <- function(x, wb_ds_ds, gage_add, events){
+ print (x)
+ wb_out_fl <- distinct(filter(wb_ds_ds, COMID == x))
+ gage_ds <- filter(wb_ds_ds, Hydroseq %in% wb_out_fl$Hydroseq |
+ Hydroseq %in% wb_out_fl$DnHydroseq)
+
+ gage_reach <- gage_ds %>%
+ group_by(REACHCODE) %>%
+ summarize(do_union = TRUE,
+ total_length = sum(LENGTHKM))
+
+ #print(nrow(gage_reach))
+ gage_event <- filter(gage_add, COMID %in% gage_ds$COMID) %>%
+ filter(reach_meas == min(reach_meas))
+ wb_event <- filter(events, COMID == x, event_type == "outlet") %>%
+ unique()
+
+ if(nrow(gage_reach) == 0){
+ print("no gages")
+ }
+
+ if(nrow(gage_event) == 0){
+ return("no events")
+ } else if(gage_event$COMID != wb_out_fl$COMID) {
+ gage_reach <- gage_reach %>%
+ filter(REACHCODE == unique(gage_event$reachcode)) %>%
+ mutate(gage_dist = ifelse(gage_event$nexus == TRUE,
+ total_length * (1 - (gage_event$reach_meas/100)),
+ total_length)) %>%
+ mutate(gage_comid = gage_event$COMID,
+ wbout_comid = x)
+ } else if(gage_event$COMID == wb_out_fl$COMID){
+ if(nrow(wb_event) >0){
+ wb_out_meas <- min(wb_event$REACH_meas)
+ wb_RC <- wb_event$REACHCODE
+ } else {
+ wb_out_meas <- min(wb_out_fl$FromMeas)
+ wb_RC <- wb_out_fl$REACHCODE
+ }
+
+ # gage reach
+ gage_reach <- gage_reach %>%
+ filter(REACHCODE == gage_event$reachcode) %>%
+ mutate(gage_dist = total_length * (1 - (gage_event$reach_meas/100)))
+
+ # wb info
+ wb_reach <- gage_reach %>%
+ filter(REACHCODE == unique(wb_RC)) %>%
+ mutate(wb_dist = total_length * (1 - (wb_out_meas /100)))
+
+ gage_reach <- gage_reach %>%
+ mutate(gage_dist = abs(wb_reach$wb_dist - gage_dist),
+ gage_comid = gage_event$COMID,
+ wbout_comid = x)
+ }
+ }
+
+ # Previously identified streamgages within Gage_Selection.Rmd
+ streamgages_VPU <- gages %>%
+ rename(COMID = comid) %>%
+ filter(COMID %in% nhd$COMID) %>%
+ switchDiv(., nhd)
+
+ # get waterbody outlets
+ wb_out <- filter(POIs, !is.na(Type_WBOut), is.na(Type_Gages))
+
+ wb_out_nexus <- filter(wb_out, nexus)
+ wb_out_nhd <- filter(nhd, COMID %in% wb_out$COMID)
+ wb_ds_ds <- wb_out_nhd %>%
+ rbind(filter(nhd, LevelPathI %in% .$LevelPathI & Hydroseq %in% .$DnHydroseq))
+
+ # get gages
+ gage_wb <- filter(POIs, !is.na(Type_Gages) & is.na(Type_WBOut)) #%>%
+ # filter(COMID %in% wb_ds_ds$COMID)
+ #gage_nhd <- filter(nhd, COMID %in% gage_wb$COMID)
+ #gage_node <- filter(gage_wb, nexus == FALSE)
+ #gage_nexus <- filter(gage_wb, nexus == TRUE)
+
+ gage_add <- filter(streamgages_VPU, site_no %in% gage_wb$Type_Gages) %>%
+ select(COMID, reachcode, reach_meas, site_no) %>%
+ inner_join(select(st_drop_geometry(gage_wb), site_no = Type_Gages, nexus),
+ by = "site_no") %>%
+ distinct()
+
+ # 8693865
+ output <- lapply(wb_out$COMID,
+ gage_dist_node, wb_ds_ds, gage_add, events)
+ output_length <- output[lengths(output) > 1]
+
+ if(length(output_length) == 0){
+ return(list(POIs = POIs, events_ret = NA))
+ }
+
+ output_full <- do.call("rbind", output[lengths(output) > 1]) %>%
+ filter(gage_dist < 1) %>%
+ left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_WB = TotDASqKM),
+ by = c("wbout_comid" = "COMID")) %>%
+ left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_gage = TotDASqKM),
+ by = c("gage_comid" = "COMID")) %>%
+ mutate(DAR = TotDASqKM_WB / TotDASqKM_gage) %>%
+ filter(gage_dist < 1, DAR > .975) %>%
+ st_drop_geometry()
+
+ gage_POI <- filter(POIs, COMID %in% output_full$gage_comid) %>%
+ select(COMID, Type_HUC12_ds = Type_HUC12, Type_Gages_ds = Type_Gages,
+ Type_TE_ds = Type_TE, nexus) %>%
+ st_drop_geometry() %>%
+ group_by(COMID) %>%
+ summarise(Type_HUC12_ds = last(na.omit(Type_HUC12_ds)),
+ Type_Gages_ds = last(na.omit(Type_Gages_ds)),
+ Type_TE_ds = last(na.omit(Type_TE_ds)),
+ nexus = last(na.omit(nexus)))
+
+ WB_POI <- filter(POIs, COMID %in% output_full$wbout_comid, !is.na(Type_WBOut)) %>%
+ inner_join(select(output_full, gage_comid, wbout_comid), by = c("COMID" = "wbout_comid")) %>%
+ inner_join(select(gage_POI, -nexus), by = c("gage_comid" = "COMID")) %>%
+ mutate(Type_HUC12 = ifelse(!is.na(Type_HUC12_ds), Type_HUC12_ds, Type_HUC12),
+ Type_Gages = ifelse(!is.na(Type_Gages_ds), Type_Gages_ds, Type_Gages),
+ Type_TE = ifelse(!is.na(Type_TE_ds), Type_TE_ds, Type_TE)) %>%
+ select(-c(Type_HUC12_ds, Type_Gages_ds, Type_TE_ds))
+
+ POIs_fin <- filter(POIs, !COMID %in% c(WB_POI$COMID, WB_POI$gage_comid)) %>%
+ rbind(select(WB_POI, -gage_comid))
+
+ if(any(gage_POI$nexus == TRUE)){
+ gage_events <- filter(gage_POI, nexus == TRUE)
+ events <- filter(events, !POI_identifier %in% gage_events$Type_Gages_ds)
+ }
+
+
+ return(list(POIs = POIs_fin, events_ret = events))
+}
+
+#' create abstraction(?) and removal event points of interest
+#' @param ar_data abstraction and removal data from USGS data release
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+create_ar_event_pois <- function(POIs, ar_data, flowline, poi_name = "AR") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ ar_events <- ar_data %>%
+ filter(fromComid > 0 | ToComid > 0) %>%
+ select(COMID = NHDComid, AREventID) %>%
+ filter(COMID %in% flowline$COMID)
+
+ if(nrow(ar_events) > 0){
+ # AR POIs
+ POIs <- POI_creation(ar_events, flowline, poi_name) %>%
+ addType(., POIs, "AR", nexus = TRUE)
+
+ }
+
+ list(POIs = POIs, vpu = vpu)
+}
+
+#' create terminal pois
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+#' @param min_da_km_terminal minimum drainage area to include a network
+#' @param poi_name name for poi set
+create_terminal_pois <- function(POIs, flowline, min_da_km_terminal, poi_name = "Term") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ term_paths <- filter(st_drop_geometry(flowline),
+ Hydroseq %in% filter(flowline, COMID %in% POIs$COMID)$TerminalPa)
+
+ # Non-POI levelpath terminal pois, but meet size criteria
+ terminal_POIs <- st_drop_geometry(flowline) %>%
+ filter(Hydroseq == TerminalPa | (toCOMID == 0 | is.na(toCOMID) | !toCOMID %in% COMID)) %>%
+ filter(!COMID %in% term_paths$COMID, TotDASqKM >= min_da_km_terminal) %>%
+ bind_rows(term_paths) %>%
+ # Use level path identifier as Type ID
+ select(COMID, LevelPathI)
+
+ POIs <- POI_creation(terminal_POIs, flowline, poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+
+ list(POIs = POIs, vpu = vpu)
+}
+
+#' create confluence pois
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+create_confluence_pois <- function(POIs, flowline, poi_name = "Conf") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # Navigate upstream from each POI and determine minimally-sufficient network between current POI sets
+ up_net <- unique(unlist(lapply(unique(POIs$COMID),
+ \(x, nhdDF) get_UM(nhdDF, x),
+ nhdDF = flowline)))
+
+ finalNet <- unique(NetworkConnection(up_net, st_drop_geometry(flowline)))
+
+ # Subset NHDPlusV2 flowlines to navigation results and write to shapefile
+ flowline <- mutate(flowline, minNet = ifelse(COMID %in% finalNet, 1, 0))
+
+ # Create new confluence POIs
+ conf_COMIDs <- st_drop_geometry(filter(flowline, minNet == 1)) %>%
+ # Downstream hydrosequence of 0 indicates
+ # the flowline is terminating or
+ # leaving the domain, so they
+ # are excluded from this process
+ filter(DnHydroseq > 0) %>%
+ group_by(DnHydroseq) %>%
+ filter(n()> 1) %>%
+ mutate(Type_Conf = LevelPathI) %>%
+ ungroup() %>%
+ select(COMID, Type_Conf)
+
+ POIs <- POI_creation(conf_COMIDs, filter(flowline, minNet == 1), poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+
+ list(POIs = POIs, updated_flowline = flowline, vpu = vpu)
+}
+
+#' create waterbody inlet pois
+#' @param POIs POIs from previous step
+#' @param wb_lyr waterbodies to create inlet pois from
+#' @param events complete layer of events prior to creating waterbody inlets
+#' @param flowline flowlines to attach pois to
+#' @param nhdplus_area (sf data.frame) NHDPlus Area features
+#' @param proj_crs projected crs for overall project
+#' @param poi_name name for poi set
+#' @param nhdplushr_dir directory containing NHDPlusHR data
+create_wb_inlet_pois <- function(POIs, wb_lyr, events,
+ flowline, gages, nhdplus_area,
+ proj_crs, poi_name = "WBIn", nhdplushr_dir) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ wb_layers <- wbin_POIcreation(filter(flowline, minNet == 1), wb_lyr, events,
+ nhdplus_area, proj_crs, POIs,
+ poi_name, nhdplushr_dir)
+
+ wb_in_col <- wb_inlet_collapse(wb_layers$POIs, flowline, events, gages)
+
+ wb_inlet_events <- NULL
+
+ if(!all(is.na(wb_layers$events))) {
+ wb_inlet_events <- wb_layers$events %>%
+ select(COMID, REACHCODE, REACH_meas, POI_identifier,
+ event_type, nexus)
+
+ events <- rbind(events, st_compatibalize(wb_inlet_events, events))
+ }
+
+ list(POIs = wb_in_col$POIs, events = events, vpu = vpu)
+}
+
+### used as part of waterbody poi creation in the workflow
+#' collapses close upstream gages with wb inlet events.
+#' @param POIs (sf data.frame) rolling POI data frame
+#' @param nhd (sf data.frame) nhd flowlines
+#' @param events (list) waterbody inlet events
+#'
+#' @return (sf data.frame) dataframe of gage POIs
+#'
+wb_inlet_collapse <- function(POIs, nhd, events, gages){
+ gage_dist_node <- function(x, wb_ds_ds, gage_add, events){
+ # print (x)
+ wb_in_fl <- filter(wb_ds_ds, COMID == x)
+ gage_ds <- filter(wb_ds_ds, Hydroseq %in% wb_in_fl$Hydroseq |
+ Hydroseq %in% wb_in_fl$DnHydroseq) %>%
+ filter(TotDASqKM == max(TotDASqKM))
+
+ gage_reach <- gage_ds %>%
+ group_by(REACHCODE) %>%
+ summarize(do_union = TRUE,
+ total_length = sum(LENGTHKM))
+
+ #print(nrow(gage_reach))
+ gage_event <- filter(gage_add, COMID %in% gage_ds$COMID)
+ wb_event <- filter(events, COMID == x, event_type == "inlet") %>%
+ unique()
+
+ if(nrow(gage_reach) == 0){
+ print("no gage reaches")
+ }
+
+ if(nrow(gage_event) == 0){
+ return("No gage events")
+ } else if(gage_event$COMID != wb_in_fl$COMID) {
+ gage_reach <- gage_reach %>%
+ filter(REACHCODE == gage_event$reachcode) %>%
+ mutate(gage_dist = ifelse(gage_event$nexus == TRUE,
+ total_length * (1 - (gage_event$reach_meas/100)),
+ total_length)) %>%
+ mutate(gage_comid = gage_event$COMID,
+ wbin_comid = x)
+ } else if(gage_event$COMID == wb_in_fl$COMID){
+ if(nrow(wb_event) >0){
+ wb_in_meas <- wb_event$REACH_meas
+ wb_RC <- wb_event$REACHCODE
+ } else {
+ wb_out_meas <- wb_in_fl$FromMeas
+ wb_RC <- wb_in_fl$REACHCODE
+ }
+
+ # gage reach
+ gage_reach <- gage_reach %>%
+ filter(REACHCODE == gage_event$reachcode) %>%
+ mutate(gage_dist = total_length * (1 - (gage_event$reach_meas/100)))
+
+ # wb info
+ wb_reach <- gage_reach %>%
+ filter(REACHCODE == wb_RC) %>%
+ mutate(wb_dist = total_length * (1 - (wb_out_meas /100)))
+
+ gage_reach <- gage_reach %>%
+ mutate(gage_dist = abs(wb_reach$wb_dist - gage_dist),
+ gage_comid = gage_event$COMID,
+ wbin_comid = x)
+ }
+ }
+
+ #events <- read_sf(temp_gpkg, split_layer) %>%
+ # rbind(st_compatibalize(wb_,.))
+
+ # Previously identified streamgages within Gage_Selection.Rmd
+ streamgages_VPU <- gages %>%
+ rename(COMID = comid) %>%
+ filter(COMID %in% nhd$COMID) %>%
+ #st_drop_geometry() %>%
+ switchDiv(., nhd)
+
+ # get waterbody outlets
+ wb_in <- filter(POIs, !is.na(Type_WBIn), is.na(Type_Gages))
+
+ wb_in_nexus <- filter(wb_in, nexus == TRUE)
+ wb_in_nhd <- filter(nhd, COMID %in% wb_in$COMID)
+ wb_ds_ds <- wb_in_nhd %>%
+ rbind(filter(nhd, LevelPathI %in% .$LevelPathI & DnHydroseq %in% .$Hydroseq)) %>%
+ distinct()
+
+ # get gages
+ gage_wb <- filter(POIs, !is.na(Type_Gages) & is.na(Type_WBIn)) #%>%
+ # filter(COMID %in% wb_ds_ds$COMID)
+ #gage_nhd <- filter(nhd, COMID %in% gage_wb$COMID)
+ #gage_node <- filter(gage_wb, nexus == FALSE)
+ #gage_nexus <- filter(gage_wb, nexus == TRUE)
+
+ gage_add <- filter(streamgages_VPU, site_no %in% gage_wb$Type_Gages) %>%
+ select(COMID, reachcode, reach_meas, site_no) %>%
+ inner_join(select(st_drop_geometry(gage_wb), site_no = Type_Gages, nexus),
+ by = "site_no") %>%
+ filter(!nexus)
+
+ output <- lapply(wb_in$COMID,
+ gage_dist_node, wb_ds_ds, gage_add, events)
+
+ output_full <- do.call("rbind", output[lengths(output) > 1])
+
+ if(!is.null(output_full)){
+ output_full <- output_full %>%
+ filter(gage_dist < 1) %>%
+ left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_WB = TotDASqKM),
+ by = c("wbin_comid" = "COMID")) %>%
+ left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_gage = TotDASqKM),
+ by = c("gage_comid" = "COMID")) %>%
+ mutate(DAR = TotDASqKM_gage / TotDASqKM_WB) %>%
+ filter(gage_dist < 1, DAR > .975) %>%
+ st_drop_geometry()
+
+ gage_POI <- filter(POIs, COMID %in% output_full$gage_comid) %>%
+ select(COMID, Type_HUC12_ds = Type_HUC12, Type_Gages_ds = Type_Gages,
+ Type_TE_ds = Type_TE, Type_Term_ds = Type_Term, nexus) %>%
+ st_drop_geometry() %>%
+ group_by(COMID) %>%
+ summarise(Type_HUC12_ds = last(na.omit(Type_HUC12_ds)),
+ Type_Gages_ds = last(na.omit(Type_Gages_ds)),
+ Type_Term_ds = last(na.omit(Type_Term_ds)),
+ Type_TE_ds = last(na.omit(Type_TE_ds)),
+ nexus = last(na.omit(nexus)))
+
+ WB_POI <- filter(POIs, COMID %in% output_full$wbin_comid, !is.na(Type_WBIn)) %>%
+ left_join(select(output_full, gage_comid, wbin_comid), by = c("COMID" = "wbin_comid")) %>%
+ left_join(select(gage_POI, -nexus), by = c("gage_comid" = "COMID")) %>%
+ mutate(Type_HUC12 = ifelse(!is.na(Type_HUC12_ds), Type_HUC12_ds, Type_HUC12),
+ Type_Gages = ifelse(!is.na(Type_Gages_ds), Type_Gages_ds, Type_Gages),
+ Type_TE = ifelse(!is.na(Type_TE_ds), Type_TE_ds, Type_TE),
+ Type_Term = ifelse(!is.na(Type_Term_ds), Type_Term_ds, Type_Term)) %>%
+ select(-c(Type_HUC12_ds, Type_Gages_ds, Type_TE_ds, Type_Term_ds))
+
+ POIs_fin <- filter(POIs, !COMID %in% c(WB_POI$COMID, WB_POI$gage_comid)) %>%
+ rbind(select(WB_POI, -gage_comid))
+
+ if(any(gage_POI$nexus == TRUE)){
+ gage_events <- filter(gage_POI, nexus == TRUE)
+ events <- filter(events, !POI_identifier %in% gage_events$Type_Gages_ds)
+ }
+ return(list(POIs = POIs_fin, events_ret = events))
+ } else {
+ print ("no points collapse")
+ return(list(POIs = POIs, events_ret = NA))
+ }
+}
+
+#' @param POIs POIs from previous step
+#' @param nid_points national inventory of dams data
+#' @param flowline flowlines to attach pois to
+#' @param poi_name name for poi set
+create_nid_pois <- function(POIs, nid_points, flowline, poi_name) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # Read in NID shapefile
+ NID_COMIDs <- nid_points %>%
+ st_drop_geometry() %>%
+ filter(EROM != 0, FlowLcomid %in% filter(flowline, dend ==1)$COMID) %>%
+ rename(COMID = FlowLcomid) %>%
+ switchDiv(., flowline) %>%
+ group_by(COMID) %>%
+ summarize(Type_NID = paste0(unique(NIDID), collapse = " "))
+
+ # Derive other NID POIs
+ POIs <- POI_creation(NID_COMIDs, flowline, poi_name) %>%
+ addType(., POIs, poi_name, nexus = FALSE, bind = FALSE)
+
+ list(POIs = POIs, vpu = vpu)
+}
+
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+#' @param all_nhdplus_attributes original attributes from nhdplusv2
+#' @param min_da_km_hw minimum drainage area for creation of a headwater poi
+#' @param poi_name name for poi set
+create_headwater_pois <- function(POIs, flowline,
+ all_nhdplus_attributes,
+ min_da_km_hw, poi_name = "DA") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # derive incremental segments from POIs
+ inc_segs <- make_incremental_segments(flowline,
+ filter(st_drop_geometry(flowline),
+ COMID %in% POIs$COMID)) %>%
+ # bring over VAA data
+ inner_join(select(all_nhdplus_attributes, COMID,
+ DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO,
+ MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE, StartFlag,
+ AreaSqKM, TotDASqKM), by = "COMID")
+
+ hw_segs <- inc_segs %>%
+ group_by(POI_ID) %>%
+ filter(any(StartFlag == 1)) %>%
+ filter(any(TotDASqKM > max_da_km_hw)) %>%
+ ungroup()
+
+ att_group <- function(a, athres) {
+ #cumsum <- 0
+ group <- 1
+ result <- numeric()
+ for (i in 1:length(a)) {
+ #cumsum <- cumsum + a[i]
+ tot_DA <- a[i]
+ if (tot_DA > athres) {
+ group <- group + 1
+ athres <- athres + athres
+ }
+ result = c(result, group)
+ }
+ return (result)
+ }
+
+ #TODO Add magic numbers to config file
+ hw_DA_splits <- hw_segs %>%
+ st_drop_geometry() %>%
+ #filter(.data$ID %in% cat$ID) %>%
+ group_by(POI_ID) %>%
+ arrange(-Hydroseq) %>%
+ mutate(ind = att_group(TotDASqKM, min_da_km_hw)) %>%
+ ungroup() %>%
+ group_by(POI_ID, ind) %>%
+ mutate(total_length = cumsum(LENGTHKM)) %>%
+ ungroup() %>%
+ group_by(POI_ID, ind) %>%
+ mutate(set = cur_group_id()) %>%
+ filter(TotDASqKM == max(TotDASqKM) &
+ total_length > 5) %>%
+ mutate(da_class = paste(POI_ID, ind, sep = "_")) %>%
+ ungroup() %>%
+ select(-ind) %>%
+ filter(!COMID %in% POIs$COMID)
+
+ if(nrow(hw_DA_splits) > 0) {
+ POIs <- POI_creation(select(hw_DA_splits, COMID, da_class),
+ filter(flowline, poi == 1), poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+ }
+
+ list(POIs = POIs, vpu = vpu)
+
+}
+
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+#' @param all_nhdplus_attributes original attributes from nhdplusv2
+#' @param poi_name name for poi set
+create_elevation_break_pois <- function(POIs, flowline, all_nhdplus_attributes,
+ poi_name = "elev") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ inc_segs <- make_incremental_segments(filter(flowline, minNet == 1),
+ filter(st_drop_geometry(flowline),
+ COMID %in% POIs$COMID)) %>%
+ # bring over VAA data
+ inner_join(select(all_nhdplus_attributes, COMID,
+ DnHydroseq, VA_MA, TOTMA, LENGTHKM, MAXELEVSMO,
+ MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE, StartFlag,
+ AreaSqKM, TotDASqKM), by = "COMID")
+
+ elev_fp <- inc_segs %>%
+ group_by(POI_ID) %>%
+ arrange(Hydroseq) %>%
+ # Get elevation info
+ mutate(MAXELEVSMO = na_if(MAXELEVSMO, -9998), MINELEVSMO = na_if(MINELEVSMO, -9998),
+ elev_diff_seg = max(MAXELEVSMO) - min(MINELEVSMO),
+ total_length = cumsum(LENGTHKM)) %>%
+ filter((max(MINELEVSMO) - min(MINELEVSMO)) > elev_diff) %>%
+ mutate(inc_elev_diff = c(MINELEVSMO[1], (MINELEVSMO - lag(MINELEVSMO))[-1])) %>%
+ mutate(inc_elev_diff = ifelse(inc_elev_diff == MINELEVSMO, 0, inc_elev_diff)) %>%
+ ungroup()
+
+ if(nrow(elev_fp) > 0){
+ #TODO Add magic numbers to config file
+ hw_elev_splits <- elev_fp %>%
+ st_drop_geometry() %>%
+ group_by(POI_ID) %>%
+ arrange(-Hydroseq) %>%
+ mutate(ind = cs_group(inc_elev_diff, elev_diff/2)) %>%
+ ungroup() %>%
+ group_by(POI_ID, ind) %>%
+ filter(TotDASqKM == max(TotDASqKM) &
+ total_length > 5) %>%
+ mutate(elev_class = paste(POI_ID, ind, sep = "_")) %>%
+ ungroup() %>%
+ select(-ind) %>%
+ filter(!COMID %in% POIs$COMID)
+
+ if(nrow(hw_elev_splits) > 0) {
+ POIs <- POI_creation(select(hw_elev_splits, COMID, elev_class),
+ filter(flowline, poi == 1),
+ poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+ }
+ }
+
+ list(POIs = POIs, vpu = vpu)
+}
+
+cs_group <- function(a, athres) {
+ cumsum <- 0
+ group <- 1
+ result <- numeric()
+ for (i in 1:length(a)) {
+ cumsum <- cumsum + a[i]
+ if (cumsum > athres) {
+ group <- group + 1
+ cumsum <- a[i]
+ }
+ result = c(result, group)
+ }
+ return (result)
+}
+
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+#' @param all_nhdplus_attributes original attributes from nhdplusv2
+#' @param poi_name name for poi set
+create_time_of_travel_pois <- function(POIs, flowline, all_nhdplus_attributes, poi_name = "Travel") {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ # derive incremental segments from POIs
+ inc_segs <- make_incremental_segments(flowline,
+ filter(st_drop_geometry(flowline),
+ COMID %in% POIs$COMID,
+ COMID %in% flowline$COMID)) %>%
+ # bring over VAA data
+ inner_join(select(all_nhdplus_attributes, COMID, DnHydroseq, VA_MA, TOTMA, LENGTHKM,
+ MAXELEVSMO, MINELEVSMO, WBAREACOMI, WBAreaType, FTYPE,
+ AreaSqKM, TotDASqKM), by = "COMID")
+
+ # TT POIs
+ tt_pois_split <- inc_segs %>%
+ arrange(-Hydroseq) %>%
+ # Should we substitute with a very small value
+ mutate(VA_MA = ifelse(VA_MA < 0, NA, VA_MA)) %>%
+ mutate(FL_tt_hrs = (LENGTHKM * ft_per_km)/ VA_MA / s_per_hr ) %>%
+ group_by(POI_ID) %>%
+ filter(sum(FL_tt_hrs) > travt_diff, max(TotDASqKM) > max_elev_TT_DA) %>%
+ mutate(cum_tt = cumsum(FL_tt_hrs),
+ hrs = sum(FL_tt_hrs))
+
+ #TODO Add magic numbers to config file
+ tt_splits <- tt_pois_split %>%
+ st_drop_geometry() %>%
+ group_by(POI_ID) %>%
+ arrange(-Hydroseq) %>%
+ mutate(ind = cs_group(FL_tt_hrs, travt_diff * 0.75)) %>%
+ ungroup() %>%
+ group_by(POI_ID, ind) %>%
+ filter(TotDASqKM == max(TotDASqKM)) %>%
+ mutate(tt_class = paste(POI_ID, ind, sep = "_")) %>%
+ ungroup() %>%
+ select(-ind) %>%
+ filter(!COMID %in% POIs$COMID)
+
+ if(nrow(tt_splits) > 0) {
+ POIs <- POI_creation(select(tt_splits, COMID, tt_class),
+ filter(flowline, poi == 1), poi_name) %>%
+ addType(., POIs, poi_name, nexus = TRUE)
+ }
+
+ list(POIs = POIs, vpu = vpu)
+
+}
+
+#' create final POIs
+#' @param POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+create_final_pois <- function(POIs, flowline) {
+
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ unCon_POIs <- filter(POIs, COMID %in% filter(flowline, AreaSqKM == 0)$COMID)
+
+ xWalk <- NULL
+ new_POIs <- NULL
+
+ # If any POIs happened to fall on flowlines w/o catchment
+ if (nrow(unCon_POIs) > 0){
+ # For confluence POIs falling on Flowlines w/o catchments, derive upstream valid flowline,
+ poi_fix <- DS_poiFix(POIs, filter(flowline, minNet == 1))
+ new_POIs <- st_compatibalize(poi_fix$new_POIs, POIs)
+ xWalk <- poi_fix$xWalk
+
+ # POIs that didn't need to be moved
+ POIs_fixed <- filter(POIs, nexus == TRUE |
+ !COMID %in% c(poi_fix$xWalk$oldPOI, poi_fix$xWalk$COMID))
+ # bind together
+ final_POIs <- bind_rows(POIs_fixed, new_POIs) %>%
+ mutate(Type_Term = ifelse(nexus == 1, NA, Type_Term)) %>%
+ select(-dplyr::any_of(c("ID")))
+
+ } else {
+ # If no fixes designate as NA
+ poi_fix <- NA
+
+ POIs$nexus <- as.integer(POIs$nexus)
+
+ # if a POI will be a nexus, it can not be terminal.
+ final_POIs <- mutate(POIs, Type_Term = ifelse(nexus == 1, NA, Type_Term))
+
+ }
+
+ list(POIs = final_POIs, xwalk = xWalk, new_POIs = new_POIs,
+ unCon_POIs = unCon_POIs, vpu = vpu)
+}
+
+### used as a cleanup step in POI workflow
+#' Moves POI Upstream or downstream if it falls on COMID
+# of flowline with no corresponding catchment
+#' @param POIs_wgeom (sf data.frame) POIs
+#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
+#'
+#' @return (sf data.frame) data.frame of POIs with new COMID associated
+DS_poiFix <- function(POIs_wgeom, nhd){
+ nhd <- distinct(nhd)
+ POIs <- st_drop_geometry(POIs_wgeom) %>%
+ arrange(COMID) %>%
+ filter(nexus == FALSE)
+
+ # DF of downstream segment
+ tocomDF <- select(st_drop_geometry(nhd), COMID, Hydroseq, TotDASqKM,
+ DnHydroseq, WBAREACOMI) %>%
+ inner_join(select(st_drop_geometry(nhd), COMID_ds = COMID, Hydroseq,
+ WBAREACOMI_down = WBAREACOMI, totda_ds = TotDASqKM),
+ by = c("DnHydroseq" = "Hydroseq")) %>%
+ inner_join(select(st_drop_geometry(nhd), COMID_us = COMID, DnHydroseq,
+ WBAREACOMI_up = WBAREACOMI, totda_us = TotDASqKM),
+ by = c("Hydroseq" = "DnHydroseq"))
+
+ # Find segments with POIs where there is no corresponding catchment that are not terminal
+ unCon_fl <- filter(nhd, COMID %in% POIs$COMID, AreaSqKM == 0)# & Hydroseq != TerminalPa)
+ unCon_POIs <- filter(POIs, COMID %in% unCon_fl$COMID)
+
+ # Get specific fixes for waterbody inlets and outlets
+ wbout <- filter(unCon_POIs, !is.na(Type_WBOut)) %>%
+ inner_join(tocomDF, by = "COMID") %>%
+ mutate(nonrefactor = ifelse(WBAREACOMI %in% WBAREACOMI_up, COMID_ds, 0),
+ new_POI = COMID_us)
+
+ wb_pois <- filter(unCon_POIs, !is.na(Type_WBIn)) %>%
+ inner_join(tocomDF, by = "COMID") %>%
+ mutate(nonrefactor = ifelse(WBAREACOMI < 0, COMID_ds, 0),
+ new_POI = COMID_us) %>%
+ rbind(wbout) %>%
+ select(-c(nexus, Hydroseq, TotDASqKM, DnHydroseq, WBAREACOMI, COMID_ds,
+ WBAREACOMI_down, totda_ds, COMID_us, WBAREACOMI_up, totda_us)) %>%
+ rename(COMID = new_POI, oldPOI = COMID)
+
+ # The rest can be resolved with drainage are ratio
+ unCon_POIs <- filter(unCon_POIs, !COMID %in% wb_pois$oldPOI)
+
+ poi_fix <- as.data.frame(do.call("rbind", lapply(unCon_POIs$COMID, movePOI_NA_DA, st_drop_geometry(nhd)))) %>%
+ inner_join(POIs, by = c("oldPOI" = "COMID")) %>%
+ inner_join(select(st_drop_geometry(nhd), COMID), by = c("oldPOI" = "COMID")) %>%
+ select(-c(AreaSqKM, DnHydroseq, nexus, TotDASqKM)) %>%
+ distinct() %>%
+ bind_rows(wb_pois)
+
+ # Fold in new POIs with existing POIs so all the "Type" attribution will carry over
+ # using the minimum will ensure correct downstream hydrosequence gets carried over
+ poi_orig <- filter(POIs, COMID %in% poi_fix$COMID) %>%
+ bind_rows(poi_fix) %>%
+ select(-oldPOI)
+
+ list_df <- dplyr::group_by(poi_orig, COMID) |>
+ group_split()
+
+ compact <- function(l) {
+ if(nrow(l) == 1) return(as.data.frame(l))
+ lapply(names(l), \(x) {
+ out <- unique(l[[x]][!is.na(l[[x]])])
+ if(!length(out)) NA
+ else if(length(out) == 1) out
+ else {
+ cat(paste("duplicate id for", unique(l$COMID),
+ "column", x,
+ "values", paste(out, collapse = ", "),
+ "using", out[1]), file = "POI-issues.log")
+ out[1]
+ }
+ }) |>
+ setNames(names(l)) |>
+ as.data.frame()
+ }
+
+ poi_merged <- bind_rows(lapply(list_df, compact))
+
+ # # Combine POI information together for redundant pois
+ # poi_merged <- poi_orig %>%
+ # select(-c(nexus, AreaSqKM, oldPOI, DnHydroseq, TotDASqKM)) %>%
+ # group_by(COMID) %>%
+ # summarise_each(funs(toString(na.omit(.))))
+ # is.na(poi_merged) <- poi_merged == ""
+
+ # Join new POI COMIDs and geometry with the old Type fields
+ fin_POIs <- poi_merged %>%
+ arrange(COMID) %>%
+ bind_cols(get_node(filter(nhd, COMID %in% .$COMID) %>% arrange(COMID), position = "end")) %>%
+ st_sf() %>%
+ st_compatibalize(., POIs_wgeom)
+
+ return (list(xWalk = poi_fix, new_POIs = fin_POIs))
+}
+
+### USED in DS_poiFix
+#' Move POIs that fall on flowlines with no catchment upstream/downstream
+# to adjacent flowline with most similar total drainage area. Called from
+# DS_poi_fix function above
+#' @param poi_fix (data.frame) POI data set of COMIDs to be changed
+#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
+#'
+#' @return (data frame) DF of POIs with new COMID associated
+movePOI_NA_DA <- function(poi_fix, nhdDF){
+ #print(poi_fix)
+ nhdDF <- distinct(nhdDF)
+
+ # Closest POI/US/DS
+ up_segs <- unique(nhdplusTools::get_UM(nhdDF, poi_fix, sort=T))
+ seg2fix <- filter(nhdDF, COMID == poi_fix) %>%
+ distinct()
+
+ # Sorted results and filter out all flowlines w/o catchments
+ upstuff <- filter(nhdDF, COMID %in% unlist(up_segs)) %>%
+ arrange(Hydroseq) %>%
+ filter(AreaSqKM > 0)
+
+ down_segs <- unique(nhdplusTools::get_DM(nhdDF, poi_fix, sort=T))
+ downstuff <- filter(nhdDF, COMID %in% unlist(down_segs)) %>%
+ arrange(Hydroseq)%>%
+ filter(AreaSqKM > 0)
+
+ # combine into one dataframe, select up/downstream seg with least change in total drainage area
+ near_FL <- rbind(select(upstuff, COMID, TotDASqKM, AreaSqKM) %>%
+ slice(1),
+ select(downstuff, COMID, TotDASqKM, AreaSqKM) %>%
+ slice(1))
+
+ # If 1 or other adjacent flowlines are coupled with a catchment
+ if (sum(near_FL$AreaSqKM) > 0){
+ new_POI <- near_FL[(which.min(abs(seg2fix$TotDASqKM - near_FL$TotDASqKM))),] #near_FL$COMID
+ new_POI$oldPOI <- poi_fix
+ new_POI$DnHydroseq <-seg2fix$DnHydroseq
+ } else {
+ # Remove POI if not catchment associated with flowlines upstream or downstream
+ print (poi_fix)
+ print ("US and DS flowlines also have no catchment, removing POI")
+ new_POI <- NA
+ }
+ return(new_POI)
+}
+
+#' create draft segments
+#' @param final_POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+create_draft_segments <- function(POIs, flowline) {
+
+ xWalk <- POIs$xwalk
+ vpu <- POIs$vpu
+ POIs <- POIs$POIs
+
+ if("POI_ID" %in% colnames(flowline)) {
+ flowline <- select(flowline, -POI_ID)
+ }
+
+ # Sort POIs by Levelpath and Hydrosequence in upstream to downstream order
+ seg_POIs <- filter(st_drop_geometry(flowline),
+ COMID %in% POIs$COMID,
+ COMID %in% filter(flowline, minNet == 1)$COMID)
+
+ # derive incremental segments from POIs
+ inc_segs <- make_incremental_segments(filter(flowline, minNet == 1), seg_POIs)
+
+ flowline_final <- flowline %>%
+ left_join(select(inc_segs, COMID, POI_ID), by = "COMID")
+
+ # create and write out final dissolved segments
+ nsegments_fin <- segment_creation(flowline_final, xWalk)
+
+ flowline_final <- select(flowline_final, -POI_ID) %>%
+ left_join(distinct(st_drop_geometry(nsegments_fin$raw_segs), COMID, POI_ID), by = "COMID")
+
+ nsegments <- nsegments_fin$diss_segs
+
+ list(flowline_final = flowline_final, nsegments = nsegments, vpu = vpu)
+
+}
+
+#' Creates finalized segments and routing
+#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
+#' @param routing_fix (sf data.frame) any additional routing fixes
+#'
+#' @return (sf data.frame) data.frame of segments
+segment_creation <- function(nhdDF, routing_fix = NULL){
+
+ if(!"StartFlag" %in% names(nhdDF)) {
+ nhdDF$StartFlag <- ifelse(nhdDF$Hydroseq %in% nhdDF$DnHydroseq, 0, 1)
+ }
+
+ in_segs <- filter(nhdDF, !is.na(POI_ID))
+
+ # If there are routing fixes to account for if a POI with a DA of 0 is moved upsream or downstream
+ if (is.data.frame(routing_fix)){
+ routing_fix <- routing_fix %>%
+ rename(COMID = oldPOI, new_COMID = COMID)
+
+ # Above we generated the network using the initial set of POIs; here we crosswalk over the old COMIDs to the new
+ nhd_fix <- nhdDF %>%
+ left_join(routing_fix %>%
+ select(COMID, new_COMID), by = c("POI_ID" = "COMID")) %>%
+ mutate(POI_ID = ifelse(is.na(new_COMID), POI_ID, new_COMID)) %>%
+ filter(!POI_ID %in% routing_fix$COMID) %>%
+ select(-new_COMID)
+
+ in_segs <- filter(nhd_fix, !is.na(POI_ID))
+ }
+
+ # Dissolve flowlines to aggregated segments
+ nsegments <- filter(in_segs, !is.na(POI_ID)) %>%
+ group_by(POI_ID) %>%
+ #arrange(desc(LevelPathI), desc(Hydroseq)) %>%
+ summarize(TotalLength = sum(LENGTHKM),TotalDA = max(TotDASqKM), HW = max(StartFlag),
+ do_union = FALSE) %>%
+ #st_cast("MULTILINESTRING") %>%
+ inner_join(st_drop_geometry(filter(in_segs, minNet == 1)) %>%
+ select(COMID, Hydroseq, DnHydroseq), by = c("POI_ID" = "COMID"))
+
+ # produce a short data frame for populating TO_POI for downstream segment
+ to_from <- filter(st_drop_geometry(in_segs)) %>%
+ left_join(filter(st_drop_geometry(nhdDF), !is.na(POI_ID)) %>%
+ select(COMID, Hydroseq, POI_ID), by = c("DnHydroseq" = "Hydroseq")) %>%
+ select(COMID.x, Hydroseq, DnHydroseq, POI_ID.y) %>%
+ rename(To_POI_ID = POI_ID.y)
+
+ # Add To_POI_ID to dissolved segments
+ nsegments_fin <- nsegments %>%
+ left_join(select(to_from, COMID.x, To_POI_ID), by = c("POI_ID" = "COMID.x")) %>%
+ select(POI_ID, TotalLength, TotalDA, HW, To_POI_ID)
+
+ return(list(diss_segs = nsegments_fin, raw_segs = in_segs))
+}
+
+collapse_pois <- function(final_POIs, poi_dar_move, poi_distance_move, flowline) {
+
+ POIs <- final_POIs$POIs
+ vpu <- final_POIs$vpu
+
+ # number POIs
+ POIs <- mutate(POIs, id = row_number(), moved = NA)
+
+ moved_pois <- get_moved_pois(POIs, poi_dar_move, poi_distance_move, flowline)
+
+ check_dups <- moved_pois$POIs %>%
+ group_by(COMID) %>%
+ filter(n() > 1)
+
+ dups <- NULL
+
+ if(nrow(filter(check_dups, all(c(0,1) %in% nexus))) != nrow(check_dups)){
+ print("Multiple POI ids at same geometric location")
+ no_dups <- filter(check_dups, all(c(0,1) %in% nexus))
+ dups <- filter(check_dups, !id %in% no_dups$id)
+ # write_sf(dups, temp_gpkg, dup_pois)
+ } else {
+ print("All double COMIDs nexus for gage or WB splitting")
+ }
+
+ list(POIs = POIs,
+ duplicate_pois = dups,
+ pois_collapsed = moved_pois$pois_collapsed,
+ vpu = vpu)
+}
+
+#' Collapses POIs together based on criteria
+#' @param pois sf data frame of POIs
+#' @param move_category (character) POI data theme to move
+#' @param DAR (numeric) drainage area threshold to move within
+#' @param dist (numeric) maximum river distance between two points to move within
+#' @param flowline (sf data.frame) nhd flowline
+#' @param keep_category (character) POI data themes to keep static
+#'
+#' @return (sf data.frame, table) dataframe of pois, table of points that have moved
+poi_move <- function(pois, move_category, DAR, dist, flowline, keep_category) {
+ # filter out features with identical geometry
+
+ # Add row_number
+ pois_edit <- pois %>%
+ mutate(nexus = ifelse(is.na(nexus), 0, nexus))
+
+ # Don't consider points already moved
+ if("moved" %in% colnames(pois_edit)){
+ pois_tomove <- filter(pois_edit, is.na(moved)) # change from poi_edit
+ pois_moved_pre <- filter(pois_edit, !is.na(moved))}
+
+ # If 'keep' category included
+ if(!missing(keep_category)){
+ poi2move <- filter(pois_tomove, !is.na(.data[[move_category]]) & nexus == FALSE) %>%
+ filter(if_all(!!as.symbol(keep_category), function(x) is.na(x))) %>%
+ # Never move these
+ filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_Term), all_vars(is.na(.)))
+
+ pois2keep <- filter(pois_tomove, !id %in% poi2move$id)
+ #is.na(.data[[move_category]]) & nexus == FALSE) #%>%
+ #filter(if_all(!!as.symbol(keep_category), function(x) is.na(x)))
+ } else {
+ # POIs to move
+ poi2move <- pois_tomove %>%
+ filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_Term), all_vars(is.na(.))) %>%
+ filter(nexus == 0) %>%
+ filter(!is.na(.data[[move_category]]))
+
+ pois2keep <- filter(pois_tomove, !id %in% poi2move$id)
+ }
+
+ # Get relevant NHD data
+ nhd_poi1 <- filter(flowline, COMID %in% pois2keep$COMID)
+ nhd_poi2 <- filter(flowline, COMID %in% poi2move$COMID)
+ # Ensure they are on same level path
+ nhd_poi2 <- filter(nhd_poi2, LevelPathI %in% nhd_poi1$LevelPathI)
+
+ # Join NHD data
+ pois2keep_nhd <- pois2keep %>%
+ inner_join(select(st_drop_geometry(nhd_poi1), COMID, LevelPathI, Hydroseq,
+ DA_keep = TotDASqKM, Pathlength_keep = Pathlength), by = "COMID") %>%
+ rename(COMID_keep = COMID)
+
+ # Join NHD data
+ pois2move_nhd <- select(poi2move, COMID, !!as.symbol(move_category), id_move = id) %>%
+ inner_join(select(st_drop_geometry(nhd_poi2), COMID, LevelPathI, Hydroseq, TotDASqKM, Pathlength),
+ by = "COMID")
+
+ # Candidates to move
+ pois2move_cand <-pois2move_nhd %>%
+ inner_join(select(st_drop_geometry(pois2keep_nhd), COMID_keep, DA_keep, LevelPathI,
+ Pathlength_keep, id_keep = id, nexus),
+ by = "LevelPathI") %>%
+ mutate(river_dist = abs(Pathlength - Pathlength_keep), DAR_poi = abs(DA_keep/TotDASqKM),
+ move_dir = ifelse(Pathlength < Pathlength_keep, "Up", "Down")) %>%
+ group_by(id_move, move_dir) %>%
+ ungroup() %>%
+ filter((river_dist < dist) & (DAR_poi > (1 - DAR)) & (DAR_poi < (1 + DAR))) %>%
+ select(!!as.symbol(move_category), id_move, COMID, id_keep, COMID_keep, river_dist, DAR_poi, move_dir, nexus) %>%
+ st_drop_geometry()
+
+ move_distinct <- pois2move_cand %>%
+ group_by(id_keep) %>%
+ filter(row_number() == 1) %>%
+ ungroup() %>%
+ distinct(id_move, COMID_move = COMID, id_keep, COMID_keep, river_dist, DAR_poi, move_dir, nexus) %>%
+ group_by(id_move) %>%
+ slice(which.min(abs(1 - DAR_poi)))
+
+ if(nrow(move_distinct) == 0){
+ print("no POIs to move")
+ return(pois)
+ }
+
+ pois2_move <- filter(st_drop_geometry(pois_tomove), id %in% move_distinct$id_move) %>%
+ select_if(~sum(!is.na(.)) > 0) %>%
+ select(-c(COMID, nexus)) %>%
+ inner_join(select(move_distinct, id_move, id_keep), by = c("id" = "id_move"))
+
+ move_fields <- colnames(select(pois2_move, -c(id, id_keep)))
+
+ if(length(move_fields) == 1){
+ pois2_keep <- filter(pois_tomove, id %in% pois2_move$id_keep, !id %in% pois2_move$id) %>%
+ inner_join(select(pois2_move, id_move = id, id_keep,
+ new_val = !!as.symbol(move_category)), by = c("id" = "id_keep")) %>%
+ mutate(moved := ifelse(is.na(!!as.symbol(move_category)),
+ id_move, moved),
+ !!as.symbol(move_category) := ifelse(is.na(!!as.symbol(move_category)),
+ new_val, !!as.symbol(move_category)))
+
+ moved_points <- filter(pois2_keep, !is.na(new_val), !is.na(moved)) %>%
+ mutate(moved_value = move_category)
+ } else {
+ for (field in move_fields){
+ pois2_keep <- filter(pois_tomove, id %in% pois2_move$id_keep, !id %in% pois2_move$id) %>%
+ inner_join(select(pois2_move, id_move = id, id_keep, new_val = !!as.symbol(field)),
+ by = c("id" = "id_keep")) %>%
+ mutate(moved := ifelse(is.na(!!as.symbol(field)),
+ id_move, moved),
+ !!as.symbol(field) := ifelse(is.na(!!as.symbol(field)),
+ new_val, !!as.symbol(field)))
+
+ pois_moved <- filter(pois2_keep, !is.na(new_val), !is.na(moved)) %>%
+ mutate(moved_value = field)
+
+ if(!exists("moved_points")){
+ moved_points <- pois_moved
+ } else {
+ moved_points <- rbind(moved_points, pois_moved)
+ }
+ }
+ }
+
+
+ pois_final <- data.table::rbindlist(list(filter(pois_edit, !id %in% c(moved_points$id_move, pois2_keep$id)),
+ select(pois2_keep, -c(new_val, id_move, new_val))), fill = TRUE) %>%
+ st_as_sf()
+
+ return(list(final_pois = pois_final, moved_points = moved_points))
+
+}
+
+
+#' get moved pois
+#' @param final_POIs finalized POIs that can be reconciled
+#' @param poi_dar_move POI drainage area ratio where moves are allowed
+#' @param poi_distance_move POI distance where moves are allowed
+#' @param flowline flowline to use for evaluation of poi moves
+get_moved_pois <- function(final_POIs, poi_dar_move, poi_distance_move, flowline) {
+
+ # Move HUC12 to other POIs
+ moved_pois <- poi_move(final_POIs, "Type_HUC12", poi_dar_move,
+ poi_distance_move, flowline)
+
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois$moved_points %>%
+ mutate(move_type = "huc12 to other")
+ } else {
+ final_POIs <- moved_POIs
+ }
+
+ # Gages to confluences, terminals
+ moved_pois <- poi_move(final_POIs, "Type_Gages", poi_dar_move,
+ poi_distance_move, flowline, c("Type_Conf", "Type_Term"))
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "gages to conf"))
+ } else {
+ final_POIs <- moved_POIs
+ }
+
+ # Gages to waterbody inlets
+ moved_pois <- poi_move(final_POIs, "Type_Gages", poi_dar_move,
+ poi_distance_move, flowline, c("Type_WBIn", "Type_WBOut"))
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "gages to wbin"))
+ } else {
+ final_POIs <- moved_pois
+ }
+
+ # Waterbody inlet to confluence
+ moved_pois <- poi_move(final_POIs, "Type_WBIn", poi_dar_move/2,
+ poi_distance_move*0.4, flowline, "Type_Conf")
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "gages to term"))
+ } else {
+ final_POIs <- moved_pois
+ }
+
+ # # Waterbody inlet to confluence
+ # moved_pois <- poi_move(final_POIs, "Type_WBOut", poi_dar_move/2,
+ # poi_distance_move*0.4, flowline, "Type_WBIn")
+ # if(!is.data.frame(moved_pois)){
+ # final_POIs <- moved_pois$final_pois
+ # moved_pois_table <- moved_pois_table %>%
+ # rbind(moved_pois$moved_points %>%
+ # mutate(move_type = "gages to term"))
+ # } else {
+ # final_POIs <- moved_pois
+ # }
+
+ # Waterbody inlet to confluence
+ # TODO: verify that this is OK Type_HUC12 was here in move_category?!?
+ moved_pois <- poi_move(final_POIs, "Type_WBIn", poi_dar_move/2,
+ poi_distance_move*0.4, flowline, "Type_Conf")
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "gages to term"))
+ } else {
+ final_POIs <- moved_pois
+ }
+
+ # NID to waterbody outlet
+ moved_pois <- poi_move(final_POIs, "Type_hilarri", poi_dar_move/2,
+ poi_distance_move * 0.4, flowline, c("Type_WBOut", "Type_TE"))
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "nid to wb_out"))
+ } else {
+ final_POIs <- moved_pois
+ }
+
+ # NID to waterbody outlet
+ moved_pois <- poi_move(final_POIs, "Type_DA", poi_dar_move,
+ poi_distance_move, flowline)
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "nid to wb_out"))
+ } else {
+ final_POIs <- moved_pois
+ }
+
+ if("Type_elev" %in% names(final_POIs)){
+ # NID to waterbody outlet
+ moved_pois <- poi_move(final_POIs, "Type_elev", poi_dar_move,
+ poi_distance_move, flowline)
+ if(!is.data.frame(moved_pois)){
+ final_POIs <- moved_pois$final_pois
+ moved_pois_table <- moved_pois_table %>%
+ rbind(moved_pois$moved_points %>%
+ mutate(move_type = "nid to wb_out"))
+ } else {
+ final_POIs <- moved_pois
+ }
+ }
+
+ list(POIs = final_POIs, pois_collapsed = moved_pois_table)
+
+}
+
+create_poi_lookup <- function(POIs, events, full_cats,
+ flowline) {
+
+ vpu <- POIs$vpu
+
+ pois_collapsed <- POIs$pois_collapsed
+
+ # Final POI layer
+ POIs <- POIs$POIs %>%
+ mutate(identifier = row_number())
+
+ # Unique POI geometry
+ final_POI_geom <- POIs %>%
+ select(identifier) %>%
+ cbind(st_coordinates(.)) %>%
+ group_by(X, Y) %>%
+ mutate(geom_id = cur_group_id()) %>%
+ ungroup()
+
+ final_POIs_table <- POIs %>%
+ inner_join(select(st_drop_geometry(final_POI_geom), -X, -Y), by = "identifier") %>%
+ select(-identifier)
+
+ # POI data theme table
+ pois_data_orig <- reshape2::melt(st_drop_geometry(select(final_POIs_table,
+ -c(nexus, nonrefactor, id, moved))),
+ id.vars = c("COMID", "geom_id")) %>%
+ filter(!is.na(value)) %>%
+ group_by(COMID, geom_id) %>%
+ mutate(identifier = cur_group_id()) %>%
+ rename(hy_id = COMID, poi_id = identifier, hl_reference = variable, hl_link = value) %>%
+ distinct()
+
+ if(!is.null(pois_collapsed)){
+ pois_data_moved <- select(st_drop_geometry(pois_collapsed),
+ hy_id = COMID, hl_link = new_val, hl_reference = moved_value) %>%
+ inner_join(distinct(pois_data_orig, hy_id, geom_id, poi_id), by = "hy_id")
+
+ pois_data <- data.table::rbindlist(list(pois_data_moved, pois_data_orig), use.names = TRUE) %>%
+ filter(!hl_reference %in% c("id", "moved"))
+ } else {
+ pois_data <- pois_data_orig
+ }
+
+ # POI Geometry table
+ poi_geometry <- select(final_POIs_table, hy_id = COMID, geom_id) %>%
+ inner_join(distinct(pois_data, hy_id, geom_id, poi_id),
+ by = c("hy_id" = "hy_id", "geom_id" = "geom_id")) %>%
+ distinct() %>%
+ st_as_sf()
+
+ # write_sf(pois_data, nav_gpkg, poi_data_table)
+ # write_sf(poi_geometry, nav_gpkg, poi_geometry_table)
+
+ poi_geom_xy <- cbind(poi_geometry, st_coordinates(poi_geometry)) %>%
+ st_drop_geometry()
+
+ event_table <- NULL
+
+ if(!is.null(events)) {
+ events_data <- events %>%
+ arrange(COMID) %>%
+ cbind(st_coordinates(.)) %>%
+ st_drop_geometry() %>%
+ group_by(COMID, REACHCODE, REACH_meas) %>%
+ mutate(event_id = cur_group_id()) %>%
+ rename(hy_id = COMID) %>%
+ ungroup()
+
+ event_table <- select(events_data, -c(nexus, X, Y))
+ }
+
+ nexi <- filter(final_POIs_table, nexus == 1) %>%
+ cbind(st_coordinates(.)) %>%
+ select(hy_id = COMID, X, Y) %>%
+ inner_join(poi_geom_xy, by = c("hy_id" = "hy_id", "X" = "X", "Y" = "Y")) %>%
+ inner_join(events_data, by = c("hy_id" = "hy_id", "X" = "X", "Y" = "Y"), multiple = "all") %>%
+ select(hy_id, REACHCODE, REACH_meas, event_id, poi_id) %>%
+ group_by(hy_id, REACHCODE) %>%
+ filter(REACH_meas == min(REACH_meas)) %>%
+ ungroup()
+ #distinct(hy_id, REACHCODE, REACH_meas, event_id, poi_id)
+
+ event_geometry_table <- nexi
+
+ # write_sf(, nav_gpkg, event_table)
+ # write_sf(nexi, nav_gpkg, event_geometry_table)
+
+ # Load data
+ lookup <- dplyr::select(sf::st_drop_geometry(flowline),
+ NHDPlusV2_COMID = COMID,
+ realized_catchmentID = COMID,
+ mainstem = LevelPathI) %>%
+ dplyr::mutate(realized_catchmentID = ifelse(realized_catchmentID %in% full_cats$FEATUREID,
+ realized_catchmentID, NA)) %>%
+ left_join(select(st_drop_geometry(poi_geometry), hy_id, poi_geom_id = geom_id),
+ by = c("NHDPlusV2_COMID" = "hy_id"))
+
+ # sf::write_sf(lookup, nav_gpkg, lookup_table_refactor)
+
+ list(lookup = lookup, event_table = event_table,
+ event_geometry_table = event_geometry_table,
+ pois_data = pois_data, poi_geometry = poi_geometry, vpu = vpu)
+
+}
\ No newline at end of file
diff --git a/workspace/R/03_refactor_functions.R b/workspace/R/03_refactor_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..ffea5fa2b9008eda9c88bcc649c555b1d0eacb07
--- /dev/null
+++ b/workspace/R/03_refactor_functions.R
@@ -0,0 +1,208 @@
+#' create refactor input
+#' @param flowline flowlines to be used in refactor
+#' @param refactor_event_table table of locations refactor should split flowlines
+#' @param pois all POIs with geometry
+#' @param pois_data attributes for POIs
+#' @return list with all events, outlets and comids to exclude
+create_refactor_input <- function(flowline, refactor_event_table, pois, pois_data) {
+
+ # TODO: #157 will fix the need for this filter!
+
+ events_refactor <- rename(refactor_event_table, COMID = hy_id) |>
+ inner_join(select(sf::st_drop_geometry(flowline), COMID, LENGTHKM, FromMeas, ToMeas), by = "COMID")
+
+ if(nrow(events_refactor) > 0) {
+ events_refactor$comid_meas <- sapply(seq_len(nrow(events_refactor)), \(i) {
+ hydroloom::rescale_measures(events_refactor$REACH_meas[i],
+ events_refactor$FromMeas[i],
+ events_refactor$ToMeas[i])
+ })
+
+ events_refactor$length_up <- events_refactor$LENGTHKM * events_refactor$comid_meas / 100
+ events_refactor$length_dn <- events_refactor$LENGTHKM - events_refactor$length_up
+
+ events_refactor <- filter(events_refactor, length_dn > 0.15 & length_up > 0.15) |>
+ select(-LENGTHKM, FromMeas, ToMeas, comid_meas, length_up, length_dn)
+ }
+ events_refactor <- events_refactor|>
+ distinct(COMID, REACHCODE, REACH_meas,
+ poi_id, geom) %>%
+ arrange(poi_id) %>%
+ mutate(event_identifier = row_number())
+
+ POIs_ref <- pois |>
+ inner_join(select(st_drop_geometry(flowline), TotDASqKM, COMID, DnHydroseq),
+ by = c("hy_id" = "COMID"))
+
+ # Also need to avoid modification to flowlines immediately downstream of POIs
+ # This can cause some hydrologically-incorrect catchment aggregation
+ POI_downstream <- filter(flowline, Hydroseq %in% POIs_ref$DnHydroseq, AreaSqKM > 0)
+
+ # build final outlets set
+ term_poi <- filter(pois_data, hl_reference == "Type_Term")
+
+ outlets <- POIs_ref |>
+ mutate(type = ifelse(poi_id %in% term_poi$poi_id, "terminal", "outlet"))
+
+ # Need to avoid refactoring catchments that are long and thing and
+ # reasonably large. They cause problems in a downstream step.
+ avoid <- dplyr::filter(flowline, (sqrt(AreaSqKM) / LENGTHKM) > 3 & AreaSqKM > 1)
+
+ exclude <- c(outlets$COMID,
+ avoid$COMID,
+ POI_downstream$COMID)
+
+ outlets <- rename(outlets, COMID = hy_id) %>%
+ filter(!poi_id %in% events_refactor$poi_id)
+
+ list(events_refactor = events_refactor,
+ outlets = outlets,
+ exclude = exclude)
+}
+
+#' run refactor nhdplus
+#' @param flowline flowlines to be used in refactor
+#' @param split_meters distance to use to split flowlines
+#' @param para_split_flines how many jobs to run at a time for splitting
+#' @param combine_meters how long to use as combine target
+#' @param events_refactor event locations where flowlines should be split
+#' @param refactor_exclusion_list flowlines that should not be refactored
+#' @param rpu_code raster processing unit
+#' @param proj_crs projected coordinate reference system to put outputs in
+run_refactor_nhdplus <- function(flowline, split_meters,
+ para_split_flines, combine_meters,
+ events_refactor, refactor_exclusion_list,
+ rpu_code, proj_crs) {
+
+ tf <- paste0("temp/refactored_", rpu_code,".gpkg")
+ tr <- paste0("temp/reconciled_", rpu_code, ".gpkg")
+
+ unlink(list(tf, tr))
+
+ refactor_nhdplus(nhdplus_flines = dplyr::select(flowline, -FTYPE), # Select controls whether prepare_nhdplus is used.
+ split_flines_meters = split_meters,
+ split_flines_cores = para_split_flines,
+ collapse_flines_meters = combine_meters,
+ collapse_flines_main_meters = combine_meters,
+ out_refactored = tf,
+ out_reconciled = tr,
+ three_pass = TRUE,
+ purge_non_dendritic = FALSE,
+ events = events_refactor,
+ exclude_cats = refactor_exclusion_list,
+ warn = TRUE)
+
+ out <- list(refactored = st_transform(read_sf(tf), proj_crs),
+ reconciled = st_transform(read_sf(tr), proj_crs))
+
+ unlink(list(tf, tr))
+
+ return(out)
+}
+
+#' create refactor lookup
+#' @param refactored_network reconciled and refactored network as ouput from run_refactor_nhdplus
+#' @param flowline flowlines as used in refactor
+#' @param events_refactor event locations where flowlines should be split
+#' @param outlets all outlets
+#' @return list with lookup table, outlets, and duplicate checks
+create_refactor_lookup <- function(refactored_network, flowline, events_refactor, outlets) {
+
+ # create lookup for ref flowlines to use in the non-dendritic steps
+ refactor_lookup <- st_drop_geometry(refactored_network$reconciled) %>%
+ dplyr::select(ID, member_COMID) %>%
+ dplyr::mutate(member_COMID = strsplit(member_COMID, ",")) %>%
+ tidyr::unnest(cols = member_COMID) %>%
+ dplyr::mutate(NHDPlusV2_COMID = as.integer(member_COMID)) %>% # note as.integer truncates
+ dplyr::rename(reconciled_ID = ID)
+
+ if(is.character(refactor_lookup$reconciled_ID))
+ refactor_lookup$reconciled_ID <- as.integer(refactor_lookup$reconciled_ID)
+
+ lookup_table <- tibble::tibble(NHDPlusV2_COMID = unique(as.integer(refactor_lookup$member_COMID))) %>%
+ dplyr::left_join(refactor_lookup, by = "NHDPlusV2_COMID")
+
+ # readr::write_csv(lookup_table, lookup_table_file)
+ # write_sf(lookup_table, out_refac_gpkg, lookup_table_refactor)
+
+ # Join refactored to original NHD
+ refactored <- refactored_network$refactored %>%
+ select(member_COMID = COMID, Hydroseq, event_identifier, event_REACHCODE) %>%
+ inner_join(select(st_drop_geometry(flowline), orig_COMID = COMID, Hydroseq), by = "Hydroseq")
+
+ if(nrow(events_refactor) > 0){
+ # Subset for events
+ refactored_events <- refactored %>%
+ filter(!is.na(event_REACHCODE), !is.na(event_identifier)) %>%
+ mutate(event_identifier = as.numeric(event_identifier))
+
+ event_outlets <- events_refactor %>%
+ inner_join(st_drop_geometry(refactored_events), by = "event_identifier") %>%
+ select(hy_id = COMID, event_id = event_identifier, poi_id, member_COMID)%>%
+ inner_join(select(lookup_table, -NHDPlusV2_COMID), by = "member_COMID")
+
+ # subset for refactored outlets (non-events)
+ refactored_outlets <- filter(refactored,
+ !member_COMID %in% event_outlets$member_COMID)
+
+ # get ref_COMId for other outlets
+ outlets_ref <- outlets %>%
+ filter(!poi_id %in% event_outlets$poi_id) %>%
+ inner_join(lookup_table,
+ by = c("COMID" = "NHDPlusV2_COMID")) %>%
+ group_by(COMID) %>%
+ filter(member_COMID == max(member_COMID)) %>%
+ select(hy_id = COMID, poi_id, member_COMID, reconciled_ID, type)
+
+ outlets_ref_COMID <- data.table::rbindlist(list(outlets_ref, event_outlets),
+ fill = TRUE) %>%
+ st_as_sf()
+ } else {
+ # get ref_COMId for other outlets
+ outlets_ref_COMID <- outlets %>%
+ inner_join(lookup_table,
+ by = c("COMID" = "NHDPlusV2_COMID")) %>%
+ group_by(COMID) %>%
+ filter(member_COMID == max(member_COMID)) %>%
+ select(hy_id = COMID, poi_id, member_COMID, reconciled_ID, type)
+ }
+
+ # write_sf(outlets_ref_COMID, out_refac_gpkg, outlets_layer)
+
+ check_dups_poi <- outlets_ref_COMID %>%
+ group_by(reconciled_ID) %>%
+ filter(n() > 1) %>%
+ ungroup()
+
+ # if(nrow(check_dups_poi) > 1){
+ # print("Double-check for double POIs")
+ # write_sf(check_dups_poi, out_refac_gpkg, paste0(dup_pois, "_", rpu_code))
+ # } else {
+ # print("no double POIs detected")
+ # }
+
+ out <- list(lookup = lookup_table, outlets = outlets_ref_COMID, dups = check_dups_poi)
+}
+
+reconcile_divides <- function(cats, refactored_network, fdr_fac, para_reconcile, cache_split) {
+
+ divides <- reconcile_catchment_divides(catchment = cats,
+ fline_ref = refactored_network$refactored,
+ fline_rec = refactored_network$reconciled,
+ fdr = fdr_fac$fdr,
+ fac = fdr_fac$fac,
+ para = para_reconcile,
+ cache = cache_split,
+ keep = NULL)
+
+ load(cache_split)
+
+ split_cats <- bind_rows(split_cats[lengths(split_cats) > 0])
+
+ split_cats$areasqkm <- as.numeric(units::set_units(sf::st_area(split_cats), "km^2"))
+
+ split_cats <- sf::st_transform(split_cats, proj_crs)
+
+ list(divides = divides, split_cats = split_cats)
+
+}
\ No newline at end of file
diff --git a/workspace/R/04_aggregate_functions.R b/workspace/R/04_aggregate_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..0d32e6d5a09559a291bf868ba97a20072ea1cfe8
--- /dev/null
+++ b/workspace/R/04_aggregate_functions.R
@@ -0,0 +1,184 @@
+#' get highest drainage area
+#' @param lookup lookup table from refactor step
+#' @param flowline source flowlines of refactor
+#' @param refactored refactored but not reconciled reconciled_ID and hydrosequence values
+#'
+get_highest_da <- function(lookup, flowline, refactored) {
+ lookup |>
+ inner_join(select(st_drop_geometry(flowline), COMID, TotDASqKM),
+ by = c("NHDPlusV2_COMID" = "COMID")) |>
+ inner_join(refactored, by = c("NHDPlusV2_COMID" = "COMID")) |>
+ group_by(reconciled_ID) |>
+ filter(Hydroseq == min(Hydroseq))
+}
+
+#' aggregate catchments function
+#' @param divides reconciled divides from refactor step
+#' @param reconciled refactored and reconciled flowlines from refactor step
+#' @param outlets_POI POI outlets from refactor step
+#' @param aggregate_da_thresh_sqkm drainage area threshold passed to aggregate catchments
+#' @param cache_split rda file to output error information to
+#' @param highest_DA as generated by get_highest_da()
+#'
+aggregate_catchments_fun <- function(divides, reconciled, outlets_POI,
+ aggregate_da_thresh_sqkm, cache_split,
+ highest_DA) {
+
+ # https://github.com/r-spatial/sf/issues/1094#issuecomment-988933580 for why this is here.
+ st_geometry(divides[st_is_empty(divides),]) <-
+ st_cast(st_geometry(divides[st_is_empty(divides),]), "MULTIPOLYGON")
+
+ # POI outlets
+ outlets <- select(st_drop_geometry(outlets_POI), ID = reconciled_ID, type)
+
+ # Identify reconciled flowpaths that are terminal and above DA threshold
+ reconciled_DA <- filter(reconciled, TotDASqKM > aggregate_da_thresh_sqkm, is.na(toID))
+
+ # Ones not in existing pois
+ missing_outlets <- filter(reconciled_DA, !ID %in% outlets$ID) |>
+ pull(ID)
+
+ # bind missing outlets, re-assign mis-attributed terminals
+ if(length(missing_outlets) > 0){
+ outlets <- bind_rows(outlets,
+ data.frame(ID = missing_outlets,
+ type = rep("terminal", length(missing_outlets))))
+ # write_sf(filter(reconciled, ID %in% missing_outlets), out_agg_gpkg, "missing_outlets")
+ }
+
+ # Identify reconciled flowpaths that are terminal and below DA threshold
+ reconciled_DA <- filter(reconciled, TotDASqKM <= aggregate_da_thresh_sqkm, is.na(toID))
+
+ # Ones not in existing pois
+ extra_outlets <- filter(reconciled_DA, !ID %in% outlets$ID) |>
+ pull(ID)
+
+ extra_nets <- hydroloom::sort_network(select(st_drop_geometry(reconciled),
+ ID, toID), outlets = extra_outlets)
+
+ # remove extra network from contention
+ reconciled <- filter(reconciled, !ID %in% extra_nets$ID)
+
+ outlets <- outlets |>
+ left_join(select(st_drop_geometry(reconciled), ID, toID), by = "ID") |>
+ mutate(type = ifelse(is.na(toID), "terminal", "outlet")) |>
+ mutate(type = ifelse(type == "terminal" & !is.na(toID), "outlet", type)) |>
+ select(-toID)
+
+ outlets <- filter(outlets, ID %in% reconciled$ID) |>
+ distinct()
+
+ agg_cats <- hyRefactor::aggregate_catchments(flowpath = reconciled,
+ divide = divides,
+ outlets = outlets,
+ da_thresh = aggregate_da_thresh_sqkm,
+ only_larger = TRUE,
+ post_mortem_file = cache_split)
+
+ agg_cats$cat_sets$set <- sapply(agg_cats$cat_sets$set, paste, collapse = ",")
+ agg_cats$fline_sets$set <- sapply(agg_cats$fline_sets$set, paste, collapse = ",")
+
+ # write_sf(agg_cats$cat_sets, out_agg_gpkg, agg_cats_layer)
+ # write_sf(agg_cats$fline_sets, out_agg_gpkg, agg_fline_layer)
+
+ # Get physical geometry of reconciled FL end node whose ID is an aggregated outlet
+ rec_outlets <- filter(st_drop_geometry(reconciled), ID %in% agg_cats$fline_sets$ID) |>
+ cbind(hydroloom::get_node(filter(reconciled, ID %in% agg_cats$fline_sets$ID))) |>
+ st_as_sf()
+
+ # Build final POI set
+ POIs_att <- select(rec_outlets, ID, toID) |>
+ # Bring over POI information
+ inner_join(st_drop_geometry(outlets_POI), by = c("ID" = "reconciled_ID")) |>
+ select(-c(type, member_COMID))
+
+ POIs_missing <- filter(select(rec_outlets, -toID), !ID %in% POIs_att$ID) |>
+ inner_join(st_drop_geometry(agg_cats$fline_sets), by = "ID") |>
+ arrange(ID) |>
+ mutate(poi_id = max(POIs_att$poi_id) + row_number()) |>
+ select(ID, toID, poi_id, event_id = event_identifier, Type_Term = orig_levelpathID) |>
+ inner_join(select(highest_DA, NHDPlusV2_COMID, reconciled_ID), by = c("ID" = "reconciled_ID")) |>
+ select(ID, toID, hy_id = NHDPlusV2_COMID, poi_id, event_id, Type_Term) |>
+ mutate(Type_Term = ifelse(is.na(toID), Type_Term, NA),
+ Type_Con = ifelse(!is.na(toID), 1, NA)) |>
+ st_as_sf()
+
+ if(nrow(POIs_missing) > 0){
+ final_POIs <- data.table::rbindlist(list(POIs_att, select(POIs_missing,
+ -c(Type_Term, Type_Con))), fill = TRUE) |>
+ st_as_sf()
+ } else {
+ final_POIs <- POIs_att
+ }
+
+ unaggregated_outlets <- filter(outlets_POI, !reconciled_ID %in% final_POIs$ID)
+ double_outlets <- final_POIs |> group_by(ID) |> filter(n() > 1)
+
+ # Write out
+ # write_sf(final_POIs, out_agg_gpkg, mapped_outlets_layer)
+ # write_sf(unaggregated_outlets, out_agg_gpkg, "unmapped_outlets")
+ # write_sf(double_outlets, out_agg_gpkg, "double_outlets")
+
+ list(mapped_outlets_layer = final_POIs, unmapped_outlets = unaggregated_outlets,
+ double_outlets = double_outlets, missing_outlets = filter(reconciled, ID %in% missing_outlets),
+ agg_cats_layer = agg_cats$cat_sets, agg_fline_layer = agg_cats$fline_sets)
+
+}
+
+#' make long form pois
+#' @param final_POIs final points of interest from aggregate step
+#'
+make_long_form_pois <- function(final_POIs) {
+
+ POIs <- final_POIs |>
+ arrange(ID)
+
+ final_POI_geom <- POIs |>
+ select(ID)
+
+ final_POI_geom <- final_POI_geom |>
+ cbind(st_coordinates(final_POI_geom)) |>
+ group_by(ID, X, Y) |>
+ mutate(geom_id = cur_group_id()) |>
+ ungroup()
+
+ POIs |>
+ inner_join(select(st_drop_geometry(final_POI_geom), -X, -Y), by = "ID") |>
+ distinct()
+
+}
+
+#' make lookup
+#' @param reconciled refactored and reconciled flowlines from refactor step
+#' @param agg_cats aggregated catchments from aggregate step
+#' @param agg_fline aggregated flowlines from aggregate step
+#'
+make_lookup <- function(reconciled, agg_cats, agg_fline) {
+
+ refactor_lookup <- dplyr::select(st_drop_geometry(reconciled), ID, member_COMID) |>
+ dplyr::mutate(member_COMID = strsplit(member_COMID, ",")) |>
+ tidyr::unnest(cols = member_COMID) |>
+ dplyr::mutate(NHDPlusV2_COMID = as.integer(member_COMID)) |> # note as.integer truncates
+ dplyr::rename(reconciled_ID = ID)
+
+ aggregate_lookup_fline <- dplyr::select(st_drop_geometry(agg_fline), ID, set) |>
+ dplyr::mutate(set = strsplit(set, ",")) |>
+ tidyr::unnest(cols = set) |>
+ dplyr::rename(aggregated_flowpath_ID = ID, reconciled_ID = set)
+
+ aggregate_lookup_catchment <- dplyr::select(st_drop_geometry(agg_cats), ID, set) |>
+ dplyr::mutate(set = strsplit(set, ",")) |>
+ tidyr::unnest(cols = set) |>
+ dplyr::rename(aggregated_divide_ID = ID, reconciled_ID = set)
+
+ if(is.character(aggregate_lookup_catchment$reconciled_ID))
+ aggregate_lookup_catchment$reconciled_ID <- as.integer(aggregate_lookup_catchment$reconciled_ID)
+ if(is.character(aggregate_lookup_fline$reconciled_ID))
+ aggregate_lookup_fline$reconciled_ID <- as.integer(aggregate_lookup_fline$reconciled_ID)
+
+ tibble::tibble(NHDPlusV2_COMID = unique(as.integer(refactor_lookup$member_COMID))) |>
+ dplyr::left_join(refactor_lookup, by = "NHDPlusV2_COMID") |>
+ dplyr::left_join(aggregate_lookup_fline, by = "reconciled_ID") |>
+ dplyr::left_join(aggregate_lookup_catchment, by = "reconciled_ID")
+
+}
diff --git a/workspace/R/non_dend.R b/workspace/R/05_non_dendritic_functions.R
similarity index 53%
rename from workspace/R/non_dend.R
rename to workspace/R/05_non_dendritic_functions.R
index 090819d7284d014d08f4040cf0af5424040537cc..fce667c96ab448bf6cf14dc18f9845d7eff9efa9 100644
--- a/workspace/R/non_dend.R
+++ b/workspace/R/05_non_dendritic_functions.R
@@ -1,3 +1,516 @@
+#'merge rpu to vpu
+#' @param pois pois from reference fabric step
+#' @param rpu_vpu table of rpu and vpu codes
+#' @param vpu vpu to be merged
+#' @param rpu_vpu_out outputs from rpus to other rpus/vpus
+#' @param ref_gpkg_fun function to convert a rpu into a refactored gpkg path
+#' @param agg_gpkg_fun function to convert a rpu into an aggregate gpkg path
+#' @param lookup_table_refactor table name to get the lookup table from
+#' @param reconciled_layer table name to get the reconciled flowlines from
+#' @param divide_layer table name to get the reconciled divides from
+#' @param split_divide_layer table name to get the split catchment divides from
+#' @param agg_fline_layer table name to get the aggregate flowlines from
+#' @param agg_cats_layer table name to get the aggregate catchments from
+#' @param mapped_oulets_layer table name to get the long form mapped pois from
+#'
+merge_rpu_to_vpu <- function(pois, rpu_vpu, vpu, rpu_vpu_out,
+ ref_gpkg_fun, agg_gpkg_fun,
+ lookup_table_refactor,
+ reconciled_layer, divide_layer, split_divide_layer,
+ agg_fline_layer, agg_cats_layer, mapped_outlets_layer) {
+
+ rpu_vpu <- rpu_vpu[rpu_vpu$vpuid == vpu,]
+
+ # Thematic POIs
+ POIs <- pois %>%
+ select(-geom_id)
+
+ merged_layers <- merge_refactor(rpu_vpu$rpuid,
+ rpu_vpu_out,
+ ref_gpkg_fun,
+ agg_gpkg_fun,
+ lookup_table_refactor,
+ reconciled_layer,
+ divide_layer,
+ split_divide_layer,
+ agg_fline_layer,
+ agg_cats_layer,
+ mapped_outlets_layer)
+
+ merged_layers[[agg_cats_layer]] <- merged_layers[[agg_cats_layer]] %>%
+ mutate(areasqkm = as.numeric(units::set_units(st_area(.), "km^2")))
+
+ merged_layers[[agg_fline_layer]] <- merged_layers[[agg_fline_layer]] %>%
+ mutate(lengthkm = as.numeric(units::set_units(st_length(.), "km"))) %>%
+ left_join(select(st_drop_geometry(merged_layers[[agg_cats_layer]]), ID, areasqkm), by = "ID")
+
+ cat_net_rfc <- st_drop_geometry(merged_layers[[reconciled_layer]]) %>%
+ select(id = ID, toID = toID, lengthkm = LENGTHKM, levelpathid = LevelPathID) %>%
+ left_join(select(st_drop_geometry(merged_layers[[divide_layer]]),
+ id = ID, areasqkm), by = "id") %>%
+ relocate(id, toID, lengthkm, areasqkm, levelpathid)
+
+ cat_net_gf <- st_drop_geometry(merged_layers[[agg_fline_layer]]) %>%
+ select(id = ID, toid = toID, lengthkm, areasqkm) %>%
+ left_join(distinct(select(merged_layers[[lookup_table_refactor]],
+ id = aggregated_flowpath_ID,
+ levelpathid = LevelPathID)))
+
+ list(pois = POIs,
+ lookup_table_refactor = select(merged_layers[[lookup_table_refactor]],
+ -aggregated_flowpath_ID,
+ -aggregated_divide_ID),
+ reconciled_layer = merged_layers[[reconciled_layer]],
+ divide_layer = merged_layers[[divide_layer]],
+ split_divide_layer = merged_layers[[split_divide_layer]],
+ mapped_outlets_layer = merged_layers[[mapped_outlets_layer]],
+ agg_cats_layer = merged_layers[[agg_cats_layer]],
+ agg_fline_layer = merged_layers[[agg_fline_layer]],
+ lookup_table_refactor = merged_layers[[lookup_table_refactor]],
+ reconciled_layer = merged_layers[[reconciled_layer]],
+ catchment_network_table_refector = cat_net_rfc,
+ cathment_network_table_aggregate = cat_net_gf,
+ lookup_table_aggregate = merged_layers[[lookup_table_refactor]])
+}
+
+#' merge refactor
+#' @param rpus vector of rpu codes to be merged
+#' @param rpu_vpu_out outputs from rpus to other rpus/vpus
+#' @param ref_gpkg_fun function to convert a rpu into a refactored gpkg path
+#' @param agg_gpkg_fun function to convert a rpu into an aggregate gpkg path
+#' @param lookup_table_refactor table name to get the lookup table from
+#' @param reconciled_layer table name to get the reconciled flowlines from
+#' @param divide_layer table name to get the reconciled divides from
+#' @param split_divide_layer table name to get the split catchment divides from
+#' @param agg_fline_layer table name to get the aggregate flowlines from
+#' @param agg_cats_layer table name to get the aggregate catchments from
+#' @param mapped_oulets_layer table name to get the long form mapped pois from
+#'
+merge_refactor <- function(rpus,
+ rpu_vpu_out,
+ ref_gpkg_fun,
+ agg_gpkg_fun,
+ lookup_table_refactor,
+ reconciled_layer,
+ divide_layer,
+ split_divide_layer,
+ agg_fline_layer,
+ agg_cats_layer,
+ mapped_outlets_layer) {
+
+
+ out <- rep(list(list()), length(rpus))
+ names(out) <- rpus
+
+ s <- 10000000
+
+ for(rpu in rpus) {
+ print(rpu)
+
+ refactor_gpkg <- ref_gpkg_fun(rpu)
+ aggregate_gpkg <- agg_gpkg_fun(rpu)
+
+ out[[rpu]] <- setNames(list(read_sf(aggregate_gpkg, lookup_table_refactor),
+ read_sf(refactor_gpkg, reconciled_layer),
+ read_sf(refactor_gpkg, divide_layer),
+ read_sf(refactor_gpkg, split_divide_layer),
+ read_sf(aggregate_gpkg, agg_fline_layer),
+ read_sf(aggregate_gpkg, agg_cats_layer),
+ read_sf(aggregate_gpkg, mapped_outlets_layer)),
+ c(lookup_table_refactor,
+ reconciled_layer,
+ divide_layer,
+ split_divide_layer,
+ agg_fline_layer,
+ agg_cats_layer,
+ mapped_outlets_layer))#,
+
+ ### RECONCILED ###
+
+ out[[rpu]][[reconciled_layer]] <- select(out[[rpu]][[reconciled_layer]],
+ ID, toID, LENGTHKM, TotDASqKM, member_COMID,
+ LevelPathID = orig_levelpathID)
+
+ out[[rpu]][[reconciled_layer]]$newID <-
+ seq(s, by = 1, length.out = nrow(out[[rpu]][[reconciled_layer]]))
+
+ s <- max(out[[rpu]][[reconciled_layer]]$newID) + 1
+
+ # get a toID that matches the new IDs
+ out[[rpu]][[reconciled_layer]] <- left_join(out[[rpu]][[reconciled_layer]],
+ select(st_drop_geometry(out[[rpu]][[reconciled_layer]]),
+ ID, newtoID = newID),
+ by = c("toID" = "ID"))
+
+ # find updates that we need to apply
+ update <- rpu_vpu_out[!rpu_vpu_out$toCOMID %in% out[[rpu]][[lookup_table_refactor]]$NHDPlusV2_COMID &
+ rpu_vpu_out$COMID %in% out[[rpu]][[lookup_table_refactor]]$NHDPlusV2_COMID, ]
+
+ # apply these updates for follow up if we got any
+ if(nrow(update) > 0) {
+ update <- left_join(update, out[[rpu]][[lookup_table_refactor]],
+ by = c("COMID" = "NHDPlusV2_COMID")) %>%
+ left_join(select(out[[rpu]][[lookup_table_refactor]],
+ NHDPlusV2_COMID, to_member_COMID = member_COMID),
+ by = c("toCOMID" = "NHDPlusV2_COMID"))
+
+ out[[rpu]][[reconciled_layer]] <- left_join(out[[rpu]][[reconciled_layer]],
+ select(update, reconciled_ID, toCOMID),
+ by = c("ID" = "reconciled_ID"))
+ }
+
+ #### LOOKUP TABLE ####
+
+ update_id <- st_drop_geometry(select(out[[rpu]][[reconciled_layer]],
+ old_ID = ID, ID = newID))
+
+ out[[rpu]][[lookup_table_refactor]] <- out[[rpu]][[lookup_table_refactor]] %>%
+ left_join(update_id, by = c("reconciled_ID" = "old_ID")) %>%
+ select(-reconciled_ID, reconciled_ID = ID) %>%
+ left_join(update_id, by = c("aggregated_flowpath_ID" = "old_ID")) %>%
+ select(-aggregated_flowpath_ID, aggregated_flowpath_ID = ID) %>%
+ left_join(update_id, by = c("aggregated_divide_ID" = "old_ID")) %>%
+ select(-aggregated_divide_ID, aggregated_divide_ID = ID) %>%
+ left_join(st_drop_geometry(select(out[[rpu]][[reconciled_layer]],
+ ID = newID, LevelPathID)),
+ by = c("reconciled_ID" = "ID"))
+
+ #### DIVIDE LAYER ####
+
+ out[[rpu]][[divide_layer]] <- left_join(rename(out[[rpu]][[divide_layer]],
+ old_ID = ID),
+ update_id, by = c("old_ID"))
+
+ out[[rpu]][[divide_layer]] <- select(out[[rpu]][[divide_layer]],
+ ID, areasqkm, member_COMID)
+
+ out[[rpu]][[divide_layer]]$rpu <- rep(rpu, nrow(out[[rpu]][[divide_layer]]))
+
+ #### aggregate layers ####
+
+ for(l in c(agg_cats_layer, agg_fline_layer)) { #, mapped_outlets_layer
+
+ out[[rpu]][[l]] <- left_join(rename(out[[rpu]][[l]], old_ID = ID),
+ update_id,
+ by = c("old_ID"))
+
+ if("toID" %in% names(out[[rpu]][[l]])) {
+ out[[rpu]][[l]] <- left_join(rename(out[[rpu]][[l]], old_toID = toID),
+ rename(update_id, toID = ID),
+ by = c("old_toID" = "old_ID"))
+
+ sets <- select(st_drop_geometry(out[[rpu]][[l]]), ID, old_ID, old_set = set) %>%
+ mutate(old_set = strsplit(old_set, ",")) %>%
+ tidyr::unnest(cols = old_set) %>%
+ mutate(old_set = as.integer(old_set)) %>%
+ left_join(rename(update_id, set = ID), by = c("old_set" = "old_ID")) %>%
+ select(-old_set, -old_ID)
+
+ sets <- split(sets$set, sets$ID)
+
+ sets <- data.frame(ID = as.integer(names(sets))) %>%
+ mutate(set = unname(sets))
+
+ out[[rpu]][[l]] <- left_join(select(out[[rpu]][[l]], -set),
+ sets, by = "ID")
+
+ out[[rpu]][[l]] <- select(out[[rpu]][[l]], -old_ID, -old_toID)
+
+ out[[rpu]][[l]] <- out[[rpu]][[l]][c("ID", "toID", "set",
+ names(out[[rpu]][[l]])[!names(out[[rpu]][[l]]) %in%
+ c("ID", "toID", "set",
+ attr(out[[rpu]][[l]], "sf_column"))],
+ attr(out[[rpu]][[l]], "sf_column"))]
+
+ out[[rpu]][[l]]$set <- sapply(out[[rpu]][[l]]$set, paste, collapse = ",")
+ } else {
+
+ out[[rpu]][[l]] <- select(out[[rpu]][[l]], -old_ID)
+
+ out[[rpu]][[l]] <- out[[rpu]][[l]][c("ID",
+ names(out[[rpu]][[l]])[!names(out[[rpu]][[l]]) %in%
+ c("ID",
+ attr(out[[rpu]][[l]], "sf_column"))],
+ attr(out[[rpu]][[l]], "sf_column"))]
+ }
+ }
+
+ }
+
+ out <- setNames(lapply(names(out[[1]]), function(x, out) {
+ dplyr::bind_rows(lapply(out, function(df, n) {
+ if("COMID" %in% names(df[[n]]) && is.numeric(df[[n]]$COMID))
+ df[[n]]$COMID <- as.character(df[[n]]$COMID)
+ df[[n]]
+
+ if("event_id" %in% names(df[[n]]) && !is.character(df[[n]]$event_id))
+ df[[n]]$event_id <- as.character(df[[n]]$event_id)
+ df[[n]]
+ }, n = x))
+ }, out = out), names(out[[1]]))
+
+ if("toCOMID" %in% names(out[[reconciled_layer]])) {
+
+ # blow up so we have unique COMIDs to join on.
+ # need to keep the top most of any splits (the .1 variety)
+ # this makes sure out toCOMID assignments go to the right new id.
+ long_form <- st_drop_geometry(out[[reconciled_layer]]) %>%
+ select(newID, member_COMID) %>%
+ mutate(member_COMID = strsplit(member_COMID, ",")) %>%
+ tidyr::unnest(cols = member_COMID) %>%
+ filter(grepl("\\.1$", member_COMID) | !grepl("\\.", member_COMID)) %>%
+ mutate(NHDPlusV2_COMID = as.integer(member_COMID)) %>%
+ select(-member_COMID, update_newtoID = newID)
+
+ # NOTE: if the missing tocomid is in the next VPU they will still be NA
+ out[[reconciled_layer]] <- left_join(out[[reconciled_layer]],
+ long_form, by = c("toCOMID" = "NHDPlusV2_COMID"))
+ out[[reconciled_layer]]$newtoID[!is.na(out[[reconciled_layer]]$toCOMID)] <-
+ out[[reconciled_layer]]$update_newtoID[!is.na(out[[reconciled_layer]]$toCOMID)]
+
+ # now use updates from refactored ids with aggregate
+ long_form <- st_drop_geometry(out[[agg_fline_layer]]) %>%
+ select(ID, set) %>%
+ mutate(set = strsplit(set, ",")) %>%
+ tidyr::unnest(cols = set) %>%
+ mutate(set = as.integer(set)) %>%
+ select(update_newtoID = ID, refactor_ID = set)
+
+ # join updated toID from refactor so we can update as needed
+ out[[agg_fline_layer]] <- out[[agg_fline_layer]] %>%
+ # this adds a "new_toID" containing the refactor id that the
+ # aggregate flowpaths we are updating need to go to.
+ left_join(select(st_drop_geometry(out[[reconciled_layer]]),
+ ID = newID, new_toID = update_newtoID),
+ by = "ID") %>%
+ # we need to handle sets of refactor ids and get the right aggregate toID
+ left_join(long_form, by = c("new_toID" = "refactor_ID"))
+ # need to update the field to reflect the information joined just above.
+ out[[agg_fline_layer]]$new_toID[!is.na(out[[agg_fline_layer]]$update_newtoID)] <-
+ out[[agg_fline_layer]]$update_newtoID[!is.na(out[[agg_fline_layer]]$update_newtoID)]
+
+ # now do the actual toID updates
+ out[[agg_fline_layer]]$toID[!is.na(out[[agg_fline_layer]]$new_toID)] <-
+ out[[agg_fline_layer]]$new_toID[!is.na(out[[agg_fline_layer]]$new_toID)]
+
+ out[[agg_fline_layer]] <- select(out[[agg_fline_layer]], -new_toID, -update_newtoID)
+ }
+
+ out[[split_divide_layer]] <- rename(out[[split_divide_layer]], comid_part = FEATUREID)
+
+ out[[reconciled_layer]] <- select(out[[reconciled_layer]], ID = newID,
+ toID = newtoID, LENGTHKM, TotDASqKM,
+ member_COMID, LevelPathID, refactor_ID = ID)
+
+ out
+}
+
+#' get vpu configuration
+#' @param vpu vpu to get configuration for
+#' @param data_paths list of paths to data resources
+#'
+get_vpu_config <- function(vpu, data_paths, full_nhd, full_wbd) {
+
+ elev <- data_paths$elev_cm[grepl(paste0("Ned", substr(vpu, 1, 2)),
+ data_paths$elev_cm, ignore.case = TRUE)]
+
+ if (vpu == "08"){
+ elev$rpu_03g <- data_paths$elev_cm$rpu_03g
+ }
+
+ if(vpu == "02"){
+ grep_exp <-"^02|^04"
+ } else if (vpu == "08") {
+ grep_exp <- "^03|^08"
+ } else {
+ grep_exp <- paste0("^", substr(vpu, start = 1, stop = 2))
+ elev <- append(elev, list(rpu_03g = data_paths$elev_cm$rpu_03g))
+ }
+
+ vpu_nhd <- full_nhd %>%
+ filter(grepl(paste0("^", grep_exp, ".*"), .data$VPUID)) %>%
+ nhdplusTools::align_nhdplus_names(.)
+
+ vpu_WBD <- full_wbd %>%
+ filter(grepl(paste0("^", grep_exp, ".*"), .data$HUC_12))
+
+ list(vpu_nhd = vpu_nhd, vpu_WBD = vpu_WBD, elev = elev)
+}
+
+#' make hu12 xwalk
+#' @param cats catchments from reference fabric
+#' @param divides reconciled divides from refactor
+#' @param vpu vpu that we are running
+#' @param wbd_xwalk crosswalk input file
+#' @param wbd_sf raw wbd dataset
+make_hu12_xwalk <- function(cats, divides, vpu, wbd_xwalk, wbd_sf) {
+
+ # Read in full NHD cats
+ cats <- filter(cats, full_cats == 1)
+ cats <- sf::st_make_valid(cats)
+ divides <- sf::st_make_valid(divides)
+
+ # Intersect NHD catchments and divides with HUC12
+ nhd_wbd_int <- get_HUC12_Xwalk(vpu, cats, divides,
+ wbd_xwalk,
+ wbd_sf)
+
+ # Bring over divides/HUC12 intersection information into divides layer
+ xwalk_divides_wbd <- st_drop_geometry(nhd_wbd_int$divides_HUC12) %>%
+ select(-c(ACRES, HU_12_MOD))
+
+ divides <- divides %>%
+ left_join(distinct(xwalk_divides_wbd) %>%
+ group_by(ID) %>%
+ filter(intArea == max(intArea)) %>%
+ ungroup() %>%
+ select(ID, HUC_12_int, intArea, AreaHUC12),
+ by = "ID")
+
+ # Bring over divides/HUC12 intersection information into divides layer
+ xwalk_nhd_wbd <- st_drop_geometry(nhd_wbd_int$cats_HUC12) %>%
+ select(-c(ACRES, HU_12_MOD))
+
+ rm(nhd_wbd_int)
+
+ cats <- cats %>%
+ left_join(distinct(xwalk_nhd_wbd) %>%
+ group_by(FEATUREID) %>%
+ slice(which.max(intArea)) %>%
+ ungroup() %>%
+ select(FEATUREID, HUC_12_int, intArea, AreaHUC12),
+ by = "FEATUREID") %>%
+ st_transform(proj_crs)
+
+ # # All intersecting NHD cat / divides / HUC12 geometries (1: many)
+ # write_sf(xwalk_nhd_wbd, ND_gpkg, xwalk_layer)
+ # write_sf(xwalk_divides_wbd, ND_gpkg, divides_xwalk)
+ #
+ # # Cats with the HUC_12 value (HUC_12_int) that is the max overlap
+ # write_sf(cats, ND_gpkg, nhd_catchment)
+ # write_sf(divides, ND_gpkg, divide_layer)
+
+ list(xwalk_layer = xwalk_nhd_wbd, divides_xwalk = xwalk_divides_wbd,
+ nhd_catchment = cats, divide_layer = divides)
+
+}
+
+#' Merges geopackages together to create CONUs geopackage of features
+#' @param VPU VPU from NHDPlusV2
+#' @param full_cats (sf data.frame) all catchments (sinks/flowline) within given VPU
+#' @param divides (sf data.frame) divides layer for a given VPU
+#' @param wbd (data.frame) HUC12 X-walk table, see get_data for full citation
+#' @param wbd_SF (sf data.frame) HUC12 layer from NHDPlusv2.1 national geodatabase
+#' @return (sf data.frame) intersection of nhd catchments and divides layer with HUC12
+#'
+get_HUC12_Xwalk <- function(vpu, full_cats = FALSE, divides = FALSE, wbd = FALSE, wbd_SF = FALSE){
+
+ # HUC02 includes some
+ if(vpu == "02"){
+ grep_exp <-"^02|^04"
+ } else if (vpu == "08") {
+ grep_exp <- "^03|^08"
+ } else {
+ grep_exp <- paste0("^", substr(vpu, start = 1, stop = 2))
+ }
+
+ # crosswalk to HU12, filter by VPU
+ nhd_to_HU12 <- read.csv(wbd, colClasses = c("character", "integer", "character")) %>%
+ filter(grepl(grep_exp, .data$HUC_12)) %>%
+ mutate(HUC_8 = substr(HUC_12, 1, 8))
+
+ # Read in the NHDPlus National GDB HUC12 layer
+ HUC12_lyr <- wbd_SF %>%
+ #filter(grepl(paste0("^", VPU,".*"), .data$HUC_12)) %>%
+ filter(grepl(grep_exp, .data$HUC_12)) %>% #,
+ st_transform(st_crs(full_cats)) %>%
+ st_make_valid() %>%
+ select(HUC_12, ACRES, HU_10_TYPE, HU_12_DS, HU_12_MOD, HU_12_TYPE)
+
+ reg_cats <- full_cats %>%
+ left_join(select(nhd_to_HU12, c(FEATUREID, HUC_12)), by = "FEATUREID")
+
+ sqm_per_sqkm <- 0.000001
+ acres_per_sqkm <- .00404686
+ # Intersect the HUC12s and catchments
+ cats_HUC12 <- sf::st_intersection(reg_cats, HUC12_lyr) %>%
+ # Convert area to squaker kilometers
+ mutate(intArea = as.numeric(st_area(.)) * sqm_per_sqkm,
+ AreaHUC12 = ACRES * acres_per_sqkm) %>%
+ rename(HUC_12_int = HUC_12.1)
+
+ divides_HUC12 <- sf::st_intersection(divides, HUC12_lyr) %>%
+ # Convert area to squaker kilometers
+ mutate(intArea = as.numeric(st_area(.)) * sqm_per_sqkm,
+ AreaHUC12 = ACRES * acres_per_sqkm) %>%
+ rename(HUC_12_int = HUC_12)
+
+
+ return(list(cats_HUC12 = cats_HUC12, divides_HUC12 = divides_HUC12))
+}
+
+#' make divides nd
+#' @param divides divides after hu12 crosswalk
+#' @param lookup lookup_table_aggregate from merged vpus
+#' @param cats nhd_catchment from hu12 crosswalk step
+#' @param cat_rpu_table table listing what rpu each catchment belongs to
+#'
+make_divides_nd <- function(divides, lookup, cats, cat_rpu_table, debug = FALSE) {
+
+ # Bind divide with lookup, identify aggregation step
+ divides_lu <- divides %>%
+ left_join(distinct(select(lookup, reconciled_ID, aggregated_divide_ID)),
+ by = c("ID" = "reconciled_ID")) %>%
+ filter(!is.na(ID) & !is.na(aggregated_divide_ID)) %>%
+ rename(POI_ID = aggregated_divide_ID) %>%
+ # attribute that hyrefactor was the step used to aggregate these catchments
+ mutate(aggStep = "hyRef")
+
+ # Identify cats witin the full catchment set not refactored or aggregated, add
+ # to divides data frame
+ cats_miss <- cats %>%
+ left_join(select(lookup, NHDPlusV2_COMID, member_COMID, reconciled_ID ,
+ POI_ID = aggregated_divide_ID),
+ by = c("FEATUREID" = "NHDPlusV2_COMID")) %>%
+ filter(is.na(POI_ID), !member_COMID %in% divides_lu$member_COMID) %>%
+ mutate(aggStep = NA) %>%
+ distinct() %>%
+ left_join(select(cat_rpu_table, FEATUREID, rpu = RPUID)) %>%
+ #filter(!reconciled_ID %in% divides_lu$ID) %>%
+ select(-member_COMID) %>%
+ mutate(areasqkm = as.numeric(st_area(.)/1000000)) %>%
+ select(ID = reconciled_ID, member_COMID = FEATUREID, rpu, HUC_12_int, intArea, AreaHUC12, POI_ID, aggStep)
+
+ divides_lu <- divides_lu %>%
+ select(-areasqkm) %>%
+ rbind(cats_miss) %>%
+ # resolve terminal non-POI outlets where we can
+ nhdplusTools:::check_valid() %>%
+ st_cast("POLYGON")
+
+ # clean_geometry(divides_lu, ID = "POI_ID", keep = 1.0, crs = st_crs(divides_lu))
+ divides_lu <- dissolve_holes(divides_lu)
+
+ rm(cats_miss)
+
+ # DEBUG:
+ # HRU layer
+ protoHRUs <- NULL
+ if(debug) {
+ protoHRUs <- divides_lu %>%
+ group_by("POI_ID") %>%
+ summarize(do_union = TRUE) %>%
+ sfheaders::sf_remove_holes(.) %>%
+ st_make_valid()
+ # write_sf(protoHRUs, ND_gpkg, HRU_layer)
+ # rm(protoHRUs)
+ }
+
+ # write_sf(divides_lu, ND_gpkg, divides_nd)
+
+ list(divides_nd = divides_lu, HRU_layer = protoHRUs)
+}
+
#' Dissolves internal unaggregated divides within existing aggregated catchments
#' @param divides_poi (sf data frame) data frame of reconciled divides
#
@@ -47,6 +560,49 @@ dissolve_holes <- function(divides_poi){
return(divides_poi)
}
+#' assign huc12 function
+#' @param divides_lu divides from divides non dritic step
+#' @param xwalk_nhd_wbd xwalk_layer from huc12 crosswalk step
+#' @param vpu_nhd vpu_nhd from vpu_attributes step
+#' @param debug logical whether to output proto HRUs
+assign_huc12_fun <- function(divides_lu, xwalk_nhd_wbd, vpu_nhd, debug = FALSE) {
+
+ print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
+
+ # This will crate aggregated IDs for NHD catchments that match HUC12 footprint if aggregated together
+ # The Coefficient of Areal correpsondence - is the last argument
+ if("AREASQKM" %in% names(xwalk_nhd_wbd)) {
+ xwalk_nhd_wbd <- rename(xwalk_nhd_wbd,
+ AreaSqKM = AREASQKM)
+ }
+
+ divides_lu <- assign_HUC12(divides_lu, xwalk_nhd_wbd,
+ filter(vpu_nhd, FTYPE != "Coastline"), CAC_thresh)
+
+ # Determine if any unaggregated catchments match HUC10 footprint (mostly in the west)
+ divides_lu <- assign_HUC10(divides_lu, xwalk_nhd_wbd,
+ filter(vpu_nhd, FTYPE != "Coastline"), CAC_thresh) %>%
+ select(-comid_char)
+
+ protoHRUs <- NULL
+ if(debug) {
+ # DEBUG:
+ # HRU layer
+ # this is not working in my testing
+ protoHRUs <- divides_lu %>%
+ group_by(POI_ID) %>%
+ summarize(do_union = TRUE) %>%
+ sfheaders::sf_remove_holes(.) %>%
+ st_make_valid()
+ # write_sf(protoHRUs, ND_gpkg, HRU_layer)
+ # rm(protoHRUs)
+ }
+
+ # Update missing_cats
+ # write_sf(divides_lu, ND_gpkg, divides_nd)
+
+ list(divides_nd = divides_lu, HRU_layer = protoHRUs)
+}
#' Determine if any divides that have not been assigned to an aggregated catchment
#' can be aggregated on the basis of their HUC12 ID
@@ -62,7 +618,7 @@ dissolve_holes <- function(divides_poi){
#' @return (sf data frame) data frame with unaggregated divides assigned if HUC10 if grouped divides
#' meet CAC criteria
assign_HUC12 <- function(divides_poi, HUC12_xwalk, nhd, CAC_num){
-
+
miss_cats_sub <- filter(divides_poi, is.na(POI_ID))
# HUC12/cat intersections associated with missing catchments
@@ -73,7 +629,7 @@ assign_HUC12 <- function(divides_poi, HUC12_xwalk, nhd, CAC_num){
#***************************************
# STEP 1 - Identify aggregated cats without aggregated ID that match the HUC12 footprint
# Note - out west we may need to expand this to HUC10
-
+
# HUC12s that match Catchment footprint
huc12_in_nhd <- nhd_wbd_int_sub %>%
# int_HUC_12 is the intersection HUC12, not the NAWQA Xwalk HUC12
@@ -108,7 +664,7 @@ assign_HUC12 <- function(divides_poi, HUC12_xwalk, nhd, CAC_num){
#***************************************
# STEP 2 - Identify HUC12s that match very large nhd catchments
# Note - out west we may need to expand this to HUC10
-
+
# Update the number of missing catchments
miss_cats_sub <- filter(divides_poi, is.na(POI_ID))
@@ -136,7 +692,7 @@ assign_HUC12 <- function(divides_poi, HUC12_xwalk, nhd, CAC_num){
mutate(POI_ID = ifelse(!is.na(new_POI_ID), new_POI_ID, POI_ID),
aggStep = ifelse(member_COMID %in% cat_in_HUC12s$member_COMID, "HUC_12", aggStep)) %>%
select(-new_POI_ID)
-
+
#***************************************
# STEP 2 - Identify edge non-aggregated catchments that may contribute to the HUC12 but are not
# assigned an aggregated ID and may not share the HUC12 value
@@ -306,6 +862,45 @@ assign_HUC10 <- function(divides, HUC12_xwalk, nhd, CAC_num){
return(mutate(divides, comid_char = as.character(member_COMID)))
}
+#' create coastal catchments
+#' @param vpu_nhd vpu_nhd from vpu_attributes step
+#' @param divides_lu divides from assign huc12 step
+#' @param vpu_WBD vpu_WBD from vpu_attributes step
+#' @param debug logical whether to output proto HRUs
+#'
+create_coastal_catchments <- function(vpu_nhd, divides_lu, vpu_WBD, debug = FALSE) {
+ protoHRUs <- NULL
+ # aggregate frontal hucs of same type
+ if("Coastline" %in% unique(vpu_nhd$FTYPE)){
+ print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
+
+
+ # Function to create coastal catchments by HUC12 and catch inflows.
+ divides_lu <- coastal_cats(divides_lu, vpu_nhd, vpu_WBD)
+
+ if(debug) {
+ # DEBUG:
+ # HRU layer
+ protoHRUs <- divides_lu %>%
+ group_by(POI_ID) %>%
+ summarize(do_union = TRUE) %>%
+ sfheaders::sf_remove_holes(.) %>%
+ st_make_valid()
+ }
+
+
+ # Update missing_cats
+ # write_sf(divides_lu, ND_gpkg, divides_nd)
+
+ } else {
+ print ("No Coastlines in VPU")
+ }
+
+ vpu_nhd <- filter(vpu_nhd, FTYPE != "Coastline")
+
+ list(vpu_nhd = vpu_nhd, divides_nd = divides_lu, protoHRUs = protoHRUs)
+}
+
#' Determine if any divides that have not been assigned to an aggregated catchment
#' can be aggregated as coastal catchments using their HUC12 ID (no CAC match requirement)
#' @param nhd (sf data frame) full data frame of nhd flowlines (including coastal flowlines)
@@ -336,10 +931,10 @@ coastal_cats <- function(divides_poi, full_nhd, vpu_HUC12){
#divides_miss <- rbind(coastal_cats, filter(frontal_HUC12_cats, !member_COMID %in% coastal_cats$member_COMID)) %>%
# mutate(member_COMID = as.character(member_COMID))
-
+
coastalFL <- rbind(coastFL, filter(st_drop_geometry(full_nhd), COMID %in% divides_miss$member_COMID)) %>%
distinct()
-
+
# # Just assign remaining nonPOI costal cats the HUC12, not going to get much better information
divides_miss <- divides_miss %>%
mutate(HUC_12_POI = ifelse(member_COMID %in% coastal_cats$member_COMID, HUC_12_int, POI_ID))
@@ -368,7 +963,7 @@ coastal_cats <- function(divides_poi, full_nhd, vpu_HUC12){
cat_at_coast <- coastal_cats %>%
inner_join(st_drop_geometry(nhd_at_coast) %>%
select(COMID, Hydroseq), by = c("member_COMID_int" = "COMID"))
-
+
nhd2coast_us <- full_nhd %>%
filter(TerminalPa %in% filter(nhd2coast, COMID %in% cat2coast$member_COMID)$Hydroseq) %>%
select(COMID, TerminalPa)
@@ -418,19 +1013,135 @@ coastal_cats <- function(divides_poi, full_nhd, vpu_HUC12){
select(-HUC_12_POI, member_COMID, ID, rpu, POI_ID, aggStep, HUC_12_int, AreaHUC12, intArea) %>%
mutate(vpu_ID = substr(rpu, 1, 2), comid_char = as.character(member_COMID))
}
-
+
divides_poi <- dissolve_holes(divides_poi)
return(divides_poi)
}
}
+#' fix holes
+#' @param divides_lu divides layer from create coastal step
+#' @param HUC12_table wbd layer from the NHDPlus
+#' @param nhdplus_sinks sink layer from the NHDPlus
+#' @param min_da_km_terminal minimum drainage area to include a terminal network
+#' @param vpu_nhd vpu_nhd from create coastal step
+#' @param lookup lookup_table_aggregate from merged vpus
+#' @param elev elev from vpu configuration step
+#'
+fix_holes <- function(divides_lu, HUC12_table,
+ nhdplus_sinks, min_da_km_terminal,
+ vpu_nhd, lookup, elev) {
+
+ print(paste0("Currently there are ", sum(is.na(divides_lu$POI_ID)), " cats without a POI_ID"))
+
+ if(sum(is.na(divides_lu$POI_ID)) > 0){
+
+ # Handle nhd sinks
+ # arrange divides_lu by member_COMID and populate with RowID for easy iteration within next two steps
+ divides_lu <- divides_lu %>%
+ arrange(member_COMID, POI_ID) %>%
+ mutate(row_ID = row_number()) %>%
+ arrange(row_ID)
+
+ HUC_sinks <- NHD_sinks(divides_lu, area_thresh = min_da_km_terminal/2,
+ HUC12_table = HUC12_table,
+ NHD_sinks = nhdplus_sinks)
+
+ if(length(HUC_sinks) == 2){
+ divides_lu <- HUC_sinks$divides_poi
+ sinks_table <- HUC_sinks$sink_cats_table
+ }
+
+ # Scan for terminals that may have been refactored
+ missing_ds <- filter(divides_lu, is.na(POI_ID))
+
+ term_refactored_fun <- function(x) {
+
+ ds_ref <- nhdplusTools::get_DM(vpu_nhd, x, include = FALSE)
+
+ if(length(ds_ref) == 0){
+ return(filter(missing_ds, member_COMID == x))
+ }
+
+ lookup_test <- filter(lookup, NHDPlusV2_COMID %in% ds_ref)
+
+ divides_test <- filter(divides_lu, ID %in% lookup_test$reconciled_ID) %>%
+ filter(!is.na(POI_ID))
+
+ # print(unique(divides_test$POI_ID))
+
+ if(length(unique(divides_test$POI_ID)) == 1){
+ return(filter(missing_ds, member_COMID == x) %>%
+ mutate(POI_ID = unique(divides_test$POI_ID)))
+ } else {
+ return(filter(missing_ds, member_COMID == x))
+ }
+
+ }
+
+ term_refactored <- lapply(missing_ds$member_COMID, term_refactored_fun)
+
+ term_refactored <- data.table::rbindlist(term_refactored[lengths(term_refactored) > 1],
+ fill = TRUE) %>%
+ st_as_sf()
+
+ divides_lu <- filter(divides_lu, !member_COMID %in% term_refactored$member_COMID) %>%
+ rbind(term_refactored)
+
+ if(sum(is.na(divides_lu$POI_ID)) > 0) {
+
+ divides_dem <- miss_term_assign(divides_lu, vpu_nhd, elev)
+
+ divides_lu <- divides_lu %>%
+ left_join(select(divides_dem, member_COMID, agg_ID),
+ by = "member_COMID") %>%
+ mutate(POI_ID = ifelse(!is.na(agg_ID), agg_ID, POI_ID),
+ aggStep = ifelse(!is.na(agg_ID), "boundary DEM", aggStep)) %>%
+ select(-agg_ID)
+
+ if(exists("sinks_table")){
+ sinks_table_fin <- filter(sinks_table, !member_COMID %in% divides_dem$member_COMID)
+ sinks_table_fin <- data.table::rbindlist(list(sinks_table_fin,
+ divides_dem), fill = TRUE)
+ } else {
+ sinks_table_fin <- divides_dem
+ }
+
+ # write_sf(sinks_table_fin, ND_gpkg, ND_table)
+ }
+
+ } else {
+ print ("all unaggregated catchments assigned")
+ }
+
+ divides_lu <- dissolve_holes(divides_lu)
+
+ missing_cats_out <- NULL
+ if(sum(is.na(divides_lu$POI_ID)) > 0){
+ missing_cats_out <- filter(divides_lu, is.na(POI_ID))
+ # write_sf(, ND_gpkg, missing_cats)
+ }
+
+ # Prob HRU - filter(all_hrus, POI_ID == 140402000209)
+ all_hrus <- filter(divides_lu, !is.na(POI_ID)) %>%
+ group_by(POI_ID) %>%
+ summarize(do_union = TRUE) %>%
+ sfheaders::sf_remove_holes(.) %>%
+ nhdplusTools:::check_valid(.)
+
+ # write_sf(divides_lu, ND_gpkg, divides_nd)
+ # write_sf(all_hrus, ND_gpkg, HRU_layer)
+
+ list(missing_cats = missing_cats_out, divides_nd = divides_lu, HRU_layer = all_hrus)
+}
+
#' Determines length of shared perimeters with adjacent catchments
#' @param divides (sf data frame) data frame of reconciled divides
#
#' @return (sf data frame) (data frame) DF of shared perimeter lengths for cats
perims <- function(divides_poi){
-
+
# Subset to data frame of existing divides with POI assignments
divides_wpoi <- filter(divides_poi, !is.na(POI_ID)) %>%
dplyr::select(POI_ID, HUC_12_int, member_COMID, row_ID)
@@ -445,9 +1156,9 @@ perims <- function(divides_poi){
divides_nopoi_int <- st_intersection(divides_nopoi_buff, divides_wpoi) %>%
mutate(perim = lwgeom::st_perimeter(.) / 2) %>%
dplyr::select(POI_ID, HUC_12_int = HUC_12_int, member_COMID, row_ID, perim, bound_cat_POI_ID = POI_ID.1,
- bound_cat_HUC12 = HUC_12_int.1, bound_cat = member_COMID.1, bound_cat_row = row_ID.1) %>%
+ bound_cat_HUC12 = HUC_12_int.1, bound_cat = member_COMID.1, bound_cat_row = row_ID.1) %>%
st_drop_geometry()
-
+
return(divides_nopoi_int)
}
@@ -464,7 +1175,7 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
divides_poi$HUC_10 <- substr(divides_poi$HUC_12_int, 1, 10)
# Filter HUC12 crosswalk to HUC10s id'ed in divides and closed HUC types
- HUC12_sinks <- readRDS(HUC12_table) %>%
+ HUC12_sinks <- HUC12_table %>%
filter(HUC_10 %in% divides_poi$HUC_10) %>%
filter(HU_10_TYPE == "C" | HU_12_TYPE == "C")
@@ -477,7 +1188,7 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
group_by(POI_ID) %>%
filter(n() < 2) %>%
ungroup()
-
+
# Get the NHD sinks
sink_cats_nhd <- filter(divides_poi, is.na(POI_ID)) %>%
filter(grepl("-", .$member_COMID))
@@ -504,19 +1215,19 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
group_by(HUC_12_int) %>%
summarize(do_union = TRUE) %>%
mutate(agg_id = row_number())
-
+
m_per_km <- 1000
# Cast to polygon
agg_cats_poly <- do.call(rbind, lapply(1:nrow(sink_cats_agg),
- function(i){st_cast(sink_cats_agg[i,], "POLYGON")})) %>%
+ function(i){st_cast(sink_cats_agg[i,], "POLYGON")})) %>%
mutate(area = as.numeric(st_area(.))/m_per_km^2)
-
+
# Create new 'HRUs' out of larger sinks above the size threshold
if (nrow(filter(agg_cats_poly, area > area_thresh)) > 0){
# Filter to only large sinks
agg_cats_large <- filter(agg_cats_poly, area > area_thresh)
-
+
# centroids of divides with no assigned POI_ID
cents <- st_point_on_surface(sink_cats)
# intersect centroids with the aggregated HUC12 polygons
@@ -537,9 +1248,9 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
mutate(POI_ID = ifelse(!is.na(POI_ID_new), POI_ID_new, POI_ID),
aggStep = ifelse(!is.na(POI_ID_new), "HUC12_sinks, large", aggStep)) %>%
dplyr::select(-POI_ID_new)
-
+
print ("looking at aggregating smaller sinks")
-
+
sink_cats_small <- filter(sink_cats, !member_COMID %in% filter(sink_cats_final, !is.na(POI_ID_new))$member_COMID) %>%
filter(grepl("-", .$member_COMID))
@@ -553,22 +1264,22 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
# Get pertinent boundaries
cat_bound <- perims(divides_poi) %>%
filter(!bound_cat %in% sink_cats_small$member_COMID)
-
+
# centroids of divides with no assigned POI_ID
cents <- st_point_on_surface(sink_cats_small)
# intersect centroids with the aggregated HUC12 polygons
cats_int <- st_intersects(cents, agg_cats_small)
-
+
# Index of HRUs that missing cats may lie within with holes filled
sink_cats_index <- sapply(cats_int, function(s) if (length(s) == 0) NA else s)
-
+
# Populate ID of HRUs where applicable
sink_cats_small$agg_id <- agg_cats_small[sink_cats_index,]$agg_id
-
+
sink_cats_nhd_table <- st_drop_geometry(sink_cats_small) %>%
inner_join(dplyr::select(cat_bound, -HUC_12_int), by = "member_COMID") %>%
distinct()
-
+
small_sinks_POI <- sink_cats_nhd_table %>%
distinct(agg_id, HUC_12_int, bound_cat_HUC12, bound_cat_POI_ID) %>%
#summarize(perim = sum(perim)) %>%
@@ -576,11 +1287,11 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
group_by(agg_id) %>%
filter(n_distinct(bound_cat_POI_ID) == 1) %>%
ungroup()
-
+
sink_cats_assign <- dplyr::select(sink_cats_nhd_table, member_COMID, agg_id) %>%
inner_join(dplyr::select(small_sinks_POI, agg_id, POI_ID_new = bound_cat_POI_ID), by = "agg_id") %>%
distinct()
-
+
# Bring over POI_ID to divides
divides_poi <- divides_poi %>%
left_join(sink_cats_assign, by = "member_COMID") %>%
@@ -595,7 +1306,7 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
filter(HUC_12 == neighbor_HUC12) %>%
mutate(aggStep = "HUC12_sinks, small") %>%
st_drop_geometry()
-
+
}
}
large_sinks <- select(sink_cats, member_COMID, HUC_12 = HUC_12_int, POI_ID, aggStep) %>%
@@ -623,7 +1334,7 @@ NHD_sinks <- function(divides_poi, area_thresh, HUC12_table, NHD_sinks){
#' Keep the below link here until publishd
#' Topo data bins: https://www.sciencebase.gov/catalog/item/5f5154ba82ce4c3d12386a02
miss_term_assign <- function(divides_poi, nhd, elev){
-
+
# comid <- single comid of a missing catchment (member_COMID in divides_lu)
#' Find and lump remaining areas where possible
#' @param comid (integer) comid of single unaggregated terminal outlet
@@ -637,7 +1348,7 @@ miss_term_assign <- function(divides_poi, nhd, elev){
library(dplyr)
library(sf)
library(nhdplusTools)
-
+
us_network <- get_UT(nhd, incomid)
# Catchment divide not assigned/aggregated and upstream components
@@ -646,7 +1357,7 @@ miss_term_assign <- function(divides_poi, nhd, elev){
} else {
missing_cats <- filter(divides_poi, member_COMID == incomid)
}
-
+
rpu <- filter(missing_cats, member_COMID == incomid)$rpu
missing_cats_union <- st_union(missing_cats) %>%
@@ -663,7 +1374,7 @@ miss_term_assign <- function(divides_poi, nhd, elev){
if(nrow(cats_buff) == 0){
miss_cat <- dplyr::select(st_drop_geometry(missing_cats),
- outlet_COMID = member_COMID) %>%
+ outlet_COMID = member_COMID) %>%
dplyr::mutate(outlet_COMID = as.integer(outlet_COMID),
Elev = NA, neighbor_COMID = NA, POI_ID = NA) %>%
dplyr::select(Elev, outlet_COMID, neighbor_COMID, POI_ID)
@@ -697,7 +1408,7 @@ miss_term_assign <- function(divides_poi, nhd, elev){
term_outlets <- filter(divides_poi, is.na(POI_ID) | aggStep == "HUC12_sinks, small") %>%
dplyr::rename(outlet_COMID = member_COMID)
-
+
out_df <- do.call(rbind,
pbapply::pblapply(unique(term_outlets$outlet_COMID),
assign_func, divides_poi, nhd, elev, cl = NULL)) %>%
@@ -713,60 +1424,45 @@ miss_term_assign <- function(divides_poi, nhd, elev){
by = c("neighbor_COMID" = "member_COMID")) %>%
dplyr::select(member_COMID, neighbor_COMID, HUC_12, neighbor_HUC12, agg_ID = POI_ID) %>%
mutate(aggStep = "boundary DEM")
-
+
return(out_df)
}
-#' Merges geopackages together to create CONUs geopackage of features
-#' @param VPU VPU from NHDPlusV2
-#' @param full_cats (sf data.frame) all catchments (sinks/flowline) within given VPU
-#' @param divides (sf data.frame) divides layer for a given VPU
-#' @param wbd (data.frame) HUC12 X-walk table, see get_data for full citation
-#' @param wbd_SF (sf data.frame) HUC12 layer from NHDPlusv2.1 national geodatabase
-#' @return (sf data.frame) intersection of nhd catchments and divides layer with HUC12
-#'
-get_HUC12_Xwalk <- function(vpu, full_cats = FALSE, divides = FALSE, wbd = FALSE, wbd_SF = FALSE){
+#' manual checks
+#' @param noagg_divides missing_cats from fix holes step
+#' @param divides_lu divides from fix holes step
+#' @param vpu what vpu we are running
+#'
+manual_checks <- function(noagg_divides, divides_lu, vpu) {
+
+ noagg_divides <- noagg_divides %>% #read_sf(ND_gpkg, missing_cats) %>%
+ select(row_ID, POI_ID_noagg = POI_ID) %>%
+ st_drop_geometry()
- # HUC02 includes some
- if(vpu == "02"){
- grep_exp <-"^02|^04"
- } else if (vpu == "08") {
- grep_exp <- "^03|^08"
+ all_hrus <- NULL
+
+ if(all(!is.na(noagg_divides$POI_ID_noagg))){
+ print ("all unaggregated divides accounted for")
+
+ divides_lu <- divides_lu %>%
+ left_join(noagg_divides, by = "row_ID") %>%
+ mutate(POI_ID = ifelse(!is.na(POI_ID_noagg), POI_ID_noagg, POI_ID),
+ aggStep = ifelse(!is.na(aggStep), "manual", aggStep)) %>%
+ select(-POI_ID_noagg)
+
+ # Prob HRU - filter(all_hrus, POI_ID == 140402000209)
+ all_hrus <- filter(divides_lu, !is.na(POI_ID)) %>%
+ group_by(POI_ID) %>%
+ summarize(do_union = TRUE) %>%
+ sfheaders::sf_remove_holes(.) %>%
+ nhdplusTools:::check_valid(.)
+
+ # write_sf(divides_lu, ND_gpkg, divides_nd)
+ # write_sf(all_hrus, ND_gpkg, HRU_layer)
+ list(HRU_layer = all_hrus, divides_nd = divides_lu)
} else {
- grep_exp <- paste0("^", substr(vpu, start = 1, stop = 2))
+ print ("account for unaggregated divides in ", vpu)
+ NULL
}
- # crosswalk to HU12, filter by VPU
- nhd_to_HU12 <- read.csv(wbd, colClasses = c("character", "integer", "character")) %>%
- filter(grepl(grep_exp, .data$HUC_12)) %>%
- mutate(HUC_8 = substr(HUC_12, 1, 8))
-
- # Read in the NHDPlus National GDB HUC12 layer
- HUC12_lyr <- readRDS(file.path(wbd_SF)) %>%
- #filter(grepl(paste0("^", VPU,".*"), .data$HUC_12)) %>%
- filter(grepl(grep_exp, .data$HUC_12)) %>% #,
- st_transform(st_crs(full_cats)) %>%
- st_make_valid() %>%
- select(HUC_12, ACRES, HU_10_TYPE, HU_12_DS, HU_12_MOD, HU_12_TYPE)
-
- reg_cats <- full_cats %>%
- left_join(select(nhd_to_HU12, c(FEATUREID, HUC_12)), by = "FEATUREID")
-
- sqm_per_sqkm <- 0.000001
- acres_per_sqkm <- .00404686
- # Intersect the HUC12s and catchments
- cats_HUC12 <- sf::st_intersection(reg_cats, HUC12_lyr) %>%
- # Convert area to squaker kilometers
- mutate(intArea = as.numeric(st_area(.)) * sqm_per_sqkm,
- AreaHUC12 = ACRES * acres_per_sqkm) %>%
- rename(HUC_12_int = HUC_12.1)
-
- divides_HUC12 <- sf::st_intersection(divides, HUC12_lyr) %>%
- # Convert area to squaker kilometers
- mutate(intArea = as.numeric(st_area(.)) * sqm_per_sqkm,
- AreaHUC12 = ACRES * acres_per_sqkm) %>%
- rename(HUC_12_int = HUC_12)
-
-
- return(list(cats_HUC12 = cats_HUC12, divides_HUC12 = divides_HUC12))
-}
+}
\ No newline at end of file
diff --git a/workspace/R/1_get_data.R b/workspace/R/1_get_data.R
deleted file mode 100644
index 19dd825c09acd180855122093277737325701211..0000000000000000000000000000000000000000
--- a/workspace/R/1_get_data.R
+++ /dev/null
@@ -1,37 +0,0 @@
-#' get_sb_file
-#' @param item sciencebase item id
-#' @param item_files character vector of file names. "all" will download all files.
-#' @param out_destination character path to save files into
-#' @param unzip logical if TRUE, files ending with .7z will be un7zipped
-#' @return path that data was saved to
-get_sb_file <- function(item, item_files, out_destination, unzip = TRUE) {
-
- check_auth()
-
- if(length(item_files) == 1 && item_files == "all") {
- item_files <- sbtools::item_list_files(item)$fname
- }
-
- out_files <- file.path(out_destination, item_files)
-
- missing <- out_files[!file.exists(out_files)]
-
- if(length(missing) > 0) {
- sbtools::item_file_download(item,
- names = basename(missing),
- destinations = missing)
- }
-
- if(unzip) {
-
- un7zip_fs <- missing[grepl("7z$", missing)]
-
- for(f in un7zip_fs) {
- system(paste0(sevenz, " e -o", out_destination, " ", f))
- }
-
- }
-
- out_destination
-
-}
diff --git a/workspace/R/NHD_navigate.R b/workspace/R/NHD_navigate.R
index 3aaacd5b0eba95c911e763521fcbb0c90ef06a30..644912655e3bd951430eddd7cf7fa119f7d4d7b7 100644
--- a/workspace/R/NHD_navigate.R
+++ b/workspace/R/NHD_navigate.R
@@ -1,287 +1,4 @@
-#' Network navigation for upstream/downstream from a COMID of interest
-#' @param inCOM (list) list of input COMIDs
-#' @param nhdDF (sf data.frame) (data frame) valid data frame of NHD flowlines
-#' @param withTrib (logical) flag for if the upstream navigation should include tributaries
-# or stick to mainstem level path
-#
-#' @return (list) list of COMIDs upstream of point
-NetworkNav <- function(inCom, nhdDF, withTrib){
-
- if (missing(withTrib)){
- seg <- nhdplusTools::get_UM(nhdDF, inCom, include = TRUE)
- } else {
- seg <- nhdplusTools::get_UT(nhdDF, inCom)
- }
- return(seg)
-}
-
-#' Creates raw and dissolved segment layers with necessaary
-# upstream/downstream routing attribution
-#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
-#' @param POIs (sf data.frame) Existing POIs
-#'
-#' @return (sf data.frame) data.frame of segments connecting POIs attributed
-#' with POI_ID for each upstream flowpath
-segment_increment <- function(nhdDF, POIs){
-
- ptm<-proc.time()
-
- seg_POIs <- arrange(POIs, desc(LevelPathI), desc(Hydroseq)) %>%
- select(COMID, Hydroseq, LevelPathI) %>%
- group_by(LevelPathI) %>%
- # These next two levels arrange POIs hydrologically along the
- # level path in order to meet the requirements of the code below
- mutate(id = row_number(),
- num = if(n() > 1) id[1L] + row_number()-1 else id) %>%
- ungroup()
-
- # Add an empty field for POI_Id population
- nhdDF <- mutate(nhdDF, POI_ID = 0)
-
- POI_ID_assign <- function(i, seg_POIs, nhd){
- ##########################################
- # Populates POI_ID per segment
- #
- # Arguments:
- # i : (integer) iterator
- # seg_POIs : (data frame) POI data frame
- # nhd : (dataframe) flowlines data frame (no geometry)
- #
- # Returns:
- # nhd_sub : (data frame) raw segments with POI_ID populated
- #
- ##########################################
- library(dplyr)
-
- # If POI is most upstream POI on levelpath
- if (seg_POIs$num[i] == 1){
- # Assign POI_ID
- nhd_sub <- filter(nhd, Hydroseq >= seg_POIs$Hydroseq[i] &
- LevelPathI == seg_POIs$LevelPathI[i]) %>%
- mutate(POI_ID = seg_POIs$COMID[i])
- # or as you travel downstream on set of POIs below level path
- } else {
- # Assign POI_ID
- nhd_sub <- filter(nhd, LevelPathI == seg_POIs$LevelPathI[i] &
- Hydroseq >= seg_POIs$Hydroseq[i] & Hydroseq < seg_POIs$Hydroseq[i-1]) %>%
- mutate(POI_ID = seg_POIs$COMID[i])
- }
- # return assigned flowlines
- return(select(nhd_sub, LevelPathI, Hydroseq, COMID, POI_ID) %>%
- filter(POI_ID != 0))
- }
-
- library(parallel)
- library(dplyr)
- clust <- makeCluster(4)
- POI_list <- parLapply(clust, c(1:nrow(seg_POIs)), POI_ID_assign, seg_POIs, st_drop_geometry(nhdDF))
- #POI_list <- lapply(c(1:nrow(seg_POIs)), POI_ID_assign, seg_POIs, st_drop_geometry(nhdDF))
- stopCluster(clust)
-
- inc_segs <- data.table::rbindlist(POI_list)
-
- print(proc.time()-ptm)
- return(inc_segs)
-}
-
-#' Creates finalized segments and routing
-#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
-#' @param routing_fix (sf data.frame) any additional routing fixes
-#'
-#' @return (sf data.frame) data.frame of segments
-segment_creation <- function(nhdDF, routing_fix = NULL){
-
- if(!"StartFlag" %in% names(nhdDF)) {
- nhdDF$StartFlag <- ifelse(nhdDF$Hydroseq %in% nhdDF$DnHydroseq, 0, 1)
- }
-
- in_segs <- filter(nhdDF, !is.na(POI_ID))
-
- # If there are routing fixes to account for if a POI with a DA of 0 is moved upsream or downstream
- if (is.data.frame(routing_fix)){
- routing_fix <- routing_fix %>%
- rename(COMID = oldPOI, new_COMID = COMID)
-
- # Above we generated the network using the initial set of POIs; here we crosswalk over the old COMIDs to the new
- nhd_fix <- nhdDF %>%
- left_join(routing_fix %>%
- select(COMID, new_COMID), by = c("POI_ID" = "COMID")) %>%
- mutate(POI_ID = ifelse(is.na(new_COMID), POI_ID, new_COMID)) %>%
- filter(!POI_ID %in% routing_fix$COMID) %>%
- select(-new_COMID)
-
- in_segs <- filter(nhd_fix, !is.na(POI_ID))
- }
-
- # Dissolve flowlines to aggregated segments
- nsegments <- filter(in_segs, !is.na(POI_ID)) %>%
- group_by(POI_ID) %>%
- #arrange(desc(LevelPathI), desc(Hydroseq)) %>%
- summarize(TotalLength = sum(LENGTHKM),TotalDA = max(TotDASqKM), HW = max(StartFlag),
- do_union = FALSE) %>%
- #st_cast("MULTILINESTRING") %>%
- inner_join(st_drop_geometry(filter(in_segs, minNet == 1)) %>%
- select(COMID, Hydroseq, DnHydroseq), by = c("POI_ID" = "COMID"))
-
- # produce a short data frame for populating TO_POI for downstream segment
- to_from <- filter(st_drop_geometry(in_segs)) %>%
- left_join(filter(st_drop_geometry(nhdDF), !is.na(POI_ID)) %>%
- select(COMID, Hydroseq, POI_ID), by = c("DnHydroseq" = "Hydroseq")) %>%
- select(COMID.x, Hydroseq, DnHydroseq, POI_ID.y) %>%
- rename(To_POI_ID = POI_ID.y)
-
- # Add To_POI_ID to dissolved segments
- nsegments_fin <- nsegments %>%
- left_join(select(to_from, COMID.x, To_POI_ID), by = c("POI_ID" = "COMID.x")) %>%
- select(POI_ID, TotalLength, TotalDA, HW, To_POI_ID)
-
- return(list(diss_segs = nsegments_fin, raw_segs = in_segs))
-}
-
-#' Moves POI Upstream or downstream if it falls on COMID
-# of flowline with no corresponding catchment
-#' @param POIs_wgeom (sf data.frame) POIs
-#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
-#'
-#' @return (sf data.frame) data.frame of POIs with new COMID associated
-DS_poiFix <- function(POIs_wgeom, nhd){
- nhd <- distinct(nhd)
- POIs <- st_drop_geometry(POIs_wgeom) %>%
- arrange(COMID) %>%
- filter(nexus == FALSE)
-
- # DF of downstream segment
- tocomDF <- select(st_drop_geometry(nhd), COMID, Hydroseq, TotDASqKM,
- DnHydroseq, WBAREACOMI) %>%
- inner_join(select(st_drop_geometry(nhd), COMID_ds = COMID, Hydroseq,
- WBAREACOMI_down = WBAREACOMI, totda_ds = TotDASqKM),
- by = c("DnHydroseq" = "Hydroseq")) %>%
- inner_join(select(st_drop_geometry(nhd), COMID_us = COMID, DnHydroseq,
- WBAREACOMI_up = WBAREACOMI, totda_us = TotDASqKM),
- by = c("Hydroseq" = "DnHydroseq"))
-
- # Find segments with POIs where there is no corresponding catchment that are not terminal
- unCon_fl <- filter(nhd, COMID %in% POIs$COMID, AreaSqKM == 0)# & Hydroseq != TerminalPa)
- unCon_POIs <- filter(POIs, COMID %in% unCon_fl$COMID)
-
- # Get specific fixes for waterbody inlets and outlets
- wbout <- filter(unCon_POIs, !is.na(Type_WBOut)) %>%
- inner_join(tocomDF, by = "COMID") %>%
- mutate(nonrefactor = ifelse(WBAREACOMI %in% WBAREACOMI_up, COMID_ds, 0),
- new_POI = COMID_us)
-
- wb_pois <- filter(unCon_POIs, !is.na(Type_WBIn)) %>%
- inner_join(tocomDF, by = "COMID") %>%
- mutate(nonrefactor = ifelse(WBAREACOMI < 0, COMID_ds, 0),
- new_POI = COMID_us) %>%
- rbind(wbout) %>%
- select(-c(nexus, Hydroseq, TotDASqKM, DnHydroseq, WBAREACOMI, COMID_ds,
- WBAREACOMI_down, totda_ds, COMID_us, WBAREACOMI_up, totda_us)) %>%
- rename(COMID = new_POI, oldPOI = COMID)
-
- # The rest can be resolved with drainage are ratio
- unCon_POIs <- filter(unCon_POIs, !COMID %in% wb_pois$oldPOI)
-
- poi_fix <- as.data.frame(do.call("rbind", lapply(unCon_POIs$COMID, movePOI_NA_DA, st_drop_geometry(nhd)))) %>%
- inner_join(POIs, by = c("oldPOI" = "COMID")) %>%
- inner_join(select(st_drop_geometry(nhd), COMID), by = c("oldPOI" = "COMID")) %>%
- select(-c(AreaSqKM, DnHydroseq, nexus, TotDASqKM)) %>%
- distinct() %>%
- bind_rows(wb_pois)
-
- # Fold in new POIs with existing POIs so all the "Type" attribution will carry over
- # using the minimum will ensure correct downstream hydrosequence gets carried over
- poi_orig <- filter(POIs, COMID %in% poi_fix$COMID) %>%
- bind_rows(poi_fix) %>%
- select(-oldPOI)
-
- list_df <- dplyr::group_by(poi_orig, COMID) |>
- group_split()
-
- compact <- function(l) {
- if(nrow(l) == 1) return(as.data.frame(l))
- lapply(names(l), \(x) {
- out <- unique(l[[x]][!is.na(l[[x]])])
- if(!length(out)) NA
- else if(length(out) == 1) out
- else {
- cat(paste("duplicate id for", unique(l$COMID),
- "column", x,
- "values", paste(out, collapse = ", "),
- "using", out[1]), file = "POI-issues.log")
- out[1]
- }
- }) |>
- setNames(names(l)) |>
- as.data.frame()
- }
-
- poi_merged <- bind_rows(lapply(list_df, compact))
-
- # # Combine POI information together for redundant pois
- # poi_merged <- poi_orig %>%
- # select(-c(nexus, AreaSqKM, oldPOI, DnHydroseq, TotDASqKM)) %>%
- # group_by(COMID) %>%
- # summarise_each(funs(toString(na.omit(.))))
- # is.na(poi_merged) <- poi_merged == ""
-
- # Join new POI COMIDs and geometry with the old Type fields
- fin_POIs <- poi_merged %>%
- arrange(COMID) %>%
- bind_cols(get_node(filter(nhd, COMID %in% .$COMID) %>% arrange(COMID), position = "end")) %>%
- st_sf() %>%
- st_compatibalize(., POIs_wgeom)
-
- return (list(xWalk = poi_fix, new_POIs = fin_POIs))
-}
-
-
-#' Move POIs that fall on flowlines with no catchment upstream/downstream
-# to adjacent flowline with most similar total drainage area. Called from
-# DS_poi_fix function above
-#' @param poi_fix (data.frame) POI data set of COMIDs to be changed
-#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
-#'
-#' @return (data frame) DF of POIs with new COMID associated
-movePOI_NA_DA <- function(poi_fix, nhdDF){
- #print(poi_fix)
- nhdDF <- distinct(nhdDF)
-
- # Closest POI/US/DS
- up_segs <- unique(nhdplusTools::get_UM(nhdDF, poi_fix, sort=T))
- seg2fix <- filter(nhdDF, COMID == poi_fix) %>%
- distinct()
-
- # Sorted results and filter out all flowlines w/o catchments
- upstuff <- filter(nhdDF, COMID %in% unlist(up_segs)) %>%
- arrange(Hydroseq) %>%
- filter(AreaSqKM > 0)
-
- down_segs <- unique(nhdplusTools::get_DM(nhdDF, poi_fix, sort=T))
- downstuff <- filter(nhdDF, COMID %in% unlist(down_segs)) %>%
- arrange(Hydroseq)%>%
- filter(AreaSqKM > 0)
-
- # combine into one dataframe, select up/downstream seg with least change in total drainage area
- near_FL <- rbind(select(upstuff, COMID, TotDASqKM, AreaSqKM) %>%
- slice(1),
- select(downstuff, COMID, TotDASqKM, AreaSqKM) %>%
- slice(1))
-
- # If 1 or other adjacent flowlines are coupled with a catchment
- if (sum(near_FL$AreaSqKM) > 0){
- new_POI <- near_FL[(which.min(abs(seg2fix$TotDASqKM - near_FL$TotDASqKM))),] #near_FL$COMID
- new_POI$oldPOI <- poi_fix
- new_POI$DnHydroseq <-seg2fix$DnHydroseq
- } else {
- # Remove POI if not catchment associated with flowlines upstream or downstream
- print (poi_fix)
- print ("US and DS flowlines also have no catchment, removing POI")
- new_POI <- NA
- }
- return(new_POI)
-}
-
+### NOTUSED?
#' Collaposes/merges POIs together based on drainage area ratio and data theme
#' @param out_gpkg (geopackage) output geopackage to write intermediate results to
#' @param POIs (sf data.frame) Original POIs
@@ -447,6 +164,7 @@ POI_move_down<-function(out_gpkg, POIs, Seg, Seg2, exp, DA_diff){
return (list(allPOIs = fin_POIs, segs = newSegs$diss_segs, FL = newSegs$raw_segs))
}
+### DEPRECATED?
#' Identifies and attributes structural POIs
#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
#' @param final_POIs (sf data.frame) final POIs
@@ -499,7 +217,8 @@ structPOIsNet <- function(nhdDF, final_POIs){
mutate(COMID = final_struct$COMID)
# produce unique set of flowlines linking POIs
- final_net <- unique(unlist(lapply(unique(final_struct$COMID), NetworkNav, st_drop_geometry(nhdDF))))
+ final_net <- unique(unlist(lapply(unique(final_struct$COMID), \(x, nhdDF) get_UM(nhdDF, x),
+ nhdDF = st_drop_geometry(nhdDF))))
# Subset NHDPlusV2 flowlines to navigation results and write to shapefile
structnet <- filter(nhdDF, COMID %in% final_net & grepl(paste0("^", vpu, ".*"), .data$VPUID))
@@ -508,7 +227,7 @@ structPOIsNet <- function(nhdDF, final_POIs){
return(list(struc_POIs = struc_POIs, structnet = structnet))
}
-
+### DEPRECATED?
#' Splits a network based elevation change and size
#' @param in_POI_ID (integer) POI_ID of aggregated flowline that needs to be
#' split based on elevation
@@ -589,1134 +308,3 @@ split_elev <- function(in_POI_ID, split_DF, elev_diff, max_DA){
}
return(split_elev_DF)
}
-
-#' Retrieves waterbodies from NHDArea layer or NHD Hi-Res for ResOpsUs
-#' locations if absent from NHD waterbody
-#' @param nhd (sf data.frame) Fowlines for given VPU
-#' @param WBs (sf data.frame) waterbodiess for discretization within VPU
-#' @param data_paths (list) data paths to data layers
-#'
-#' @return (list) wbs - sf data frame for NHDArea and HR waterbodies
-#' wb_table - table of flowlines and outlet info for each
-#' feature in wb
-HR_Area_coms <- function(nhd, WBs, data_paths, crs){
-
- # Pull out rows for VPU that are NHDArea
- nhd_area_resops <- WBs %>%
- filter(resops_flowlcomid %in% nhd$COMID, source == "NHDAREA")
-
- # Pull out rows for VPU that are NHD HR
- nhd_hr_wb_resops <- WBs %>%
- filter(member_comid != 65000300139130) %>% # R09, in Canada
- filter(resops_flowlcomid %in% nhd$COMID, source == "HR ID AVAILABLE") %>%
- st_drop_geometry()
-
- # Get reachcodes for waterbody outlets, so we have an idea of which
- # NHD HR 4-digit geodatabase we may need to retrieve
- RC <- filter(nhd, COMID %in% nhd_hr_wb_resops$resops_flowlcomid)$REACHCODE
-
- # If no NHDArea or HR waterbodies needed return NULL
- if (nrow(nhd_area_resops) == 0 & nrow(nhd_hr_wb_resops) == 0){
- return(NA)
- }
-
- # If NHDArea feature needed retrieve from National GDB
- if (nrow(nhd_area_resops) > 0){
- nhd_area_vpu <- read_sf(data_paths$nhdplus_gdb, "NHDArea") %>%
- filter(COMID %in% nhd_area_resops$member_comid) %>%
- mutate(source = "NHDv2Area")
-
- wb <- st_transform(nhd_area_vpu, crs)
- }
-
- # If NHDHR feature needed
- if (nrow(nhd_hr_wb_resops) > 0){
- # HUC04 we need to download
- huc04 <- substr(RC, 1, 4)
-
- # Download NHD HR HUC04 if we dont' have it, other wise load and
- # Bind NHDHR waterbodies into one layer
- hr_wb <- do.call("rbind", lapply(unique(huc04), function(x){
- print(x)
- vpu <- unique(substr(x, 1, 2))
-
- if(!file.exists(file.path(data_paths$nhdplus_dir, vpu,
- paste0("NHDPLUS_H_", x, "_HU4_GDB.gdb")))){
- download_nhdplushr(data_paths$nhdplus_dir, unique(huc04))
- }
-
- gdb <- list.files(file.path(data_paths$nhdplus_dir, substr(vpu, 1, 2)),
- pattern = paste0("_", x, "_.+gdb"), full.names = TRUE)
-
- # Format to similar to NHDArea/Waterbody layers
- read_sf(gdb, "NHDWaterbody")})) #%>%
-
- # convert to lower case and designate new shape field
- names(hr_wb) <- tolower(names(hr_wb))
- st_geometry(hr_wb) <- "shape"
-
- hr_wb <- filter(hr_wb, permanent_identifier %in% WBs$member_comid) %>%
- rename(GNIS_NAME = gnis_name, GNIS_ID = gnis_id,
- Permanent_Identifier = permanent_identifier, AREASQKM = areasqkm,
- FTYPE = ftype, FCODE = fcode, FDATE = fdate,
- REACHCODE = reachcode) %>%
- #select(-c(permanent_identifier, visibilityfilter, vpuid)) %>%
- st_zm(.) %>%
- st_as_sf() %>%
- mutate(source = "NHDHR",
- wb_id = ifelse(!is.na(GNIS_ID), GNIS_ID, Permanent_Identifier)) %>%
- st_transform(crs)
-
- # Bind or create new object
- if(exists("wb")){
- hr_wb <- st_compatibalize(hr_wb, wb)
-
- wb <- data.table::rbindlist(list(wb, hr_wb), fill = TRUE) %>%
- st_as_sf()
- } else {
- wb <- hr_wb
- }
-
- }
-
- # # get the outlt rows from the table
- # resops_outlet <- read.csv("data/reservoir_data/ISTARF-CONUS.csv") %>%
- # filter(WBAREACOMI %in% wb$COMID | HR_NHDPLUSID %in% wb$COMID)
-
- # Clear out columns not needed
- WBs_sub <- WBs %>%
- select(-any_of(c("COMID", "GNIS_ID")))
-
- WBs_fin <- st_drop_geometry(WBs_sub) %>%
- mutate(member_comid = member_comid) %>%
- inner_join(select(wb, Permanent_Identifier, GNIS_ID, GNIS_NAME2 = GNIS_NAME),
- by = c("member_comid" = "Permanent_Identifier")) %>%
- mutate(wb_id = ifelse(GNIS_ID %in% c(NA, " "), member_comid, GNIS_ID),
- GNIS_NAME = ifelse(is.na(GNIS_NAME), GNIS_NAME2, GNIS_NAME)) %>%
- select(-c(GNIS_ID, GNIS_NAME2)) %>%
- st_as_sf()
-
- # Create table of all flowlines that intersect the waterbody
- nhd_wb <- st_intersects(st_transform(nhd, st_crs(wb)), wb)
- comid <- nhd[lengths(nhd_wb) > 0,]$COMID
- nhd_wb_all <- nhd_wb[lengths(nhd_wb) > 0] %>%
- purrr::set_names(comid) %>%
- stack() %>%
- # Ind is the default name for the set_names
- rename(comid = ind, nhd_wb = values) %>%
- mutate(wb_comid = wb[nhd_wb,]$Permanent_Identifier,
- outlet = ifelse(comid %in% WBs_fin$resops_flowlcomid, "outlet", NA),
- comid = as.integer(as.character(comid))) %>%
- #left_join(select(wb_table, DAM_ID, DAM_NAME, resops_FlowLcomid),
- # by = c("comid" = "resops_FlowLcomid")) %>%
- left_join(select(st_drop_geometry(wb), wb_id, Permanent_Identifier, GNIS_ID,
- source),
- by = c("wb_comid" = "Permanent_Identifier"))
-
- return(list(nhd_wb_table = nhd_wb_all, wb = WBs_fin))
-}
-
-#' Creates wb inlet and outlet events for splitting in hyRefactor
-#' for waterbodies derived from NHDArea and NHDHR waterbodies
-#' @param WBs (sf data.frame) return from HR_Area_coms
-#' @param nhd_wb (sf data.frame) flowlines that intersect waterbodies
-#' @param type (character) whether to derive inlet or outlet points
-#'
-#' @return (sf data.frame) dataframe of WB inlet and outlet points to split
-#'
-WB_event <- function(WBs, nhd_wb, type){
- # split into features and table
- WBs_table <- WBs$nhd_wb_table
- WBs_layer <- WBs$wb
-
- if (type == "outlet"){
- # get the outlet comid from the ResOps Table
- outlet_fl <- filter(nhd_wb, COMID %in% filter(WBs_table, outlet == "outlet")$comid)
-
- # Get the downstream flowline for continuity
- ds_fl <- filter(nhd_wb, Hydroseq %in% outlet_fl$DnHydroseq,
- LevelPathI %in% outlet_fl$LevelPathI) %>%
- rbind(outlet_fl) %>%
- arrange(desc(Hydroseq)) %>%
- group_by(LevelPathI) %>%
- # union together
- summarize(do_union = TRUE) %>%
- st_cast("LINESTRING")
-
- WBs_HR <- filter(WBs_layer, source == "HR ID AVAILABLE")
-
- # For NHD HR waterbody outlets its a bit more complicated
- if (nrow(WBs_HR) > 0){
- # Get the flowlines intersecting the HR waterbody and find one with the
- # max DA
- outlet_wb_int <- nhd_wb[lengths(st_intersects(st_transform(nhd_wb, st_crs(WBs_HR)),
- WBs_HR)) > 0,] %>%
- group_by(wb_id) %>%
- filter(TotDASqKM == max(TotDASqKM)) %>%
- ungroup()
-
- # get the ds flo with the same levepath (JIC)
- ds_fl <- filter(nhd_wb, DnHydroseq %in% outlet_wb_int$Hydroseq,
- LevelPathI %in% outlet_wb_int$LevelPathI)
-
- outlet_fl <- rbind(outlet_wb_int, ds_fl)
-
- # Cast flowlines within NHDHR waterbody to point
- WB_FL_pnts <- outlet_wb_int %>%
- st_cast("POINT") %>%
- group_by(wb_id) %>%
- mutate(pnt_id = row_number()) %>%
- ungroup()
-
- outlet_pnts <- do.call("rbind", lapply(unique(WB_FL_pnts$wb_id), function(x){
- fl <- filter(WB_FL_pnts, wb_id == x)
- wb <- filter(WBs_HR, wb_id == x)
-
- # Determine which points intersect waterbody
- WB_outlet_pnts <- fl[lengths(st_intersects(fl, wb)) > 0,] %>%
- st_drop_geometry() %>%
- group_by(wb_id) %>%
- mutate(within_wb_id = row_number()) %>%
- filter(within_wb_id >= max(within_wb_id)) %>%
- ungroup() %>%
- select(wb_id, orig_pnt_id = pnt_id, within_wb_id)
-
- # Deriv new linestring by concating points from most upstream point
- # within waterbody to downstream so we can split at FL/waterbody
- # nexus
- outlet_FL <- fl %>%
- inner_join(WB_outlet_pnts, by = "wb_id") %>%
- select(wb_id, pnt_id, orig_pnt_id, within_wb_id) %>%
- filter(pnt_id >= orig_pnt_id) %>%
- group_by(wb_id) %>%
- summarize(do_union = F) %>%
- st_cast("LINESTRING") %>%
- filter(wb_id %in% wb$wb_id)
-
- outlet_pnt <- sf::st_intersection(outlet_FL, WBs_HR) %>%
- st_cast("MULTIPOINT") %>%
- st_cast("POINT") %>% # was point
- group_by(wb_id) %>%
- filter(row_number() == max(row_number(), na.rm = T)) %>%
- ungroup() %>%
- mutate(id = row_number()) %>%
- filter(wb_id == wb_id.1)
- }))
-
- # Derive the events
- if(exists("wb_events")){
- hr_events <- get_flowline_index(st_transform(nhd_wb, st_crs(outlet_pnts)),
- outlet_pnts) %>%
- inner_join(select(st_drop_geometry(nhd_wb), COMID, wb_id), by = "COMID") %>%
- filter(wb_id %in% WBs_HR$wb_id) %>%
- mutate(event_type = type) %>%
- cbind(select(outlet_pnts, geom)) %>%
- st_as_sf() %>%
- st_transform(st_crs(wb_events)) %>%
- st_compatibalize(., wb_events)
-
- wb_events <- rbind(wb_events, hr_events) %>%
- distinct()
- } else {
- wb_events <- do.call("rbind", lapply(unique(outlet_pnts$wb_id), function(x){
- outlet_pnt <- filter(outlet_pnts, wb_id == x)
- get_flowline_index(nhd_wb, outlet_pnt)})) %>%
- left_join(distinct(st_drop_geometry(outlet_pnts), resops_flowlcomid, wb_id),
- by = c("COMID" = "resops_flowlcomid")) %>%
- mutate(event_type = type) %>%
- cbind(select(outlet_pnts, geom)) %>%
- st_as_sf()
- }
-
- }
-
- # For inlet points its alot easier for both NHDARea and NHDHR
- } else {
- start_pts <- get_node(nhd_wb, position = "start") %>%
- cbind(st_drop_geometry(nhd_wb))
-
- inlet_FL <- nhd_wb[lengths(st_intersects(
- st_transform(start_pts, st_crs(WBs_layer)), WBs_layer)) == 0,] %>%
- rbind(filter(nhd_wb, Hydroseq %in% .$DnHydroseq,
- LevelPathI %in% .$LevelPathI)) %>%
- arrange(desc(Hydroseq)) %>%
- unique()
-
- inlet_ls <- inlet_FL %>%
- group_by(LevelPathI) %>%
- st_cast("POINT") %>%
- summarize(do_union = F) %>%
- st_cast("LINESTRING") %>%
- ungroup()
-
- inlet_pnts_int <- sf::st_intersection(
- st_transform(inlet_ls, st_crs(WBs_layer)), WBs_layer) #%>%
- #st_cast("LINESTRING")
-
- int_point <- inlet_pnts_int[st_geometry_type(inlet_pnts_int) %in% c("POINT"),]
- if(nrow(int_point) > 0){
- inlet_fl <- inlet_pnts_int[st_geometry_type(inlet_pnts_int) %in% c("LINESTRING", "MULTILINESTRING"),] %>%
- st_cast("LINESTRING")
- inlet_pnts_int <- rbind(int_point, inlet_fl)
- }
-
- inlet_pnts <- inlet_pnts_int %>%
- group_by(LevelPathI) %>%
- st_cast("POINT") %>%
- mutate(id = row_number()) %>%
- filter(id == min(id), !is.na(wb_id)) %>%
- ungroup()
-
- wb_events <- get_flowline_index(st_transform(nhd_wb, st_crs(inlet_pnts)),
- inlet_pnts) %>%
- inner_join(select(st_drop_geometry(nhd_wb), COMID, wb_id, LevelPathI), by = "COMID") %>%
- mutate(event_type = type) %>%
- inner_join(select(inlet_pnts, LevelPathI), by = "LevelPathI") %>%
- #group_by(COMID, LEVELPATHI) %>%
- mutate(nexus = T) %>%
- rename(POI_identifier = wb_id) %>%
- select(-c(id, offset)) %>%
- st_as_sf()
- }
- return(wb_events)
-}
-
-
-#' Creates POIs for gages using refactor criteria
-#' @param temp_POIs (sf data.frame) current data frame of POIs
-#' @param gages_info (sf data.frame) VPU specific streamgages from 01_gage_selection
-#' @param nhd (sf data.frame) flowline data.frame
-#' @param combine_meters (integer) refactor threshold (m) for if if two adjacent fl should be combined
-#' @reach_meas_thresh (integer) threshold added or substracted from reach_meas to determine if a gage will split fl
-#'
-#' @return (sf data.frame) dataframe of gage POIs
-#'
-gage_POI_creation <- function(tmp_POIs, gages_info, nhd, combine_meters, reach_meas_thresh){
- # Create streamgage POIs
- gage_POIs <- POI_creation(select(st_drop_geometry(gages_info), COMID, site_no), nhd, "Gages") %>%
- st_compatibalize(., tmp_POIs)
-
- # Avoid these for refactoring
- avoid <- dplyr::filter(nhd, (sqrt(AreaSqKM) / LENGTHKM) > 3 & AreaSqKM > 1)
-
- # Create events for streamgages for flowline splitting
- events <- gages_info %>%
- # bring over NHD information
- inner_join(select(st_drop_geometry(gage_POIs), Type_Gages), by = c("site_no" = "Type_Gages")) %>%
- # Get over the NHD attributes
- #inner_join(select(st_drop_geometry(nhd), AreaSqKM, REACHCODE, LENGTHKM, COMID, FromMeas, ToMeas),
- # by = "COMID") %>%
- # Apply reach measure thresholds
- filter(reach_meas - FromMeas > reach_meas_thresh & AreaSqKM > 2 &
- ToMeas - reach_meas > reach_meas_thresh & LENGTHKM > (combine_meters / m_per_km)) %>%
- select(COMID, REACHCODE = reachcode, REACH_meas = reach_meas, Type_Gages = site_no) %>%
- filter(!COMID %in% avoid$COMID) %>%
- mutate(event_type = "streamgage") %>%
- st_compatibalize(., tmp_POIs) %>%
- mutate(nexus = TRUE)
-
- # Reset gage flag if even is created
- gage_POIs_nonevent <- filter(gage_POIs, !Type_Gages %in% events$Type_Gages) %>%
- addType(., tmp_POIs, "Gages", nexus = FALSE, bind = TRUE)
-
- if(nrow(events) > 0){
- tmp_POIs <- data.table::rbindlist(list(gage_POIs_nonevent,
- select(events, COMID, Type_Gages, nexus)), fill = TRUE) %>%
- mutate(nexus = ifelse(is.na(nexus), FALSE, nexus)) %>%
- st_as_sf()
- } else {
- events <- NA
- tmp_POIs <- mutate(tmp_POIs, nexus = FALSE)
- }
-
-
- return(list(events = events, tmp_POIs = tmp_POIs))
-}
-
-#' Creates Waterbody POIs, calls a few other functions
-#' @param nhd (sf data.frame) flowline data.frame
-#' @param WBs_VPU (sf data.frame)
-#' @param data_paths (list) data paths to data layers
-#' @param crs (integer) CRS to use (epsg code)
-#'
-#' @return (sf data.frame) dataframe of waterbody outlet POIs
-#'
-wbout_POI_creaton <- function(nhd, wb_table, data_paths, tmp_POIs, crs){
-
- wb_components_table <- st_drop_geometry(wb_table) %>%
- dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
- tidyr::unnest(cols = member_comid) %>%
- mutate(member_comid = as.integer(member_comid)) %>%
- distinct()
-
- # R17, some wierd stuff going on in the waterbodies
- if("947070203" %in% wb_components_table$member_comid){
- wb_components_table <- wb_components_table %>%
- filter(!wb_id %in% c(1503847, 1513298))
- }
-
- # Bring wb_id to NHD data frame
- if(("wb_id") %in% colnames(nhd)){
- nhd <- select(nhd, -wb_id)
- }
-
- nhd <- nhd %>%
- left_join(distinct(st_drop_geometry(wb_components_table), wb_id, member_comid) %>%
- mutate(member_comid = as.numeric(member_comid)),
- by = c("WBAREACOMI" = "member_comid"))
-
-
- # Resops that are either NHDArea or MHD HR source and are missing in the
- # nhd attributiong table
- resops_wb_other_sources <- filter(wb_table, source ==
- "HR ID AVAILABLE" | (source == "NHDAREA" &
- !wb_id %in% nhd$wb_id) &
- accounted == 0)
-
- # Resops that are not accounted for and NHDv2 waterbody or NHDArea sourced
- resops_main <- filter(wb_table, !is.na(resops_flowlcomid) &
- !wb_id %in% resops_wb_other_sources$wb_id,
- accounted == 0)
-
- # Remaining WB that don't have outlet COMID defined and aren't in ResOPsUS
- WB_outlet <- filter(wb_table, is.na(resops_flowlcomid),
- !wb_id %in% tmp_POIs$Type_WBOut)
-
- # Size-based waterbody outlet POIs ot in NHDArea, HR, or
- # manually defined with ResOPS
- wbout_COMIDs <- nhd %>%
- filter(wb_id %in% WB_outlet$wb_id) %>%
- group_by(wb_id) %>%
- slice(which.min(Hydroseq)) %>%
- ungroup() %>%
- switchDiv(., nhd) %>%
- select(COMID, wb_id) %>%
- mutate(wbtype = "size") %>%
- st_drop_geometry() %>%
- distinct()
-
- # ResOpsUS defined outlets
- resops_main_outlets <- select(st_drop_geometry(resops_main), COMID = resops_flowlcomid,
- wb_id) %>%
- mutate(wbtype = "resops")
-
- # combine together
- wbout_coms <- distinct(rbind(wbout_COMIDs, resops_main_outlets))
-
- # Get NHDArea and HI-Res waterbodies for ResOpsUS locaitons
- WBs_VPU_areaHR <- HR_Area_coms(nhd, resops_wb_other_sources, data_paths, crs)
-
- # if there are no HR/Area waterbodies generated
- if(all(is.na(WBs_VPU_areaHR))){
- tmp_POIs <- POI_creation(wbout_coms,
- nhd, "wb_id") %>%
- addType(., tmp_POIs, "wb_id", nexus = TRUE) %>%
- mutate(Type_WBOut = ifelse(is.na(Type_WBOut), Type_wb_id, Type_WBOut)) %>%
- select(-Type_wb_id) %>%
- left_join(select(st_drop_geometry(resops_main), GRAND_ID, resops_FlowLcomid),
- by = c("COMID" = "resops_FlowLcomid")) %>%
- mutate(Type_resops = ifelse(!is.na(GRAND_ID), GRAND_ID, Type_resops)) %>%
- select(-GRAND_ID)
- } else {
- # WBarea out comids
- wbareaout_coms <- select(st_drop_geometry(nhd), COMID, Hydroseq) %>%
- inner_join(filter(WBs_VPU_areaHR$nhd_wb_table, !is.na(outlet)),
- by = c("COMID" = "comid")) %>%
- group_by(wb_id) %>%
- filter(Hydroseq == min(Hydroseq)) %>% #, row_number() == 1
- ungroup() %>%
- inner_join(select(WBs_VPU_areaHR$wb, -source), by = "wb_id") %>%
- filter(source != "NHDHR") %>%
- select(COMID, wb_id) %>%
- mutate(wbtype = "resops")
-
- if(nrow(wbareaout_coms) > 0){
- wbout_coms <- rbind(wbout_coms, wbareaout_coms)
- }
-
- tmp_POIs <- POI_creation(select(wbout_coms, COMID, wb_id),
- nhd, "wb_id") %>%
- addType(., tmp_POIs, "wb_id", nexus = TRUE) %>%
- mutate(Type_WBOut = ifelse(is.na(Type_WBOut) & (!nexus | is.na(nexus)),
- Type_wb_id, Type_WBOut)) %>%
- select(-Type_wb_id) %>%
- left_join(select(st_drop_geometry(resops_main), grand_id, resops_flowlcomid),
- by = c("COMID" = "resops_flowlcomid")) %>%
- mutate(Type_resops = ifelse(!is.na(grand_id) & (!nexus | is.na(nexus)),
- grand_id, Type_resops)) %>%
- select(-grand_id)
- }
-
- # If the return is not NA
- if(inherits(WBs_VPU_areaHR, "list")){
- # Attribute flowlines that intersect NHDARea and/or NHD HR waterbodies with
- # waterbody COMIDs
- # For NHDHR, two waterbodies might be back to back and share an intersecting
- # flowline, this may cause problems below, so deal with this case
- WBs_VPU_areaHR$nhd_wb_table <- WBs_VPU_areaHR$nhd_wb_table %>%
- left_join(select(st_drop_geometry(resops_wb_other_sources),
- resops_flowlcomid, member_comid, grand_id),
- by = c("comid" = "resops_flowlcomid",
- "wb_comid" = "member_comid")) %>%
- group_by(comid) %>%
- filter(case_when(n() == 2 ~ !is.na(grand_id),
- TRUE ~ n() == 1)) %>%
- ungroup()
-
- nhd <- nhd %>%
- left_join(distinct(WBs_VPU_areaHR$nhd_wb_table, comid, wb_id_hr = wb_id),
- by = c("COMID" = "comid")) %>%
- mutate(wb_id = ifelse(!is.na(wb_id_hr), wb_id_hr, wb_id)) %>%
- select(-wb_id_hr)
-
- # NHD flowlines within the HR waterbodies
- nhd_WBs <- filter(nhd, wb_id %in%
- filter(WBs_VPU_areaHR$nhd_wb_table, source == "NHDHR")$wb_id)
-
- if(nrow(nhd_WBs) > 0){
- # Create outlet events for splitting HR and NHDArea waterbodies
- wb_outlet_events <- WB_event(WBs_VPU_areaHR, nhd_WBs, "outlet") %>%
- st_compatibalize(., tmp_POIs) %>%
- mutate(nexus = TRUE, Type_resops = 2)
-
- tmp_POIs <- data.table::rbindlist(list(tmp_POIs,
- select(wb_outlet_events, COMID, Type_WBOut = wb_id, Type_resops, nexus)), fill = TRUE) %>%
- st_as_sf()
- } else {
- wb_outlet_events <- NA
- }
-
- WBs_VPU_areaHR$wb <- WBs_VPU_areaHR$wb %>%
- sfheaders::sf_remove_holes(.) %>%
- st_compatibalize(wb_poi_lst)
-
- WBs_VPU_areaHR$wb <- nhdplusTools::st_compatibalize(
- WBs_VPU_areaHR$wb, wb_table)
-
- wb_table_filtered <- wb_table %>%
- filter(!st_is_empty(wb_table))
-
- # Append NHDArea and NHDHR waterbodies to waterbody layer
- WBs_VPU <- data.table::rbindlist(list(wb_table_filtered, WBs_VPU_areaHR$wb),
- fill = TRUE) %>%
- st_as_sf()
-
- st_geometry(WBs_VPU) <- st_make_valid(st_geometry(WBs_VPU))
-
- return(list(POIs = tmp_POIs, events = wb_outlet_events, WBs = WBs_VPU,
- nhd_wb_table = nhd))
-
- } else {
- return(list(POIs = tmp_POIs, events = NA, WBs = wb_table,
- nhd_wb_table = nhd))
- }
-}
-
-#' Creates Waterbody POIs, calls a few other functions
-#' @param nhd (sf data.frame) flowline data.frame
-#' @param WBs_VPU (sf data.frame) waterbodies to create inlet pois from
-#' @param data_paths (list) list of data paths
-#' @param crs (integer) CRS to use (epsg code)
-#' @param split_layer (sf data.frame) events to split flowlines with
-#' @param tmp_POIs (sf data.frame) rolling POI data frame
-#'
-#' @return (sf data.frame) dataframe of WB inlet POIs
-#'
-wbin_POIcreation <- function(nhd, wb_lyr, data_paths, crs,
- split_layer, tmp_POIs){
-
- wbout_COMIDs <- filter(tmp_POIs, !is.na(Type_WBOut))
- WBs_in_POIs <- filter(wb_lyr, wb_id %in% wbout_COMIDs$Type_WBOut)
-
- # Unnest to get list of waterbody COMIDS (member_comid)
- wb_table <- st_drop_geometry(wb_lyr) %>%
- dplyr::mutate(member_comid = strsplit(member_comid, ",")) %>%
- tidyr::unnest(cols = member_comid) %>%
- mutate(member_comid = as.integer(member_comid)) %>%
- distinct()
-
- # # Attribute flowline if waterbody exists for POIs
- # nhd_wb <- nhd %>%
- # left_join(distinct(wb_table, wb_id, member_comid),
- # by = c("WBAREACOMI" = "member_comid"))
-
- # Create waterbody inlet POIs
- wbin_COMIDs <- filter(nhd, is.na(wb_id) &
- DnHydroseq %in% filter(nhd, !is.na(wb_id))$Hydroseq) %>%
- select(-wb_id) %>%
- switchDiv(., nhd) %>%
- inner_join(st_drop_geometry(filter(nhd, minNet == 1)) %>%
- select(wb_id, Hydroseq), by = c("DnHydroseq" = "Hydroseq")) %>%
- select(COMID, wb_id, minNet) %>%
- group_by(COMID) %>%
- # Ensure the inlets are on the network defined by confluence POIs
- filter(minNet == 1)
-
- # Headwater Waterbodies that may need the network extended through the inlet
- need_wbin <- st_drop_geometry(wb_lyr) %>%
- #dplyr::select(COMID)%>%
- dplyr::filter(!wb_id %in% wbin_COMIDs$wb_id)
-
- if(nrow(need_wbin)>0){
-
- nhd_inlet <- mutate(nhd, WB = ifelse(wb_id > 0 & wb_id %in% need_wbin$wb_id, 1, 0))
-
- missing_wbin_COMIDs <- filter(nhd_inlet, WB == 0,
- DnHydroseq %in% filter(nhd_inlet, WB == 1)$Hydroseq) %>%
- select(-wb_id) %>%
- switchDiv(., nhd_inlet) %>%
- inner_join(st_drop_geometry(filter(nhd_inlet, minNet == 1)) %>%
- select(Hydroseq, wb_id),
- by = c("DnHydroseq" = "Hydroseq")) %>%
- select(COMID, wb_id) %>%
- group_by(COMID) %>%
- filter(row_number() == 1) %>%
- ungroup()
-
- missing_wbin_COMIDs <- missing_wbin_COMIDs %>%
- left_join(select(st_drop_geometry(nhd_inlet), COMID, TotDASqKM)
- , by = c("COMID")) %>%
- group_by(COMID) %>%
- slice(which.max(TotDASqKM))%>%
- ungroup() %>%
- select(-TotDASqKM)
-
- if(nrow(missing_wbin_COMIDs) > 0){
- wbin_COMIDs <- data.table::rbindlist(list(wbin_COMIDs,
- missing_wbin_COMIDs),
- fill = TRUE) %>%
- select(COMID, wb_id)
- }
- }
-
- wbin_POIs <- POI_creation(filter(st_drop_geometry(wbin_COMIDs), !COMID %in% wbout_COMIDs$COMID),
- nhd, "WBIn")
-
- # Get NHDArea and HR waterbodies
- WBs_VPU_areaHR <- HR_Area_coms(nhd,
- filter(wb_lyr, source == "HR ID AVAILABLE"),
- data_paths, crs)
-
- if(is.list(WBs_VPU_areaHR)) {
- nhd_WBs <- filter(nhd, minNet == 1,
- COMID %in% WBs_VPU_areaHR$nhd_wb_table$comid,
- AreaSqKM > 0)
- } else {
- nhd_WBs <- NA
- }
-
- if(is.data.frame(nhd_WBs)){
-
- # Get the outlet events again
- wb_outlet_events <- read_sf(temp_gpkg, split_layer) %>%
- filter(event_type == "outlet")
-
- # Drive the inlet events
- nhd_inlet <- filter(nhd_WBs, !COMID %in% wb_outlet_events$COMID)
-
- if("12" %in% unique(nhd$VPUID)){
- nhd_inlet <- rbind(nhd_inlet, filter(nhd_WBs, COMID == 1304709))
- }
-
- if (nrow(nhd_inlet) > 0){
- # Get inlet events and bind with outlets
- wb_inlet_events <- WB_event(WBs_VPU_areaHR, nhd_inlet, "inlet") %>%
- mutate(nexus = TRUE) %>%
- inner_join(select(st_drop_geometry(nhd), COMID, Hydroseq, ToMeas), by = "COMID")
-
- # Determine which events are close enough to the end of an upstream flowline to just use that geometry for the POI
- wbin_fl_upstream <- filter(nhd, DnHydroseq %in% filter(nhd, COMID %in% wb_inlet_events$COMID)$Hydroseq) %>%
- group_by(DnHydroseq) %>%
- filter(n() == 1) %>%
- ungroup()
-
- if(nrow(wbin_fl_upstream) > 0){
-
- wb_inlet_POIs <- filter(wb_inlet_events, REACH_meas < 5 | as.integer(REACH_meas) == as.integer(ToMeas),
- COMID %in% wbin_fl_upstream$toCOMID) %>%
- inner_join(select(st_drop_geometry(wbin_fl_upstream), usCOMID = COMID, toCOMID), by = c("COMID" = "toCOMID")) %>%
- mutate(dsCOMID = COMID, COMID = usCOMID)
-
- if(nrow(wb_inlet_POIs) > 0) {
- wbin_POIs <- bind_rows(wbin_POIs, POI_creation(select(st_drop_geometry(wb_inlet_POIs), dsCOMID,
- Type_WBIn = POI_identifier),
- nhd, "WBIn"))
-
- wb_inlet_events <- filter(wb_inlet_events, !COMID %in% wb_inlet_POIs$dsCOMID)
- }
- }
-
- if(nrow(wb_inlet_events) > 0){
-
- wbin_POIs <- addType(wbin_POIs, tmp_POIs, "WBIn", nexus = TRUE)
- wb_inlet_events <- st_compatibalize(wb_inlet_events, wbin_POIs)
- wbin_POIs_fin <- data.table::rbindlist(list(wbin_POIs,
- select(wb_inlet_events, COMID,
- Type_WBIn = POI_identifier, nexus)),
- fill = TRUE) %>%
- st_as_sf()
- }
-
- return(list(POIs = wbin_POIs_fin, events = wb_inlet_events))
- } else {
- print("no waterbody inlets events")
- wbin_POIs <- addType(wbin_POIs, tmp_POIs, "WBIn")
- return(list(POIs = wbin_POIs, events = NA))
- }
- } else {
- wbin_POIs <- addType(wbin_POIs, tmp_POIs, "WBIn")
- return(list(POIs = wbin_POIs, events = NA))
- }
-
-}
-
-
-#' collapses close upstream gages with wb inlet events.
-#' @param temp_POIs (sf data.frame) rolling POI data frame
-#' @param nhd (sf data.frame) nhd flowlines
-#' @param events (list) waterbody inlet events
-#'
-#' @return (sf data.frame) dataframe of gage POIs
-#'
-wb_inlet_collapse <- function(tmp_POIs, nhd, events){
- gage_dist_node <- function(x, wb_ds_ds, gage_add, events){
- print (x)
- wb_in_fl <- filter(wb_ds_ds, COMID == x)
- gage_ds <- filter(wb_ds_ds, Hydroseq %in% wb_in_fl$Hydroseq |
- Hydroseq %in% wb_in_fl$DnHydroseq) %>%
- filter(TotDASqKM == max(TotDASqKM))
-
- gage_reach <- gage_ds %>%
- group_by(REACHCODE) %>%
- summarize(do_union = TRUE,
- total_length = sum(LENGTHKM))
-
- #print(nrow(gage_reach))
- gage_event <- filter(gage_add, COMID %in% gage_ds$COMID)
- wb_event <- filter(events, COMID == x, event_type == "inlet") %>%
- unique()
-
- if(nrow(gage_reach) == 0){
- print("no gage reaches")
- }
-
- if(nrow(gage_event) == 0){
- return("No gage events")
- } else if(gage_event$COMID != wb_in_fl$COMID) {
- gage_reach <- gage_reach %>%
- filter(REACHCODE == gage_event$reachcode) %>%
- mutate(gage_dist = ifelse(gage_event$nexus == TRUE,
- total_length * (1 - (gage_event$reach_meas/100)),
- total_length)) %>%
- mutate(gage_comid = gage_event$COMID,
- wbin_comid = x)
- } else if(gage_event$COMID == wb_in_fl$COMID){
- if(nrow(wb_event) >0){
- wb_in_meas <- wb_event$REACH_meas
- wb_RC <- wb_event$REACHCODE
- } else {
- wb_out_meas <- wb_in_fl$FromMeas
- wb_RC <- wb_in_fl$REACHCODE
- }
-
- # gage reach
- gage_reach <- gage_reach %>%
- filter(REACHCODE == gage_event$reachcode) %>%
- mutate(gage_dist = total_length * (1 - (gage_event$reach_meas/100)))
-
- # wb info
- wb_reach <- gage_reach %>%
- filter(REACHCODE == wb_RC) %>%
- mutate(wb_dist = total_length * (1 - (wb_out_meas /100)))
-
- gage_reach <- gage_reach %>%
- mutate(gage_dist = abs(wb_reach$wb_dist - gage_dist),
- gage_comid = gage_event$COMID,
- wbin_comid = x)
- }
- }
-
- #events <- read_sf(temp_gpkg, split_layer) %>%
- # rbind(st_compatibalize(wb_,.))
-
- # Previously identified streamgages within Gage_Selection.Rmd
- streamgages_VPU <- gages %>%
- rename(COMID = comid) %>%
- filter(COMID %in% nhd$COMID) %>%
- #st_drop_geometry() %>%
- switchDiv(., nhd)
-
- # get waterbody outlets
- wb_in <- filter(tmp_POIs, !is.na(Type_WBIn), is.na(Type_Gages))
-
- wb_in_nexus <- filter(wb_in, nexus == TRUE)
- wb_in_nhd <- filter(nhd, COMID %in% wb_in$COMID)
- wb_ds_ds <- wb_in_nhd %>%
- rbind(filter(nhd, LevelPathI %in% .$LevelPathI & DnHydroseq %in% .$Hydroseq)) %>%
- distinct()
-
- # get gages
- gage_wb <- filter(tmp_POIs, !is.na(Type_Gages) & is.na(Type_WBIn)) #%>%
- # filter(COMID %in% wb_ds_ds$COMID)
- #gage_nhd <- filter(nhd, COMID %in% gage_wb$COMID)
- #gage_node <- filter(gage_wb, nexus == FALSE)
- #gage_nexus <- filter(gage_wb, nexus == TRUE)
-
- gage_add <- filter(streamgages_VPU, site_no %in% gage_wb$Type_Gages) %>%
- select(COMID, reachcode, reach_meas, site_no) %>%
- inner_join(select(st_drop_geometry(gage_wb), site_no = Type_Gages, nexus),
- by = "site_no") %>%
- filter(!nexus)
-
- output <- lapply(wb_in$COMID,
- gage_dist_node, wb_ds_ds, gage_add, events)
-
- output_full <- do.call("rbind", output[lengths(output) > 1])
-
- if(!is.null(output_full)){
- output_full <- output_full %>%
- filter(gage_dist < 1) %>%
- left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_WB = TotDASqKM),
- by = c("wbin_comid" = "COMID")) %>%
- left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_gage = TotDASqKM),
- by = c("gage_comid" = "COMID")) %>%
- mutate(DAR = TotDASqKM_gage / TotDASqKM_WB) %>%
- filter(gage_dist < 1, DAR > .975) %>%
- st_drop_geometry()
-
- gage_POI <- filter(tmp_POIs, COMID %in% output_full$gage_comid) %>%
- select(COMID, Type_HUC12_ds = Type_HUC12, Type_Gages_ds = Type_Gages,
- Type_TE_ds = Type_TE, Type_Term_ds = Type_Term, nexus) %>%
- st_drop_geometry() %>%
- group_by(COMID) %>%
- summarise(Type_HUC12_ds = last(na.omit(Type_HUC12_ds)),
- Type_Gages_ds = last(na.omit(Type_Gages_ds)),
- Type_Term_ds = last(na.omit(Type_Term_ds)),
- Type_TE_ds = last(na.omit(Type_TE_ds)),
- nexus = last(na.omit(nexus)))
-
- WB_POI <- filter(tmp_POIs, COMID %in% output_full$wbin_comid, !is.na(Type_WBIn)) %>%
- left_join(select(output_full, gage_comid, wbin_comid), by = c("COMID" = "wbin_comid")) %>%
- left_join(select(gage_POI, -nexus), by = c("gage_comid" = "COMID")) %>%
- mutate(Type_HUC12 = ifelse(!is.na(Type_HUC12_ds), Type_HUC12_ds, Type_HUC12),
- Type_Gages = ifelse(!is.na(Type_Gages_ds), Type_Gages_ds, Type_Gages),
- Type_TE = ifelse(!is.na(Type_TE_ds), Type_TE_ds, Type_TE),
- Type_Term = ifelse(!is.na(Type_Term_ds), Type_Term_ds, Type_Term)) %>%
- select(-c(Type_HUC12_ds, Type_Gages_ds, Type_TE_ds, Type_Term_ds))
-
- tmp_POIs_fin <- filter(tmp_POIs, !COMID %in% c(WB_POI$COMID, WB_POI$gage_comid)) %>%
- rbind(select(WB_POI, -gage_comid))
-
- if(any(gage_POI$nexus == TRUE)){
- gage_events <- filter(gage_POI, nexus == TRUE)
- events <- filter(events, !POI_identifier %in% gage_events$Type_Gages_ds)
- }
- return(list(POIs = tmp_POIs_fin, events_ret = events))
- } else {
- print ("no points collapse")
- return(list(POIs = tmp_POIs, events_ret = NA))
- }
-}
-
-#' Collapses POIs us/ds of waterbody POIs
-#' @param (sf data.frame) rolling POI data frame
-#' @param nhd (sf data.frame) nhd flowlines
-#' @param events (sf data.frame) waterbody events
-#'
-#' @return (sf data.frame) dataframe of wb inlet POIs collapsed
-wb_poi_collapse <- function(tmp_POIs, nhd, events){
- gage_dist_node <- function(x, wb_ds_ds, gage_add, events){
- print (x)
- wb_out_fl <- distinct(filter(wb_ds_ds, COMID == x))
- gage_ds <- filter(wb_ds_ds, Hydroseq %in% wb_out_fl$Hydroseq |
- Hydroseq %in% wb_out_fl$DnHydroseq)
-
- gage_reach <- gage_ds %>%
- group_by(REACHCODE) %>%
- summarize(do_union = TRUE,
- total_length = sum(LENGTHKM))
-
- #print(nrow(gage_reach))
- gage_event <- filter(gage_add, COMID %in% gage_ds$COMID) %>%
- filter(reach_meas == min(reach_meas))
- wb_event <- filter(events, COMID == x, event_type == "outlet") %>%
- unique()
-
- if(nrow(gage_reach) == 0){
- print("no gages")
- }
-
- if(nrow(gage_event) == 0){
- return("no events")
- } else if(gage_event$COMID != wb_out_fl$COMID) {
- gage_reach <- gage_reach %>%
- filter(REACHCODE == unique(gage_event$reachcode)) %>%
- mutate(gage_dist = ifelse(gage_event$nexus == TRUE,
- total_length * (1 - (gage_event$reach_meas/100)),
- total_length)) %>%
- mutate(gage_comid = gage_event$COMID,
- wbout_comid = x)
- } else if(gage_event$COMID == wb_out_fl$COMID){
- if(nrow(wb_event) >0){
- wb_out_meas <- min(wb_event$REACH_meas)
- wb_RC <- wb_event$REACHCODE
- } else {
- wb_out_meas <- min(wb_out_fl$FromMeas)
- wb_RC <- wb_out_fl$REACHCODE
- }
-
- # gage reach
- gage_reach <- gage_reach %>%
- filter(REACHCODE == gage_event$reachcode) %>%
- mutate(gage_dist = total_length * (1 - (gage_event$reach_meas/100)))
-
- # wb info
- wb_reach <- gage_reach %>%
- filter(REACHCODE == unique(wb_RC)) %>%
- mutate(wb_dist = total_length * (1 - (wb_out_meas /100)))
-
- gage_reach <- gage_reach %>%
- mutate(gage_dist = abs(wb_reach$wb_dist - gage_dist),
- gage_comid = gage_event$COMID,
- wbout_comid = x)
- }
- }
-
- # Previously identified streamgages within Gage_Selection.Rmd
- streamgages_VPU <- gages %>%
- rename(COMID = comid) %>%
- filter(COMID %in% nhd$COMID) %>%
- switchDiv(., nhd)
-
- # get waterbody outlets
- wb_out <- filter(tmp_POIs, !is.na(Type_WBOut), is.na(Type_Gages))
-
- wb_out_nexus <- filter(wb_out, nexus)
- wb_out_nhd <- filter(nhd, COMID %in% wb_out$COMID)
- wb_ds_ds <- wb_out_nhd %>%
- rbind(filter(nhd, LevelPathI %in% .$LevelPathI & Hydroseq %in% .$DnHydroseq))
-
- # get gages
- gage_wb <- filter(tmp_POIs, !is.na(Type_Gages) & is.na(Type_WBOut)) #%>%
- # filter(COMID %in% wb_ds_ds$COMID)
- #gage_nhd <- filter(nhd, COMID %in% gage_wb$COMID)
- #gage_node <- filter(gage_wb, nexus == FALSE)
- #gage_nexus <- filter(gage_wb, nexus == TRUE)
-
- gage_add <- filter(streamgages_VPU, site_no %in% gage_wb$Type_Gages) %>%
- select(COMID, reachcode, reach_meas, site_no) %>%
- inner_join(select(st_drop_geometry(gage_wb), site_no = Type_Gages, nexus),
- by = "site_no") %>%
- distinct()
-
- # 8693865
- output <- lapply(wb_out$COMID,
- gage_dist_node, wb_ds_ds, gage_add, events)
- output_length <- output[lengths(output) > 1]
-
- if(length(output_length) == 0){
- return(list(POIs = tmp_POIs, events_ret = NA))
- }
-
- output_full <- do.call("rbind", output[lengths(output) > 1]) %>%
- filter(gage_dist < 1) %>%
- left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_WB = TotDASqKM),
- by = c("wbout_comid" = "COMID")) %>%
- left_join(select(st_drop_geometry(nhd), COMID, TotDASqKM_gage = TotDASqKM),
- by = c("gage_comid" = "COMID")) %>%
- mutate(DAR = TotDASqKM_WB / TotDASqKM_gage) %>%
- filter(gage_dist < 1, DAR > .975) %>%
- st_drop_geometry()
-
- gage_POI <- filter(tmp_POIs, COMID %in% output_full$gage_comid) %>%
- select(COMID, Type_HUC12_ds = Type_HUC12, Type_Gages_ds = Type_Gages,
- Type_TE_ds = Type_TE, nexus) %>%
- st_drop_geometry() %>%
- group_by(COMID) %>%
- summarise(Type_HUC12_ds = last(na.omit(Type_HUC12_ds)),
- Type_Gages_ds = last(na.omit(Type_Gages_ds)),
- Type_TE_ds = last(na.omit(Type_TE_ds)),
- nexus = last(na.omit(nexus)))
-
- WB_POI <- filter(tmp_POIs, COMID %in% output_full$wbout_comid, !is.na(Type_WBOut)) %>%
- inner_join(select(output_full, gage_comid, wbout_comid), by = c("COMID" = "wbout_comid")) %>%
- inner_join(select(gage_POI, -nexus), by = c("gage_comid" = "COMID")) %>%
- mutate(Type_HUC12 = ifelse(!is.na(Type_HUC12_ds), Type_HUC12_ds, Type_HUC12),
- Type_Gages = ifelse(!is.na(Type_Gages_ds), Type_Gages_ds, Type_Gages),
- Type_TE = ifelse(!is.na(Type_TE_ds), Type_TE_ds, Type_TE)) %>%
- select(-c(Type_HUC12_ds, Type_Gages_ds, Type_TE_ds))
-
- tmp_POIs_fin <- filter(tmp_POIs, !COMID %in% c(WB_POI$COMID, WB_POI$gage_comid)) %>%
- rbind(select(WB_POI, -gage_comid))
-
- if(any(gage_POI$nexus == TRUE)){
- gage_events <- filter(gage_POI, nexus == TRUE)
- events <- filter(events, !POI_identifier %in% gage_events$Type_Gages_ds)
- }
-
-
- return(list(POIs = tmp_POIs_fin, events_ret = events))
-}
-
-#' Collapses POIs together based on criteria
-#' @param (pois) sf data frame of POIs
-#' @param move_category (character) POI data theme to move
-#' @param DAR (numeric) drainage area threshold to move within
-#' @param dist (numeric) maximum river distance between two points to move within
-#' @param keep_category (character) POI data themes to keep static
-#'
-#' @return (sf data.frame, table) dataframe of pois, table of points that have moved
-poi_move <- function(pois, move_category, DAR, dist, keep_category) {
- # filter out features with identical geometry
-
- # Add row_number
- pois_edit <- pois %>%
- mutate(nexus = ifelse(is.na(nexus), 0, nexus))
-
- # Don't consider points already moved
- if("moved" %in% colnames(pois_edit)){
- pois_tomove <- filter(pois_edit, is.na(moved)) # change from poi_edit
- pois_moved_pre <- filter(pois_edit, !is.na(moved))}
-
- # If 'keep' category included
- if(!missing(keep_category)){
- poi2move <- filter(pois_tomove, !is.na(.data[[move_category]]) & nexus == FALSE) %>%
- filter(if_all(!!as.symbol(keep_category), function(x) is.na(x))) %>%
- # Never move these
- filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_Term), all_vars(is.na(.)))
-
- pois2keep <- filter(pois_tomove, !id %in% poi2move$id)
- #is.na(.data[[move_category]]) & nexus == FALSE) #%>%
- #filter(if_all(!!as.symbol(keep_category), function(x) is.na(x)))
- } else {
- # POIs to move
- poi2move <- pois_tomove %>%
- filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_Term), all_vars(is.na(.))) %>%
- filter(nexus == 0) %>%
- filter(!is.na(.data[[move_category]]))
-
- pois2keep <- filter(pois_tomove, !id %in% poi2move$id)
- }
-
- # Get relevant NHD data
- nhd_poi1 <- filter(nhd, COMID %in% pois2keep$COMID)
- nhd_poi2 <- filter(nhd, COMID %in% poi2move$COMID)
- # Ensure they are on same level path
- nhd_poi2 <- filter(nhd_poi2, LevelPathI %in% nhd_poi1$LevelPathI)
-
- # Join NHD data
- pois2keep_nhd <- pois2keep %>%
- inner_join(select(st_drop_geometry(nhd_poi1), COMID, LevelPathI, Hydroseq,
- DA_keep = TotDASqKM, Pathlength_keep = Pathlength), by = "COMID") %>%
- rename(COMID_keep = COMID)
-
- # Join NHD data
- pois2move_nhd <- select(poi2move, COMID, !!as.symbol(move_category), id_move = id) %>%
- inner_join(select(st_drop_geometry(nhd_poi2), COMID, LevelPathI, Hydroseq, TotDASqKM, Pathlength),
- by = "COMID")
-
- # Candidates to move
- pois2move_cand <-pois2move_nhd %>%
- inner_join(select(st_drop_geometry(pois2keep_nhd), COMID_keep, DA_keep, LevelPathI,
- Pathlength_keep, id_keep = id, nexus),
- by = "LevelPathI") %>%
- mutate(river_dist = abs(Pathlength - Pathlength_keep), DAR_poi = abs(DA_keep/TotDASqKM),
- move_dir = ifelse(Pathlength < Pathlength_keep, "Up", "Down")) %>%
- group_by(id_move, move_dir) %>%
- ungroup() %>%
- filter((river_dist < dist) & (DAR_poi > (1 - DAR)) & (DAR_poi < (1 + DAR))) %>%
- select(!!as.symbol(move_category), id_move, COMID, id_keep, COMID_keep, river_dist, DAR_poi, move_dir, nexus) %>%
- st_drop_geometry()
-
- move_distinct <- pois2move_cand %>%
- group_by(id_keep) %>%
- filter(row_number() == 1) %>%
- ungroup() %>%
- distinct(id_move, COMID_move = COMID, id_keep, COMID_keep, river_dist, DAR_poi, move_dir, nexus) %>%
- group_by(id_move) %>%
- slice(which.min(abs(1 - DAR_poi)))
-
- if(nrow(move_distinct) == 0){
- print("no POIs to move")
- return(pois)
- }
-
- pois2_move <- filter(st_drop_geometry(pois_tomove), id %in% move_distinct$id_move) %>%
- select_if(~sum(!is.na(.)) > 0) %>%
- select(-c(COMID, nexus)) %>%
- inner_join(select(move_distinct, id_move, id_keep), by = c("id" = "id_move"))
-
- move_fields <- colnames(select(pois2_move, -c(id, id_keep)))
-
- if(length(move_fields) == 1){
- pois2_keep <- filter(pois_tomove, id %in% pois2_move$id_keep, !id %in% pois2_move$id) %>%
- inner_join(select(pois2_move, id_move = id, id_keep,
- new_val = !!as.symbol(move_category)), by = c("id" = "id_keep")) %>%
- mutate(moved := ifelse(is.na(!!as.symbol(move_category)),
- id_move, moved),
- !!as.symbol(move_category) := ifelse(is.na(!!as.symbol(move_category)),
- new_val, !!as.symbol(move_category)))
-
- moved_points <- filter(pois2_keep, !is.na(new_val), !is.na(moved)) %>%
- mutate(moved_value = move_category)
- } else {
- for (field in move_fields){
- pois2_keep <- filter(pois_tomove, id %in% pois2_move$id_keep, !id %in% pois2_move$id) %>%
- inner_join(select(pois2_move, id_move = id, id_keep, new_val = !!as.symbol(field)),
- by = c("id" = "id_keep")) %>%
- mutate(moved := ifelse(is.na(!!as.symbol(field)),
- id_move, moved),
- !!as.symbol(field) := ifelse(is.na(!!as.symbol(field)),
- new_val, !!as.symbol(field)))
-
- pois_moved <- filter(pois2_keep, !is.na(new_val), !is.na(moved)) %>%
- mutate(moved_value = field)
-
- if(!exists("moved_points")){
- moved_points <- pois_moved
- } else {
- moved_points <- rbind(moved_points, pois_moved)
- }
- }
- }
-
-
- pois_final <- data.table::rbindlist(list(filter(pois_edit, !id %in% c(moved_points$id_move, pois2_keep$id)),
- select(pois2_keep, -c(new_val, id_move, new_val))), fill = TRUE) %>%
- st_as_sf()
-
- return(list(final_pois = pois_final, moved_points = moved_points))
-
-}
-
-
-att_group <- function(a, athres) {
- #cumsum <- 0
- group <- 1
- result <- numeric()
- for (i in 1:length(a)) {
- #cumsum <- cumsum + a[i]
- tot_DA <- a[i]
- if (tot_DA > athres) {
- group <- group + 1
- athres <- athres + athres
- }
- result = c(result, group)
- }
- return (result)
-}
-
-cs_group <- function(a, athres) {
- cumsum <- 0
- group <- 1
- result <- numeric()
- for (i in 1:length(a)) {
- cumsum <- cumsum + a[i]
- if (cumsum > athres) {
- group <- group + 1
- cumsum <- a[i]
- }
- result = c(result, group)
- }
- return (result)
-}
diff --git a/workspace/R/config.R b/workspace/R/config.R
index 3ebfd9c94e6354e1d04f7c99ea44770a13641748..1af3f6142047458ef7b63e3caad2b62b15d9e1b2 100644
--- a/workspace/R/config.R
+++ b/workspace/R/config.R
@@ -1,64 +1,53 @@
-library(nhdplusTools)
-library(dplyr)
-library(sf)
-library(hyRefactor)
-library(tidyr)
-library(hyfabric)
-library(mapview)
-library(terra)
-library(sbtools)
-library(jsonlite)
-library(fst)
-
-rpu_vpu <- readr::read_csv(system.file("extdata/rpu_vpu.csv", package = "hyfabric"),
- show_col_types = FALSE)
-rpu_vpu_out <- readr::read_csv("cache/rpu_vpu_out.csv",
- col_types = c("c", "c", "i" , "i"), show_col_types = FALSE)
-
-if(nchar(Sys.getenv("HYDREG")) > 1) {
- vpu_codes <- Sys.getenv("HYDREG")
-}
-
-if(!exists("rpu_codes")) {
- if(exists("vpu_codes")) {
- rpu_codes <- rpu_vpu[rpu_vpu$vpuid %in% vpu_codes, ]
- rpu_code <- rpu_codes$rpuid[1]
- } else {
- vpu_codes <- get_rpu_dependent_vars()
- rpu_code <- vpu_codes$r
- vpu_codes <- vpu_codes$v
- rpu_codes <- rpu_vpu[rpu_vpu$vpuid %in% vpu_codes, ]
- }
-}
-
-if(!exists("vpu_codes")) {
- vpu_codes <- get_rpu_dependent_vars(rpu_code)$v
-}
-
-if(!nchar(out_agg_gpkg <- Sys.getenv("OUT_GPKG")) > 5)
- out_agg_gpkg <- file.path("cache", paste0(rpu_code, "_aggregate.gpkg"))
-
-if(!nchar(out_refac_gpkg <- Sys.getenv("OUT_REFACTOR_GPKG")) > 5)
- out_refac_gpkg <- file.path("cache", paste0(rpu_code, "_refactor.gpkg"))
-
-if(!nchar(cache_split <- Sys.getenv("CACHE_SPLIT")) > 5)
- cache_split <- file.path("temp", paste0(rpu_code, ".rda"))
-
-if(!nchar(lookup_table_file <- Sys.getenv("LOOKUP_TABLE")) > 5)
- lookup_table_file <- file.path("cache", paste0(rpu_code, "_lookup.csv"))
-
-if(!nchar(vpu_lookup_table_file <- Sys.getenv("VPU_LOOKUP_TABLE")) > 5)
- vpu_lookup_table_file <- file.path("cache", paste0("lookup_", vpu_codes, ".csv"))
+# rpu_vpu <- readr::read_csv(system.file("extdata/rpu_vpu.csv", package = "hyfabric"),
+# show_col_types = FALSE)
+# rpu_vpu_out <- readr::read_csv("cache/rpu_vpu_out.csv",
+# col_types = c("c", "c", "i" , "i"), show_col_types = FALSE)
+
+# # The below deals with various ways to get / set rpu and vpu codes
+# # based on the rpu_vpu table.
+# # if a HYDREG environment variable is set, use it
+# if(nchar(Sys.getenv("HYDREG")) > 1) {
+# vpu_codes <- Sys.getenv("HYDREG")
+# }
+#
+# # if rpu_codes hasn't been set globally, try to set it.
+# if(!exists("rpu_codes")) {
+# # if vpu_codes has been set we can get rpu based on that.
+# if(exists("vpu_codes")) {
+# rpu_codes <- rpu_vpu[rpu_vpu$vpuid %in% vpu_codes, ]
+# rpu_code <- rpu_codes$rpuid[1]
+# } else {
+# # then get the default
+# vpu_codes <- get_rpu_dependent_vars()
+# rpu_code <- vpu_codes$r
+# vpu_codes <- vpu_codes$v
+# rpu_codes <- rpu_vpu[rpu_vpu$vpuid %in% vpu_codes, ]
+# }
+# }
+#
+# # if vpu_codes still doesn't exist, set it based on the rpu_code.
+# if(!exists("vpu_codes")) {
+# vpu_codes <- get_rpu_dependent_vars(rpu_code)$v
+# }
+#
+# if(!nchar(out_agg_gpkg <- Sys.getenv("OUT_GPKG")) > 5)
+# out_agg_gpkg <- file.path("cache", paste0(rpu_code, "_aggregate.gpkg"))
+#
+# if(!nchar(out_refac_gpkg <- Sys.getenv("OUT_REFACTOR_GPKG")) > 5)
+# out_refac_gpkg <- file.path("cache", paste0(rpu_code, "_refactor.gpkg"))
+#
+# if(!nchar(cache_split <- Sys.getenv("CACHE_SPLIT")) > 5)
+# cache_split <- file.path("temp", paste0(rpu_code, ".rda"))
+#
+# if(!nchar(lookup_table_file <- Sys.getenv("LOOKUP_TABLE")) > 5)
+# lookup_table_file <- file.path("cache", paste0(rpu_code, "_lookup.csv"))
+#
+# if(!nchar(vpu_lookup_table_file <- Sys.getenv("VPU_LOOKUP_TABLE")) > 5)
+# vpu_lookup_table_file <- file.path("cache", paste0("lookup_", vpu_codes, ".csv"))
options(scipen = 9999)
-# Source Data
-data_paths <- jsonlite::read_json(file.path("cache", "data_paths.json"))
-
-#nhdplus_path(data_paths$nhdplus_gdb)
-#suppressWarnings(staged_nhd <- stage_national_data())
-
# Defined and used broadly
nhd_flowline <- "reference_flowline"
nhd_catchment <- "reference_catchment"
@@ -73,13 +62,13 @@ s_per_hr <- 3600 # seconds per hour
# Intermediate layers created during 02_Navigate
xwalk_layer <- paste0("HUC12_nhd") # HUC12 - nhdcat crosswalk, built in Nav for VPU 20
-nav_poi_layer <- paste0("POIs_tmp_", vpu_codes) # Rolling Nav POI layer added to/modified througout nav workflow
-WBs_layer <- paste0("WB_", vpu_codes) # Waterbodies within VPU
-WB_events_layer <- paste0("WB_events_", vpu_codes) # inlet and outlet events for NHDArea and HR waterbodies
-poi_moved_layer <- paste0("POIs_mv_", vpu_codes) # POIs moved from original COMID assignment
-nsegments_layer <- paste0("nsegment_", vpu_codes) # Minimally-sufficient network dissolved by POI_ID
-pois_all_layer <- paste0("POIs_", vpu_codes) # All POIs binded together
-poi_xwalk_layer <- paste0("poi_xwalk_layer_", vpu_codes) # POIs that changed COMIDS during the navigate part of the workflow
+# nav_poi_layer <- paste0("POIs_tmp_", vpu_codes) # Rolling Nav POI layer added to/modified througout nav workflow
+# WBs_layer <- paste0("WB_", vpu_codes) # Waterbodies within VPU
+# WB_events_layer <- paste0("WB_events_", vpu_codes) # inlet and outlet events for NHDArea and HR waterbodies
+# poi_moved_layer <- paste0("POIs_mv_", vpu_codes) # POIs moved from original COMID assignment
+# nsegments_layer <- paste0("nsegment_", vpu_codes) # Minimally-sufficient network dissolved by POI_ID
+# pois_all_layer <- paste0("POIs_", vpu_codes) # All POIs binded together
+# poi_xwalk_layer <- paste0("poi_xwalk_layer_", vpu_codes) # POIs that changed COMIDS during the navigate part of the workflow
final_poi_layer <- "POIs"
dup_pois <- "dup_POIs"
@@ -102,14 +91,15 @@ mapped_outlets_layer <- "mapped_POIs"
lookup_table_refactor <- "lookup_table"
catchment_network_table <- "catchment_network"
-# output geopackage file names
-ref_gpkg <- file.path(data_paths$ref_fab_path, paste0(vpu_codes, "_reference_features.gpkg"))
-nav_gpkg <- file.path("cache", paste0("reference_", vpu_codes,".gpkg"))
-temp_gpkg <- file.path("cache", paste0("nav_", vpu_codes,".gpkg"))
-
-rfc_gpkg <- file.path("cache", paste0("refactor_", vpu_codes, ".gpkg"))
-
-gf_gpkg <- file.path("cache", paste0("GF_", vpu_codes, ".gpkg"))
+# # output geopackage file names
+# ref_gpkg <- file.path(jsonlite::read_json("cache/data_paths.json")$ref_fab_path,
+# paste0(vpu_codes, "_reference_features.gpkg"))
+# nav_gpkg <- file.path("cache", paste0("reference_", vpu_codes,".gpkg"))
+# temp_gpkg <- file.path("cache", paste0("nav_", vpu_codes,".gpkg"))
+#
+# rfc_gpkg <- file.path("cache", paste0("refactor_", vpu_codes, ".gpkg"))
+#
+# gf_gpkg <- file.path("cache", paste0("GF_", vpu_codes, ".gpkg"))
gf_gpkg_conus <- "cache/reference_CONUS.gpkg"
gage_info_gpkg <- "cache/Gages_info.gpkg"
@@ -117,7 +107,7 @@ gage_info_csv <- "cache/Gages_info.csv"
gage_info_csvt <- "cache/Gages_info.csvt"
# Defined during NonDend.Rmd
-ND_gpkg <- file.path("temp", paste0("ND_", vpu_codes,".gpkg"))
+# ND_gpkg <- file.path("temp", paste0("ND_", vpu_codes,".gpkg"))
divides_xwalk <- "divides_nhd"
HRU_layer <- "all_cats"
diff --git a/workspace/R/poi_move.R b/workspace/R/poi_move.R
deleted file mode 100644
index ebfdd7a06530d5af3f1fa65318f8be33ebbed02d..0000000000000000000000000000000000000000
--- a/workspace/R/poi_move.R
+++ /dev/null
@@ -1,119 +0,0 @@
-## TODO: document this file!
-
-# Load data
-if(collapse){
-
- # Move HUC12 to other POIs
- moved_pois <- poi_move(final_POIs_prec, "Type_HUC12", poi_dar_move,
- poi_distance_move)
-
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois$moved_points %>%
- mutate(move_type = "huc12 to other")
- } else {
- final_POIs <- moved_POIs
- }
-
- # Gages to confluences, terminals
- moved_pois <- poi_move(final_POIs, "Type_Gages", poi_dar_move,
- poi_distance_move, c("Type_Conf", "Type_Term"))
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "gages to conf"))
- } else {
- final_POIs <- moved_POIs
- }
-
- # Gages to waterbody inlets
- moved_pois <- poi_move(final_POIs, "Type_Gages", poi_dar_move,
- poi_distance_move, c("Type_WBIn", "Type_WBOut"))
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "gages to wbin"))
- } else {
- final_POIs <- moved_pois
- }
-
- # Waterbody inlet to confluence
- moved_pois <- poi_move(final_POIs, "Type_WBIn", poi_dar_move/2,
- poi_distance_move*0.4, "Type_Conf")
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "gages to term"))
- } else {
- final_POIs <- moved_pois
- }
-
- # # Waterbody inlet to confluence
- # moved_pois <- poi_move(final_POIs, "Type_WBOut", poi_dar_move/2,
- # poi_distance_move*0.4, "Type_WBIn")
- # if(!is.data.frame(moved_pois)){
- # final_POIs <- moved_pois$final_pois
- # moved_pois_table <- moved_pois_table %>%
- # rbind(moved_pois$moved_points %>%
- # mutate(move_type = "gages to term"))
- # } else {
- # final_POIs <- moved_pois
- # }
-
- # Waterbody inlet to confluence
- moved_pois <- poi_move(final_POIs, c("Type_WBIn", "Type_HUC12"), poi_dar_move/2,
- poi_distance_move*0.4, "Type_Conf")
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "gages to term"))
- } else {
- final_POIs <- moved_pois
- }
-
- # NID to waterbody outlet
- moved_pois <- poi_move(final_POIs, "Type_hilarri", poi_dar_move/2,
- poi_distance_move * 0.4, c("Type_WBOut", "Type_TE"))
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "nid to wb_out"))
- } else {
- final_POIs <- moved_pois
- }
-
- # NID to waterbody outlet
- moved_pois <- poi_move(final_POIs, "Type_DA", poi_dar_move,
- poi_distance_move)
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "nid to wb_out"))
- } else {
- final_POIs <- moved_pois
- }
-
- if("Type_elev" %in% names(final_POIs)){
- # NID to waterbody outlet
- moved_pois <- poi_move(final_POIs, "Type_elev", poi_dar_move,
- poi_distance_move)
- if(!is.data.frame(moved_pois)){
- final_POIs <- moved_pois$final_pois
- moved_pois_table <- moved_pois_table %>%
- rbind(moved_pois$moved_points %>%
- mutate(move_type = "nid to wb_out"))
- } else {
- final_POIs <- moved_pois
- }
- }
-
-
- write_sf(final_POIs, nav_gpkg, pois_all_layer)
- write_sf(moved_pois_table, temp_gpkg, "pois_collapsed")
-}
\ No newline at end of file
diff --git a/workspace/R/utils.R b/workspace/R/utils.R
index 7e495b2f0ae3c464ef06f750ed105876da8c7b3b..268fb72c75c1126c5ea431e7ec98866d8db97dcb 100644
--- a/workspace/R/utils.R
+++ b/workspace/R/utils.R
@@ -27,7 +27,7 @@ check_auth <- function(){
#' @param reason (character) reason gage is excluded
#' @return writes output to file
#'
-gage_document <- function(data, source, drop_reason){
+document_dropped_gage <- function(data, source, drop_reason){
if(!file.exists("cache/dropped_gages.csv")){
write.csv(data %>% mutate(data_source = source, reason = drop_reason),
"cache/dropped_gages.csv", quote = F, row.names = F)
@@ -151,225 +151,6 @@ merge_conus <- function(rpu_vpu, rpu_vpu_out,
}
-
-
-merge_refactor <- function(rpus,
- rpu_vpu_out,
- lookup_table_refactor,
- reconciled_layer,
- divide_layer,
- split_divide_layer,
- agg_fline_layer,
- agg_cats_layer,
- mapped_outlets_layer) {
-
-
- out <- rep(list(list()), length(rpus))
- names(out) <- rpus
-
- s <- 10000000
-
- for(rpu in rpus) {
- print(rpu)
-
- refactor_gpkg <- file.path("cache", paste0(rpu, "_refactor.gpkg"))
- aggregate_gpkg <- file.path("cache", paste0(rpu, "_aggregate.gpkg"))
-
- out[[rpu]] <- setNames(list(sf::read_sf(aggregate_gpkg, lookup_table_refactor),
- sf::read_sf(refactor_gpkg, reconciled_layer),
- sf::read_sf(refactor_gpkg, divide_layer),
- sf::read_sf(refactor_gpkg, split_divide_layer),
- sf::read_sf(aggregate_gpkg, agg_fline_layer),
- sf::read_sf(aggregate_gpkg, agg_cats_layer),
- sf::read_sf(aggregate_gpkg, mapped_outlets_layer)),
- c(lookup_table_refactor,
- reconciled_layer,
- divide_layer,
- split_divide_layer,
- agg_fline_layer,
- agg_cats_layer,
- mapped_outlets_layer))#,
-
- ### RECONCILED ###
-
- out[[rpu]][[reconciled_layer]] <- select(out[[rpu]][[reconciled_layer]],
- ID, toID, LENGTHKM, TotDASqKM, member_COMID,
- LevelPathID = orig_levelpathID)
-
- out[[rpu]][[reconciled_layer]]$newID <-
- seq(s, by = 1, length.out = nrow(out[[rpu]][[reconciled_layer]]))
-
- s <- max(out[[rpu]][[reconciled_layer]]$newID) + 1
-
- # get a toID that matches the new IDs
- out[[rpu]][[reconciled_layer]] <- left_join(out[[rpu]][[reconciled_layer]],
- select(st_drop_geometry(out[[rpu]][[reconciled_layer]]),
- ID, newtoID = newID),
- by = c("toID" = "ID"))
-
- # find updates that we need to apply
- update <- rpu_vpu_out[!rpu_vpu_out$toCOMID %in% out[[rpu]][[lookup_table_refactor]]$NHDPlusV2_COMID &
- rpu_vpu_out$COMID %in% out[[rpu]][[lookup_table_refactor]]$NHDPlusV2_COMID, ]
-
- # apply these updates for follow up if we got any
- if(nrow(update) > 0) {
- update <- left_join(update, out[[rpu]][[lookup_table_refactor]],
- by = c("COMID" = "NHDPlusV2_COMID")) %>%
- left_join(select(out[[rpu]][[lookup_table_refactor]],
- NHDPlusV2_COMID, to_member_COMID = member_COMID),
- by = c("toCOMID" = "NHDPlusV2_COMID"))
-
- out[[rpu]][[reconciled_layer]] <- left_join(out[[rpu]][[reconciled_layer]],
- select(update, reconciled_ID, toCOMID),
- by = c("ID" = "reconciled_ID"))
- }
-
- #### LOOKUP TABLE ####
-
- update_id <- sf::st_drop_geometry(select(out[[rpu]][[reconciled_layer]],
- old_ID = ID, ID = newID))
-
- out[[rpu]][[lookup_table_refactor]] <- out[[rpu]][[lookup_table_refactor]] %>%
- left_join(update_id, by = c("reconciled_ID" = "old_ID")) %>%
- select(-reconciled_ID, reconciled_ID = ID) %>%
- left_join(update_id, by = c("aggregated_flowpath_ID" = "old_ID")) %>%
- select(-aggregated_flowpath_ID, aggregated_flowpath_ID = ID) %>%
- left_join(update_id, by = c("aggregated_divide_ID" = "old_ID")) %>%
- select(-aggregated_divide_ID, aggregated_divide_ID = ID) %>%
- left_join(sf::st_drop_geometry(select(out[[rpu]][[reconciled_layer]],
- ID = newID, LevelPathID)),
- by = c("reconciled_ID" = "ID"))
-
- #### DIVIDE LAYER ####
-
- out[[rpu]][[divide_layer]] <- left_join(rename(out[[rpu]][[divide_layer]],
- old_ID = ID),
- update_id, by = c("old_ID"))
-
- out[[rpu]][[divide_layer]] <- select(out[[rpu]][[divide_layer]],
- ID, areasqkm, member_COMID)
-
- out[[rpu]][[divide_layer]]$rpu <- rep(rpu, nrow(out[[rpu]][[divide_layer]]))
-
- #### aggregate layers ####
-
- for(l in c(agg_cats_layer, agg_fline_layer)) { #, mapped_outlets_layer
-
- out[[rpu]][[l]] <- left_join(rename(out[[rpu]][[l]], old_ID = ID),
- update_id,
- by = c("old_ID"))
-
- if("toID" %in% names(out[[rpu]][[l]])) {
- out[[rpu]][[l]] <- left_join(rename(out[[rpu]][[l]], old_toID = toID),
- rename(update_id, toID = ID),
- by = c("old_toID" = "old_ID"))
-
- sets <- select(st_drop_geometry(out[[rpu]][[l]]), ID, old_ID, old_set = set) %>%
- mutate(old_set = strsplit(old_set, ",")) %>%
- tidyr::unnest(cols = old_set) %>%
- mutate(old_set = as.integer(old_set)) %>%
- left_join(rename(update_id, set = ID), by = c("old_set" = "old_ID")) %>%
- select(-old_set, -old_ID)
-
- sets <- split(sets$set, sets$ID)
-
- sets <- data.frame(ID = as.integer(names(sets))) %>%
- mutate(set = unname(sets))
-
- out[[rpu]][[l]] <- left_join(select(out[[rpu]][[l]], -set),
- sets, by = "ID")
-
- out[[rpu]][[l]] <- select(out[[rpu]][[l]], -old_ID, -old_toID)
-
- out[[rpu]][[l]] <- out[[rpu]][[l]][c("ID", "toID", "set",
- names(out[[rpu]][[l]])[!names(out[[rpu]][[l]]) %in%
- c("ID", "toID", "set",
- attr(out[[rpu]][[l]], "sf_column"))],
- attr(out[[rpu]][[l]], "sf_column"))]
-
- out[[rpu]][[l]]$set <- sapply(out[[rpu]][[l]]$set, paste, collapse = ",")
- } else {
-
- out[[rpu]][[l]] <- select(out[[rpu]][[l]], -old_ID)
-
- out[[rpu]][[l]] <- out[[rpu]][[l]][c("ID",
- names(out[[rpu]][[l]])[!names(out[[rpu]][[l]]) %in%
- c("ID",
- attr(out[[rpu]][[l]], "sf_column"))],
- attr(out[[rpu]][[l]], "sf_column"))]
- }
- }
-
- }
-
- out <- setNames(lapply(names(out[[1]]), function(x, out) {
- dplyr::bind_rows(lapply(out, function(df, n) {
- if("COMID" %in% names(df[[n]]) && is.numeric(df[[n]]$COMID))
- df[[n]]$COMID <- as.character(df[[n]]$COMID)
- df[[n]]
-
- if("event_id" %in% names(df[[n]]) && !is.character(df[[n]]$event_id))
- df[[n]]$event_id <- as.character(df[[n]]$event_id)
- df[[n]]
- }, n = x))
- }, out = out), names(out[[1]]))
-
- if("toCOMID" %in% names(out[[reconciled_layer]])) {
-
- # blow up so we have unique COMIDs to join on.
- # need to keep the top most of any splits (the .1 variety)
- # this makes sure out toCOMID assignments go to the right new id.
- long_form <- st_drop_geometry(out[[reconciled_layer]]) %>%
- select(newID, member_COMID) %>%
- mutate(member_COMID = strsplit(member_COMID, ",")) %>%
- tidyr::unnest(cols = member_COMID) %>%
- filter(grepl("\\.1$", member_COMID) | !grepl("\\.", member_COMID)) %>%
- mutate(NHDPlusV2_COMID = as.integer(member_COMID)) %>%
- select(-member_COMID, update_newtoID = newID)
-
- # NOTE: if the missing tocomid is in the next VPU they will still be NA
- out[[reconciled_layer]] <- left_join(out[[reconciled_layer]],
- long_form, by = c("toCOMID" = "NHDPlusV2_COMID"))
- out[[reconciled_layer]]$newtoID[!is.na(out[[reconciled_layer]]$toCOMID)] <-
- out[[reconciled_layer]]$update_newtoID[!is.na(out[[reconciled_layer]]$toCOMID)]
-
- # now use updates from refactored ids with aggregate
- long_form <- st_drop_geometry(out[[agg_fline_layer]]) %>%
- select(ID, set) %>%
- mutate(set = strsplit(set, ",")) %>%
- tidyr::unnest(cols = set) %>%
- mutate(set = as.integer(set)) %>%
- select(update_newtoID = ID, refactor_ID = set)
-
- # join updated toID from refactor so we can update as needed
- out[[agg_fline_layer]] <- out[[agg_fline_layer]] %>%
- # this adds a "new_toID" containing the refactor id that the
- # aggregate flowpaths we are updating need to go to.
- left_join(select(st_drop_geometry(out[[reconciled_layer]]),
- ID = newID, new_toID = update_newtoID),
- by = "ID") %>%
- # we need to handle sets of refactor ids and get the right aggregate toID
- left_join(long_form, by = c("new_toID" = "refactor_ID"))
- # need to update the field to reflect the information joined just above.
- out[[agg_fline_layer]]$new_toID[!is.na(out[[agg_fline_layer]]$update_newtoID)] <-
- out[[agg_fline_layer]]$update_newtoID[!is.na(out[[agg_fline_layer]]$update_newtoID)]
-
- # now do the actual toID updates
- out[[agg_fline_layer]]$toID[!is.na(out[[agg_fline_layer]]$new_toID)] <-
- out[[agg_fline_layer]]$new_toID[!is.na(out[[agg_fline_layer]]$new_toID)]
-
- out[[agg_fline_layer]] <- select(out[[agg_fline_layer]], -new_toID, -update_newtoID)
- }
-
- out[[split_divide_layer]] <- rename(out[[split_divide_layer]], comid_part = FEATUREID)
-
- out[[reconciled_layer]] <- select(out[[reconciled_layer]], ID = newID,
- toID = newtoID, LENGTHKM, TotDASqKM,
- member_COMID, LevelPathID, refactor_ID = ID)
-
- out
-}
-
# FIXME: THESE FUNCTIONS SHOULD COME FROM hyFab
#' Extract nexus locations for Reference POIs
#' @param gpkg a reference hydrofabric gpkg
@@ -484,4 +265,4 @@ stage_national_data <- function(include = c("attribute",
}
return(outlist)
-}
\ No newline at end of file
+}
diff --git a/workspace/README.md b/workspace/README.md
index 72db05874ff85801f2e0221fc7a13b6b45c9bf59..bd6630adc15a2981e2eb500b5f5f3ccb42102c6f 100644
--- a/workspace/README.md
+++ b/workspace/README.md
@@ -2,30 +2,29 @@
This is where scripts and data live.
-- Rmd files: contain all workflow execution logic.
+- _targets: contains targets project script files
+- _targets_runner.R: used for manual workflow execution commands
+- _targets.yaml: targets projects are declared here
- bin: folder for executable files (7z, etc).
- cache: folder for cached process files.
- data: folder for static downloaded data.
- R: folder for R source files used in workflow.
-- reports: folder for process result reports.
-- runners: folder for orchestration files.
- temp: folder for temporary data.
-## cache files
+## cache files:
+
+The cache is used for files that the targets workflow interact with and are used or important outside the targets workflow.
+
+Cached outputs that have the processing unit (* in the list below) before the type signifier are based on "raster processing units". Cached outputs that have the processing unit after the type signifier are based on "vector processing units".
- data_paths.json: all data used by the workflow is referenced here. (checked in)
- dropped_gages.csv: list of gages NOT included and why.
- Gages_info.*: gages included with useful attribues.
-- enhd_nhdplusatts.csv: updated network attributes for NHDPlus ids.
-- enhd_atts_fline.gpkg: flowlines with updated network attributes for NHDPlus ids.
-- nwm_enhd__nhdplusatts.csv: updated network attributes for NWM ids.
-- nwm_network.gpkg: NWM flowlines with updated network attributes.
- reference*: by VPU files containing all reference fabric content at the native source resolution.
- reference_flowlines
- reference_catchments
- POIs
- WB
-- national_reference_POI.gpkg: National set of POIs determined by `02_NHD_Navigate.Rmd.`
- refactor*: by VPU refactored outputs.
- refactored_flowpaths
- refactored_divides
@@ -36,6 +35,13 @@ This is where scripts and data live.
- aggregated_divides
- mapped_POIs
- lookup_table
+- ND*: by VPU files containing contents "non-dendritic" workflow that seeks to identify areas of non-networked catchments and how to connect them to the network appropriately.
+ - all_cats
+ - divides_nd
+ - divides_nhd
+ - HUC12_nhd
+ - miss_terms
+ - miss_cats
- *refactor: by RPU files containing a set of refactored network artifacts preserving all network junctions from the source data.
- reconciled_flowpaths
- reconciled_divides
@@ -47,68 +53,39 @@ This is where scripts and data live.
- agg_flines
- mapped_outlets
- lookup_table
-- ND*: by VPU files containing contents "non-dendritic" workflow that seeks to identify areas of non-networked catchments and how to connect them to the network appropriately.
- - all_cats
- - divides_nd
- - divides_nhd
- - HUC12_nhd
- - miss_terms
- - miss_cats
-The following summarizes the role of each workflow file.
+The following summarizes the role of each workflow file and targets workflow. Note that over time most of the workflow files are being migrated to targets.
-## 00_ workflow files: preprocess caches
+## preprocess caches
- `00_get_data.Rmd` -- should be run interactively to download required data.
- `00_AK_prep.Rmd` -- prepares AK domain data. All outputs are cached and can be downloaded with `00_get_data.Rmd`.
-- `00_enhd_nwm_network.Rmd` -- processes the core NHDPlus network along with updates from the enhd and nwm. All outputs are cached and can be downloaded with `00_get_data.Rmd`.
- `00_gage_info.Rmd` -- retrieves gage information. All outputs are cached and can be downloaded with `00_get_data.Rmd`.
-## 01_ workflow files: preparation
+## preparation
-- `01_NHD_prep.Rmd` -- sets up basic data in VPU-based reference fabric files.
+- `01_prep_targets` -- sets up basic data in VPU-based reference fabric files.
- `01_Gage_selection.Rmd` -- refines gage list for inclusion in the rest of the workflow.
- `01_HI_prep.Rmd` -- prepares the Hawaii domain for processing.
-- `01_nwm_prep.Rmd` -- specific processing for NWM network with handling for the extended domain NWM (non-NHDPlus) attributes.
-## 02_ workflow files: navigate / POI selection
+## navigate / POI selection
- `02_AK_navigate.Rmd`
- `02_HI_navigate.Rmd`
-- `02_NHD_navigate.Rmd`
+- `02_POI_creation_targets`
These files navigate the network determining a set of required points of interest, refining the points of interest for later use (snapping/merging, etc.), and generating initial output artifacts.
-## 04_ workflow files: merge navigate
-
-- `04_merge.Rmd` -- merges VPU-based processing from 02 step into a national summary.
-
-## 05_ workflow files: refactor
-
-- `05_hyrefactor_flines.Rmd` -- refactors NHDPlus network for CONUS domain, eliminating very small catchments and splitting very large catchments and those with points of interest that need to be enforced in the network. Runs on an RPU basis.
-- `05_hyrefactor_HI.Rmd` -- complete refactor and aggregate workflow for the HI domain.
-- `05_hyrefactor_AK.Rmd` -- complete refactor and aggregate workflow for the AK domain.
-
-## 06_ workflow files: catchment processing
-
-- `06-1_hyrefactor_cats.Rmd` -- processes catchments (splits and merges) according to 05 refactored flowlines.
-- `06-2_aggregate_cats.Rmd` -- aggregates network to minimal set of catchments for points of interest. Adds some additional points of interest to ensure network continuity.
-
-## 07_ workflow files: non-network handling
-
-- `07-1_merge.Rmd` -- Merges data from multiple RPUs into VPU-based files with internally consistent identifiers.
-- `07-2_NonDend.Rmd` -- post processing of catchment processing aiming to identify and fill in gaps in the catchment coverage along coast lines and in closed basins that aren't otherwise included.
-
-## Running Markdown Programmatically
+## refactor
-The markdown files in this directory can be used in development using RStudio or run programatically.
+- `03_refactor_targets` -- refactors NHDPlus network for CONUS domain, eliminating very small catchments and splitting very large catchments and those with points of interest that need to be enforced in the network. Runs on an RPU basis.
+- `03_hyrefactor_HI.Rmd` -- complete refactor and aggregate workflow for the HI domain.
+- `03_hyrefactor_AK.Rmd` -- complete refactor and aggregate workflow for the AK domain.
-The hyRefactor steps in particular need to be executed across RPUs of NHDPlusV2.
+## aggregation
-Using docker from the root of this repository:
+- `04_aggregate_targets` -- aggregates network to minimal set of catchments for points of interest. Adds some additional points of interest to ensure network continuity.
-```
-docker run --mount type=bind,source="$(pwd)"/workspace,target=/jupyter --env OUT_GPKG=/jupyter/cache/03a.gpkg --env RPU_CODE=03a --env SPLIT_CACHE=/jupyter/temp/03a_split.rda dblodgett/gfv2:v0.5 R -e "rmarkdown::render('/jupyter/hyRefactor_flines.Rmd', output_file='/jupyter/hyRefactor_flines_03a.html')"
-```
+## non-network handling
-The `--env` inputs set environment variables that are picked up by `hyRefactor_config.R`.
\ No newline at end of file
+- `05_non_dendritic_targets` -- post processing of catchment processing aiming to identify and fill in gaps in the catchment coverage along coast lines and in closed basins that aren't otherwise included.
diff --git a/workspace/_targets.yaml b/workspace/_targets.yaml
new file mode 100644
index 0000000000000000000000000000000000000000..363f8c5ba223582520189637400580dc449c41d2
--- /dev/null
+++ b/workspace/_targets.yaml
@@ -0,0 +1,15 @@
+01_prep:
+ script: _targets/01_prep_targets.R
+ store: .targets_stores/01_prep
+02_POI_creation:
+ script: _targets/02_POI_creation_targets.R
+ store: .targets_stores/02_POI_creation
+03_refactor:
+ script: _targets/03_refactor_targets.R
+ store: .targets_stores/03_refactor
+04_aggregate:
+ script: _targets/04_aggregate_targets.R
+ store: .targets_stores/04_aggregate
+05_non_dendritic:
+ script: _targets/05_non_dendritic_targets.R
+ store: .targets_stores/05_non_dendritic
diff --git a/workspace/_targets/01_prep_targets.R b/workspace/_targets/01_prep_targets.R
new file mode 100644
index 0000000000000000000000000000000000000000..5c93112e679498ae93cfb4d8986027bb83f1132b
--- /dev/null
+++ b/workspace/_targets/01_prep_targets.R
@@ -0,0 +1,89 @@
+library(targets)
+library(tarchetypes)
+
+tar_option_set(packages = c("dplyr", "sf", "foreign", "hydroloom", "nhdplusTools"),
+ memory = "transient", garbage_collection = TRUE, error = "null",
+ storage = "worker", retrieval = "worker", deployment = "main")
+
+library(future)
+library(future.callr)
+plan(multisession)
+
+# functions for this workflow
+source("R/01_prep_functions.R")
+# project utilities
+source("R/utils.R")
+
+# user settings
+source("R/user_vars.R")
+
+# global configurations
+source("R/config.R")
+
+# manual modifications
+source("R/gage_mod.R")
+
+list(
+ tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
+ tar_target(data_paths, jsonlite::read_json(data_paths_file)),
+ ###
+ tar_target(usgs_ref_gages_file, data_paths$usgs_nldi_gages, format = "file"),
+ tar_target(gages_ii_gages_file, data_paths$gagesii_lyr, format = "file"),
+ tar_target(usgs_ref_gages, read_sf(usgs_ref_gages_file)),
+ tar_target(gages_ii_ref, filter(usgs_ref_gages,
+ id %in% filter(read_sf(gages_ii_gages_file),
+ CLASS == "Ref")$STAID)),
+ ###
+ tar_target(SWIM_dbf_file, data_paths$SWIM_dbf, format = "file"),
+ tar_target(SWIM_points_file, data_paths$SWIM_points_path, format = "file"),
+ tar_target(SWIM, prepare_SWIM(SWIM_dbf_file, SWIM_points_file, usgs_ref_gages,
+ gages_add, POR_Start, min_da_km_gages, min_obs)),
+ ###
+ tar_target(NHDPlusV2_gageloc_file, data_paths$gageloc_info, format = "file"),
+ tar_target(NHDPlusV2_gdb, data_paths$nhdplus_gdb),
+ tar_target(NHDPlusV2_gages, prepare_gage_location(NHDPlusV2_gageloc_file,
+ NHDPlusV2_gdb,
+ SWIM,
+ usgs_ref_gages,
+ min_da_km_gages)),
+ ###
+ tar_target(combined_waterbodies, make_combined_waterbodies(NHDPlusV2_gdb, proj_crs)),
+ tar_target(reference_flowlines, read_sf(data_paths$ref_fl)),
+ tar_target(gfv11_gages_rds, data_paths$GFv11_gages_lyr, format = "file"),
+ tar_target(gfv11_gages_dbf, file.path(data_paths$data_dir, "GFV11.dbf"), format = "file"),
+ tar_target(gfv11_gages, prepare_gfv11_gages(gfv11_gages_rds, gfv11_gages_dbf, usgs_ref_gages,
+ NHDPlusV2_gages, SWIM, reference_flowlines)),
+ ###
+ tar_target(final_gages, finalize_gages(SWIM, NHDPlusV2_gages, gfv11_gages, gages_ii_ref,
+ gage_info_gpkg, gage_info_csv, gage_info_csvt,
+ geo_crs)),
+ ###
+ tar_render(gage_selection_map_report, "templates/01_Gage_Selection.Rmd",
+ output_file = "../temp/01_Gage_Selection.html",
+ params = list(SWIM = SWIM,
+ NHDPlusV2_gages = NHDPlusV2_gages,
+ gfv11_gages = gfv11_gages,
+ final_gages = final_gages,
+ min_da_km_gages = min_da_km_gages)),
+
+ tar_target(rpu_vpu, read.csv(system.file("extdata/rpu_vpu.csv", package = "hyfabric"),
+ colClasses = "character")),
+
+ tar_target(vpu_codes, unique(rpu_vpu$vpuid)),
+ tar_target(all_rpu_codes, unique(rpu_vpu$rpuid)),
+ tar_target(full_cat_file, data_paths$fullcats_table, format = "file"),
+ tar_target(full_cat_table, readRDS(full_cat_file)),
+
+ tar_target(ref_gpkg, file.path(data_paths$ref_fab_path,
+ paste0(vpu_codes, "_reference_features.gpkg")),
+ pattern = map(vpu_codes)),
+ tar_target(nav_gpkg, file.path("cache", paste0("reference_", vpu_codes,".gpkg")),
+ pattern = map(vpu_codes)),
+
+ # ~1GB of memory
+ tar_target(vpu_base, prepare_vpu_base_layers(ref_gpkg, nav_gpkg, vpu_codes, full_cat_table, rpu_vpu),
+ pattern = map(ref_gpkg, nav_gpkg, vpu_codes), deployment = "worker"),
+ tar_target(rpu_vpu_out_list, prep_rpu_vpu_out_list(vpu_base, rpu_vpu), pattern = map(vpu_base),
+ deployment = "worker", iteration = "list"),
+ tar_target(rpu_vpu_out, prep_rpu_vpu_out(rpu_vpu_out_list, reference_flowlines))
+)
\ No newline at end of file
diff --git a/workspace/_targets/02_POI_creation_targets.R b/workspace/_targets/02_POI_creation_targets.R
new file mode 100644
index 0000000000000000000000000000000000000000..00d83f8a6187aa46f5f40035d16129cb2302dbc1
--- /dev/null
+++ b/workspace/_targets/02_POI_creation_targets.R
@@ -0,0 +1,188 @@
+library(targets)
+
+tar_option_set(packages = c("dplyr", "sf", "hyfabric", "hydroloom", "nhdplusTools"),
+ memory = "transient", garbage_collection = TRUE, error = "stop",
+ storage = "worker", retrieval = "worker", deployment = "main")
+
+library(future)
+library(future.callr)
+plan(multisession)
+
+source("R/config.R")
+source("R/user_vars.R")
+source("R/utils.R")
+source("R/02_POI_creation_functions.R")
+
+prep_path <- ".targets_stores/01_prep/objects/"
+
+list(tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
+ tar_target(data_paths, jsonlite::read_json(data_paths_file)),
+ tar_target(vpu_codes_file, file.path(prep_path, "vpu_codes"), format = "file"),
+ tar_target(vpu_codes, readRDS(vpu_codes_file)),
+ tar_target(vpu_gpkg, file.path("cache", paste0("reference_", vpu_codes,".gpkg")),
+ pattern = map(vpu_codes), deployment = "worker"),
+
+ ### Base flowline -- gets updated attributes
+ tar_target(flowline, read_sf(vpu_gpkg, nhd_flowline),
+ pattern = map(vpu_gpkg), deployment = "worker"),
+ # read_sf(data_paths$nhdplus_gdb, "NHDArea")
+ tar_target(all_nhdplus_attributes,
+ sf::st_drop_geometry(sf::read_sf(data_paths$nhdplus_gdb, "NHDFlowline_Network"))),
+ tar_target(nhdplushr_dir, data_paths$nhdplushr_dir),
+ tar_target(full_cat_file, data_paths$fullcats_table, format = "file"),
+ tar_target(full_cat_table, readRDS(full_cat_file)),
+
+ ### huc12 pois
+ tar_target(hu12_points_file, data_paths$hu12_points_path, format = "file"),
+ tar_target(huc12_poi, create_hu12_pois(read_sf(hu12_points_file, "hu_points"),
+ flowline,
+ poi_name = "HUC12",
+ vpu_codes),
+ pattern = map(flowline, vpu_codes)),
+
+ ### gage POIs
+ tar_target(gage_info_gpkg_file, gage_info_gpkg, format = "file"),
+ tar_target(gages, read_sf(gage_info_gpkg_file, "Gages")),
+ tar_target(gage_pois, create_gage_pois(gages,
+ flowline, "Gages", huc12_poi,
+ min_da_km_gages, combine_meters, reach_meas_thresh),
+ pattern = map(flowline, huc12_poi), deployment = "worker"),
+ tar_target(gage_events, gage_pois$events, pattern = map(gage_pois), deployment = "worker"),
+
+ ### Thermo electric power plant POIs
+ tar_target(te_points_file, data_paths$TE_points_path, format = "file"),
+ tar_target(te_points, read_sf(te_points_file, "2015_TE_Model_Estimates_lat.long_COMIDs")),
+ tar_target(te_attributes_file, file.path(data_paths$TE_points_path, "1_model_inputs/te_plants.csv"), format = "file"),
+ tar_target(te_attributes, read.csv(te_attributes_file, colClasses = "character")),
+ tar_target(te_pois, create_thermo_electric_pois(te_points, te_attributes,
+ gage_pois, huc12_poi$HUC12_COMIDs,
+ flowline, "TE"),
+ pattern = map(gage_pois, huc12_poi, flowline)),
+
+ ### get waterbodies in order
+ tar_target(combined_waterbodies_file, file.path(prep_path, "combined_waterbodies"), format = "file"),
+ tar_target(combined_waterbodies, readRDS(combined_waterbodies_file)),
+ tar_target(nhdplus_area, filter(combined_waterbodies, layer == "NHDArea")),
+ tar_target(waterbodies, make_waterbodies_layer(combined_waterbodies, flowline, geo_crs),
+ pattern = map(flowline), deployment = "worker"),
+
+ ### star fit cross walk and reservoir POIs
+ tar_target(istarf_xwalk_file, data_paths$istarf_xwalk, format = "file"),
+ tar_target(istarf_xwalk, read.csv(istarf_xwalk_file)),
+ tar_target(resops_pois, create_resops_pois(te_pois, waterbodies, istarf_xwalk,
+ flowline, "resops"),
+ pattern = map(te_pois, waterbodies, flowline), deployment = "worker"),
+ tar_target(resops_waterbody_attributes, resops_pois$wb_resops,
+ pattern = map(resops_pois), deployment = "worker"),
+
+ ### hilarri is more reservoir POIs
+ tar_target(hilarri_file, data_paths$hilarri_sites, format = "file"),
+ tar_target(hilarri_data, read.csv(hilarri_file, colClasses = "character")),
+ tar_target(hilarri_pois, create_hilarri_pois(resops_pois,
+ hilarri_data,
+ resops_pois$wb_pois,
+ flowline, "hilarri"),
+ pattern = map(resops_pois, flowline), deployment = "worker"),
+ tar_target(hilarri_waterbodies, hilarri_pois$wb_pois,
+ pattern = map(hilarri_pois), deployment = "worker"),
+
+ ### waterbody outlet POIs
+ tar_target(wb_outlet_pois, create_wb_outlet_pois(hilarri_pois,
+ nhdplus_area,
+ hilarri_waterbodies,
+ resops_waterbody_attributes,
+ flowline,
+ gage_events,
+ proj_crs,
+ gages,
+ "wb_id",
+ nhdplushr_dir),
+ pattern = map(hilarri_pois, hilarri_waterbodies, resops_waterbody_attributes,
+ gage_events,flowline), deployment = "worker"),
+ tar_target(gage_and_waterbody_outlet_events, wb_outlet_pois$all_events,
+ pattern = map(wb_outlet_pois), deployment = "worker"),
+
+ ### update flowlines for clarity
+ tar_target(updated_flowline_wb_outlet, wb_outlet_pois$updated_flowline,
+ pattern = map(wb_outlet_pois), deployment = "worker"),
+
+ ### Addition and Removal events from Brakebill, 2019
+ tar_target(ar_data, readxl::read_xlsx(file.path(data_paths$USGS_IT_path,
+ "ARevents_final7.xlsx"))),
+ tar_target(ar_event_pois, create_ar_event_pois(wb_outlet_pois, ar_data,
+ updated_flowline_wb_outlet, "AR"),
+ pattern = map(wb_outlet_pois, updated_flowline_wb_outlet), deployment = "worker"),
+
+ ### terminal POIs at network ends
+ tar_target(terminal_pois, create_terminal_pois(ar_event_pois,
+ updated_flowline_wb_outlet,
+ min_da_km_terminal, "Term"),
+ pattern = map(ar_event_pois, updated_flowline_wb_outlet), deployment = "worker"),
+
+ ### confluence POIs
+ tar_target(confluence_pois, create_confluence_pois(terminal_pois,
+ updated_flowline_wb_outlet, "Conf"),
+ pattern = map(terminal_pois, updated_flowline_wb_outlet), deployment = "worker"),
+
+ ### more updated flowline attributes
+ tar_target(updated_flowline_confluence, confluence_pois$updated_flowline,
+ pattern = map(confluence_pois), deployment = "worker"),
+
+ ## waterbody inlet POIs
+ tar_target(wb_inlet_pois, create_wb_inlet_pois(confluence_pois,
+ wb_outlet_pois$WB_VPU_pois,
+ gage_and_waterbody_outlet_events,
+ updated_flowline_confluence, gages,
+ nhdplus_area, proj_crs, "WBIn", nhdplushr_dir),
+ pattern = map(confluence_pois, wb_outlet_pois, gage_and_waterbody_outlet_events,
+ updated_flowline_confluence), deployment = "worker"),
+ tar_target(gage_and_all_waterbody_events, wb_inlet_pois$events,
+ pattern = map(wb_inlet_pois), deployment = "worker"),
+
+ tar_target(nid_points, read_sf(data_paths$NID_points_path, "Final_NID_2018")),
+ tar_target(nid_pois, create_nid_pois(wb_inlet_pois,
+ nid_points,
+ updated_flowline_confluence,
+ "NID"),
+ pattern = map(wb_inlet_pois, updated_flowline_confluence)),
+
+ tar_target(headwater_pois, create_headwater_pois(nid_pois,
+ updated_flowline_confluence,
+ all_nhdplus_attributes,
+ min_da_km_hw, "DA"),
+ pattern = map(nid_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(elevation_break_pois, create_elevation_break_pois(headwater_pois,
+ updated_flowline_confluence,
+ all_nhdplus_attributes,
+ "elev"),
+ pattern = map(headwater_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(time_of_travel_pois, create_time_of_travel_pois(elevation_break_pois,
+ updated_flowline_confluence,
+ all_nhdplus_attributes,
+ "Travel"),
+ pattern = map(elevation_break_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(final_pois, create_final_pois(time_of_travel_pois,
+ updated_flowline_confluence),
+ pattern = map(time_of_travel_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(draft_segments, create_draft_segments(final_pois,
+ updated_flowline_confluence),
+ pattern = map(final_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(collapsed_pois, collapse_pois(final_pois, poi_dar_move, poi_distance_move,
+ updated_flowline_confluence),
+ pattern = map(final_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(poi_lookup,
+ create_poi_lookup(collapsed_pois, gage_and_all_waterbody_events,
+ full_cat_table, updated_flowline_confluence),
+ pattern = map(collapsed_pois, gage_and_all_waterbody_events, updated_flowline_confluence)),
+ tar_target(write_poi_, {
+ write_sf(poi_lookup$pois_data, vpu_gpkg, poi_data_table)
+ write_sf(poi_lookup$poi_geometry, vpu_gpkg, poi_geometry_table)
+ write_sf(poi_lookup$event_geometry_table, vpu_gpkg, event_geometry_table)
+ }, pattern = map(poi_lookup, vpu_gpkg), deployment = "worker")
+)
\ No newline at end of file
diff --git a/workspace/_targets/03_refactor_targets.R b/workspace/_targets/03_refactor_targets.R
new file mode 100644
index 0000000000000000000000000000000000000000..6c459e4f900b601693a2d8cb6f4ff5c67bb23288
--- /dev/null
+++ b/workspace/_targets/03_refactor_targets.R
@@ -0,0 +1,87 @@
+library(targets)
+
+tar_option_set(packages = c("hyRefactor", "dplyr", "sf"),
+ memory = "transient", garbage_collection = TRUE, error = "null",
+ storage = "worker", retrieval = "worker", deployment = "main")
+
+library(future)
+library(future.callr)
+plan(multisession)
+
+source("R/config.R")
+source("R/user_vars.R")
+source("R/03_refactor_functions.R")
+
+prep_path <- ".targets_stores/01_prep/objects/"
+
+list(tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
+ tar_target(data_paths, jsonlite::read_json(data_paths_file)),
+ tar_target(rpu_codes_file, file.path(prep_path, "all_rpu_codes"), format = "file"),
+ tar_target(rpu_codes, readRDS(rpu_codes_file)),
+ tar_target(rpu_vpu_file, file.path(prep_path, "rpu_vpu"), format = "file"),
+ tar_target(rpu_vpu, readRDS(rpu_vpu_file)),
+ tar_target(rpu_gpkg, file.path("cache", paste0(rpu_codes, "_refactor.gpkg")),
+ pattern = map(rpu_codes), deployment = "worker"),
+ tar_target(vpu_gpkg, file.path("cache", paste0("reference_", rpu_vpu$vpuid[rpu_vpu$rpuid == rpu_codes], ".gpkg")),
+ pattern = map(rpu_codes), deployment = "worker"),
+
+ tar_target(flowline, sf::st_zm(sf::read_sf(rpu_gpkg, nhd_flowline)),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+
+ tar_target(pois, sf::read_sf(vpu_gpkg, poi_geometry_table),
+ pattern = map(vpu_gpkg), deployment = "worker"),
+ tar_target(pois_data, sf::read_sf(vpu_gpkg, poi_data_table),
+ pattern = map(vpu_gpkg), deployment = "worker"),
+
+ tar_target(refactor_event_table, sf::read_sf(vpu_gpkg, event_geometry_table),
+ pattern = map(vpu_gpkg), deployment = "worker"),
+
+ tar_target(refactor_input, create_refactor_input(flowline, refactor_event_table, pois, pois_data),
+ pattern = map(refactor_event_table, flowline, pois, pois_data), deployment = "worker"),
+ tar_target(refactored_network, run_refactor_nhdplus(flowline, split_meters,
+ para_split_flines, combine_meters,
+ refactor_input$events_refactor,
+ refactor_input$exclude,
+ rpu_codes, proj_crs),
+ pattern = map(flowline, refactor_input, rpu_codes),
+ deployment = "worker"),
+
+ tar_target(refactor_lookup, create_refactor_lookup(refactored_network, flowline,
+ refactor_input$events_refactor,
+ refactor_input$outlets),
+ pattern = map(refactored_network, flowline, refactor_input), deployment = "worker"),
+
+ tar_target(out_refactor, {
+ sf::write_sf(refactored_network$refactored, rpu_gpkg, refactored_layer)
+ sf::write_sf(refactored_network$reconciled, rpu_gpkg, reconciled_layer)
+ sf::write_sf(refactor_lookup$outlets, rpu_gpkg, outlets_layer)
+ sf::write_sf(refactor_lookup$lookup, rpu_gpkg, lookup_table_refactor)
+ try(sf::write_sf(refactor_lookup$dups, rpu_gpkg, dup_pois))
+ }, pattern = map(refactored_network, refactor_lookup, rpu_gpkg), deployment = "worker"),
+
+ tar_target(fdr_fac, list(fdr = data_paths$fdr[[paste0("rpu_", rpu_codes)]],
+ fac = data_paths$fac[[paste0("rpu_", rpu_codes)]]),
+ pattern = rpu_codes, iteration = "list"),
+
+ tar_target(raster_crs, terra::crs(terra::rast(fdr_fac[[1]]$fdr))),
+
+ tar_target(cats, sf::st_transform(sf::read_sf(rpu_gpkg, nhd_catchment), raster_crs),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+
+ tar_target(cache_split, file.path("cache", paste0(rpu_codes, ".rda")),
+ pattern = map(rpu_codes)),
+
+ tar_target(divides, reconcile_divides(cats,
+ refactored_network,
+ fdr_fac,
+ para_reconcile,
+ cache_split),
+ pattern = map(cats, refactored_network, fdr_fac, cache_split),
+ deployment = "worker"),
+ tar_target(out_divides, {
+ write_sf(divides$divides, rpu_gpkg, divide_layer)
+ write_sf(divides$split_cats, rpu_gpkg, split_divide_layer)
+ },
+ pattern = map(divides, rpu_gpkg), deployment = "worker")
+
+)
\ No newline at end of file
diff --git a/workspace/_targets/04_aggregate_targets.R b/workspace/_targets/04_aggregate_targets.R
new file mode 100644
index 0000000000000000000000000000000000000000..6374f23689cea8003a014d24c46acacc3ea8146f
--- /dev/null
+++ b/workspace/_targets/04_aggregate_targets.R
@@ -0,0 +1,66 @@
+library(targets)
+
+tar_option_set(packages = c("dplyr", "sf"),
+ memory = "transient", garbage_collection = TRUE, error = "stop",
+ storage = "worker", retrieval = "worker", deployment = "main",
+ iteration = "list")
+
+library(future)
+library(future.callr)
+plan(multisession)
+
+source("R/config.R")
+source("R/user_vars.R")
+source("R/04_aggregate_functions.R")
+
+prep_path <- ".targets_stores/01_prep/objects/"
+
+list(tar_target(rpu_codes_file, file.path(prep_path, "all_rpu_codes"), format = "file"),
+ tar_target(rpu_codes, readRDS(rpu_codes_file)),
+ tar_target(rpu_gpkg, file.path("cache", paste0(rpu_codes, "_refactor.gpkg")),
+ pattern = map(rpu_codes), deployment = "worker"),
+ tar_target(agg_gpkg, file.path("cache", paste0(rpu_codes, "_aggregate.gpkg")),
+ pattern = map(rpu_codes), deployment = "worker"),
+ tar_target(cache_split, file.path("cache", paste0(rpu_codes, ".rda")),
+ pattern = map(rpu_codes)),
+
+ tar_target(flowline, st_zm(read_sf(rpu_gpkg, nhd_flowline)),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+ tar_target(outlets_POI, read_sf(rpu_gpkg, outlets_layer) |>
+ distinct() |>
+ filter(hy_id %in% flowline$COMID),
+ pattern = map(rpu_gpkg, flowline), deployment = "worker"),
+
+ tar_target(reconciled, read_sf(rpu_gpkg, reconciled_layer),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+ tar_target(refactored, st_drop_geometry(read_sf(rpu_gpkg, refactored_layer)) |>
+ select(COMID, Hydroseq) |> mutate(COMID = as.integer(COMID)),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+ tar_target(divides, st_transform(read_sf(rpu_gpkg, divide_layer), proj_crs),
+ pattern = map(rpu_gpkg), deployment = "worker"),
+ tar_target(highest_da, get_highest_da(read_sf(rpu_gpkg, lookup_table_refactor),
+ flowline, refactored),
+ pattern = map(rpu_gpkg, flowline, refactored), deployment = "worker"),
+
+ tar_target(aggregated, aggregate_catchments_fun(divides, reconciled, outlets_POI,
+ aggregate_da_thresh_sqkm, cache_split,
+ highest_da),
+ pattern = map(divides, reconciled, outlets_POI, cache_split, highest_da),
+ deployment = "worker"),
+
+ tar_target(long_form_pois, make_long_form_pois(aggregated$mapped_outlets_layer),
+ pattern = map(aggregated), deployment = "worker"),
+
+ tar_target(lookup, make_lookup(reconciled, aggregated$agg_cats_layer, aggregated$agg_fline_layer),
+ pattern = map(reconciled, aggregated), deployment = "worker"),
+
+ tar_target(write_agg_, {
+ write_sf(aggregated$agg_cats_layer, agg_gpkg, agg_cats_layer)
+ write_sf(aggregated$agg_fline_layer, agg_gpkg, agg_fline_layer)
+ write_sf(aggregated$mapped_outlets_layer, agg_gpkg, mapped_outlets_layer)
+ write_sf(aggregated$unmapped_outlets, agg_gpkg, "unmapped_outlets")
+ write_sf(aggregated$double_outlets, agg_gpkg, "double_outlets")
+ write_sf(long_form_pois, agg_gpkg, poi_data_table)
+ write_sf(lookup, agg_gpkg, lookup_table_refactor)
+ }, pattern = map(agg_gpkg, aggregated, long_form_pois, lookup), deployment = "worker")
+)
diff --git a/workspace/_targets/05_non_dendritic_targets.R b/workspace/_targets/05_non_dendritic_targets.R
new file mode 100644
index 0000000000000000000000000000000000000000..7ff73f57144b1b77d7690f5260d3409c95300551
--- /dev/null
+++ b/workspace/_targets/05_non_dendritic_targets.R
@@ -0,0 +1,115 @@
+library(targets)
+
+tar_option_set(packages = c("hyRefactor", "dplyr", "sf"),
+ memory = "transient", garbage_collection = TRUE, error = "stop",
+ storage = "worker", retrieval = "worker", deployment = "main")
+
+library(future)
+library(future.callr)
+plan(multisession)
+
+source("R/config.R")
+source("R/user_vars.R")
+source("R/05_non_dendritic_functions.R")
+
+prep_path <- ".targets_stores/01_prep/objects/"
+
+list(tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
+ tar_target(data_paths, jsonlite::read_json(data_paths_file)),
+
+ tar_target(all_nhdplus_attributes,
+ sf::st_drop_geometry(sf::read_sf(data_paths$nhdplus_gdb, "NHDFlowline_Network"))),
+ tar_target(nhdplus_sinks, read_sf(data_paths$nhdplus_gdb, "Sink")),
+ tar_target(nhdplus_wbd, read_sf(data_paths$nhdplus_gdb, "HUC12") |>
+ st_make_valid() |> st_transform(crs = proj_crs)),
+ tar_target(cat_rpu_table, readRDS(data_paths$fullcats_table)),
+
+ tar_target(rpu_vpu_file, file.path(prep_path, "rpu_vpu"), format = "file"),
+ tar_target(rpu_vpu, readRDS(rpu_vpu_file)),
+ tar_target(rpu_vpu_out_file, file.path(prep_path, "rpu_vpu_out"), format = "file"),
+ tar_target(rpu_vpu_out, readRDS(rpu_vpu_out_file)),
+
+ ## set up to map over vpu_codes
+ tar_target(vpu_codes_file, file.path(prep_path, "vpu_codes"), format = "file"),
+ tar_target(vpu_codes, readRDS(vpu_codes_file)),
+ tar_target(vpu_gpkg, file.path("cache", paste0("reference_", vpu_codes,".gpkg")),
+ pattern = map(vpu_codes), deployment = "worker", format = "file"),
+
+ # we only write to this gpkg
+ tar_target(rfc_gpkg, file.path("cache", paste0("refactor_", vpu_codes,".gpkg")),
+ pattern = map(vpu_codes), deployment = "worker"),
+ tar_target(gf_gpkg, file.path("cache", paste0("GF_", vpu_codes, ".gpkg")),
+ pattern = map(vpu_codes), deployment = "worker"),
+
+ # TODO: setup the refactor and aggregate geopackages as format = "file" targets?
+ tar_target(merged_vpu, merge_rpu_to_vpu(read_sf(vpu_gpkg, poi_data_table),
+ rpu_vpu, vpu_codes, rpu_vpu_out,
+ \(rpu) file.path("cache", paste0(rpu, "_refactor.gpkg")),
+ \(rpu) file.path("cache", paste0(rpu, "_aggregate.gpkg")),
+ lookup_table_refactor, reconciled_layer,
+ divide_layer, split_divide_layer,
+ agg_fline_layer, agg_cats_layer,
+ mapped_outlets_layer),
+ pattern = map(vpu_gpkg, vpu_codes), deployment = "worker"),
+
+ tar_target(write_out, {
+ write_sf(merged_vpu$pois, gf_gpkg, poi_data_table)
+ write_sf(merged_vpu$lookup_table_refactor, rfc_gpkg, lookup_table_refactor)
+ write_sf(merged_vpu$reconciled_layer, rfc_gpkg, reconciled_layer)
+ write_sf(merged_vpu$divide_layer, rfc_gpkg, divide_layer)
+ write_sf(merged_vpu$split_divide_layer, rfc_gpkg, split_divide_layer)
+ write_sf(merged_vpu$mapped_outlets_layer, gf_gpkg, mapped_outlets_layer)
+ write_sf(merged_vpu$agg_cats_layer, gf_gpkg, agg_cats_layer)
+ write_sf(merged_vpu$agg_fline_layer, gf_gpkg, agg_fline_layer)
+ write_sf(merged_vpu$lookup_table_aggregate, gf_gpkg, lookup_table_refactor)
+ write_sf(merged_vpu$catchment_network_table_refector, rfc_gpkg, catchment_network_table)
+ write_sf(merged_vpu$cathment_network_table_aggregate, gf_gpkg, catchment_network_table)
+ }, pattern = map(merged_vpu, gf_gpkg, rfc_gpkg), deployment = "worker"),
+
+ ## prep for non-dendritic
+ tar_target(vpu_attributes, get_vpu_config(vpu_codes, data_paths,
+ all_nhdplus_attributes, nhdplus_wbd),
+ pattern = map(vpu_codes)),
+ # NOTUSED?
+ # tar_target(flowline_vpu, st_transform(read_sf(vpu_gpkg, nhd_flowline), proj_crs),
+ # pattern = map(vpu_gpkg), deployment = "worker"),
+ tar_target(catchment_vpu, st_transform(read_sf(vpu_gpkg, nhd_catchment), proj_crs),
+ pattern = map(vpu_gpkg), deployment = "worker"),
+ tar_target(divides_vpu, st_transform(merged_vpu$divide_layer, proj_crs),
+ pattern = map(merged_vpu), deployment = "worker"),
+ # NOTUSED?
+ # tar_target(lookup_vpu, merged_vpu$lookup_table_aggregate,
+ # pattern = map(merged_vpu), deployment = "worker"),
+
+ tar_target(hu12_xwalk, make_hu12_xwalk(catchment_vpu, divides_vpu, vpu_codes,
+ # TODO track down this file or recreate it!!
+ file.path(data_paths$nhdplus_dir,
+ "CrosswalkTable_NHDplus_HU12.csv"),
+ nhdplus_wbd),
+ pattern = map(catchment_vpu, divides_vpu, vpu_codes), deployment = "worker"),
+ tar_target(divides_non_dendritic, make_divides_nd(hu12_xwalk$divide_layer,
+ merged_vpu$lookup_table_aggregate,
+ hu12_xwalk$nhd_catchment,
+ cat_rpu_table,
+ debug = TRUE),
+ pattern = map(hu12_xwalk, merged_vpu), deployment = "worker"),
+ tar_target(divides_w_huc12, assign_huc12_fun(divides_non_dendritic$divides_nd,
+ hu12_xwalk$xwalk_layer,
+ vpu_attributes$vpu_nhd,
+ debug = FALSE),
+ pattern = map(divides_non_dendritic, hu12_xwalk, vpu_attributes), deployment = "worker"),
+ tar_target(divides_w_coastal, create_coastal_catchments(vpu_attributes$vpu_nhd,
+ divides_w_huc12$divides_nd,
+ vpu_attributes$vpu_WBD,
+ debug = FALSE),
+ pattern = map(vpu_attributes, divides_w_huc12), deployment = "worker"),
+ tar_target(divides_fixed_holes, fix_holes(divides_w_coastal$divides_nd,
+ nhdplus_wbd, nhdplus_sinks,
+ min_da_km_terminal,
+ divides_w_coastal$vpu_nhd,
+ merged_vpu$lookup_table_aggregate,
+ vpu_attributes$elev),
+ pattern = map(divides_w_coastal, vpu_attributes, merged_vpu), deployment = "worker"),
+ tar_target(final, manual_checks(divides_fixed_holes$missing_cats, divides_fixed_holes$divides_nd, vpu_codes),
+ pattern = map(divides_fixed_holes, vpu_codes), deployment = "worker")
+)
diff --git a/workspace/_targets_runner.R b/workspace/_targets_runner.R
new file mode 100644
index 0000000000000000000000000000000000000000..f0786c2497258098741820c7f255c1c76f3758a1
--- /dev/null
+++ b/workspace/_targets_runner.R
@@ -0,0 +1,91 @@
+# running in one global workflow for now.
+
+# clear dropped gages file
+file.remove("cache/dropped_gages.csv")
+
+# checks from SWIM prep
+file.remove("temp/GagestoCheck_GAGESIII.csv")
+
+# checks from nhdplusv2 gageloc prep
+file.remove("temp/GagestoCheck_GageLoc.csv")
+
+Sys.setenv(TAR_PROJECT = "01_prep")
+
+# step 1: gage selection
+tar_make(gage_selection_map_report)
+
+# step 2: vpu prep
+# iterates over vpus
+tar_load(vpu_codes)
+
+if(FALSE) { # this won't run if you just bang through this file
+ # To debug a given vpu, first run all to get the dynamic branches established:
+ tar_make(vpu_base)
+
+ # if any error, you can rerun them as shown below.
+
+ # Then find the branch in question and add it to tar_options_set in the workflow file:
+
+ (branch <- tar_branch_names(vpu_base, which(vpu_codes == "01")))
+ vpu_codes[tar_branch_index(branch)]
+
+ cat('debug = "', branch, '", cue = tar_cue(mode = "never")', sep = "")
+
+ # now we run with callr_function = NULL to get the debug to hit on the desired branch.
+ # note that any other failed branches may try to run first -- it's best to debug the firt
+ # errored branch then work down the list.
+
+ tar_make(callr_function = NULL)
+}
+
+workers <- 12
+
+# run branches for a given target in parallel if you have enough memory
+# note this will only work for targets with 'deployment = "worker"'
+tar_make_future(rpu_vpu_out_list, workers = workers)
+tar_make(rpu_vpu_out)
+
+# make sure to run all too!
+tar_make()
+
+Sys.setenv(TAR_PROJECT = "02_POI_creation")
+
+tar_make_future(huc12_poi, workers = workers)
+tar_make_future(gage_pois, workers = workers)
+tar_make_future(te_pois, workers = workers)
+tar_make_future(resops_pois, workers = workers)
+tar_make_future(hilarri_pois, workers = workers)
+tar_make_future(wb_outlet_pois, workers = workers)
+tar_make_future(write_wb_flowline_mod, workers = workers)
+tar_make_future(ar_event_pois, workers = workers)
+tar_make_future(terminal_pois, workers = workers)
+tar_make_future(updated_flowline_confluence, workers = workers)
+tar_make_future(wb_inlet_pois, workers = workers)
+tar_make_future(nid_pois, workers = workers)
+tar_make_future(headwater_pois, workers = workers)
+tar_make_future(elevation_break_pois, workers = workers)
+tar_make_future(time_of_travel_pois, workers = workers)
+tar_make_future(final_pois, workers = workers)
+tar_make_future(draft_segments, workers = workers)
+tar_make_future(collapsed_pois, workers = workers)
+tar_make_future(poi_lookup, workers = workers)
+tar_make_future(draft_segments, workers = workers)
+tar_make_future(write_poi_, workers = workers)
+
+Sys.setenv(TAR_PROJECT = "03_refactor")
+
+workers = 6
+
+tar_make_future(workers = workers)
+
+Sys.setenv(TAR_PROJECT = "04_aggregate")
+
+workers = 6
+
+tar_make_future(workers = workers)
+
+Sys.setenv(TAR_PROJECT = "05_non_dendritic")
+
+workers = 6
+
+tar_make_future(workers = workers)
diff --git a/workspace/cache/data_paths.json b/workspace/cache/data_paths.json
index 515f3d201042ce7fc440cddf0fd7f51827535a3f..bfdbba19a8ae663736c6b14608c309056ad4fa5d 100644
--- a/workspace/cache/data_paths.json
+++ b/workspace/cache/data_paths.json
@@ -1,7 +1,9 @@
{
"data_dir": "data",
+ "nhdplushr_dir": "data/nhdplushr",
"hu12_points_path": "data/102020wbd_outlets.gpkg",
"SWIM_points_path": "data/SWIM_gage_loc",
+ "SWIM_dbf": "data/SWIMGFinfo.dbf",
"TE_points_path": "data/TE_points",
"USGS_IT_path": "data/USGS_IT",
"NID_points_path": "data/NID_points",
@@ -10,13 +12,11 @@
"islands_dir": "data/islands",
"islands_gdb": "data/islands/NHDPlusNationalData/NHDPlusV21_National_Seamless_Flattened_HI_PR_VI_PI.gdb",
"nhdplus_rpu": "data/NHDPlusNationalData/NHDPlusGlobalData/BoundaryUnit.shp",
+ "gageloc_info": "data/GageLocGFinfo.dbf",
"ref_fab_path": "data/reference_fabric",
"ref_cat": "data/reference_fabric/reference_catchments.gpkg",
"ref_fl": "data/reference_fabric/reference_flowline.gpkg",
"nwm_fl": "data/reference_fabric/nwm_network.gpkg",
- "VAA_fst": "data/NHDPlusNationalData/nhdplusVAA.fst",
- "VAA_rds": "data/NHDPlusNationalData/nhd_vaa.rds",
- "waterbodies_path": "data/NHDPlusNationalData/nhdplus_waterbodies.rds",
"fullcats_table": "data/NHDPlusNationalData/nhdcat_full.rds",
"islandcats_table": "data/islands/nhdcat_full.rds",
"fdr": {
@@ -244,7 +244,6 @@
"rpu_12c": "data/nhdplusv2_elev/NHDPlusTX/NHDPlus12/NEDSnapshot/NED12c/elev_cm",
"rpu_12d": "data/nhdplusv2_elev/NHDPlusTX/NHDPlus12/NEDSnapshot/NED12d/elev_cm"
},
- "latest_wbd_rds": "data/wbd/WBD.rds",
"merit_catchments": "data/merged_AK_MERIT_Hydro/merged_AK_MERIT_Hydro/cat_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp",
"merit_rivers": "data/merged_AK_MERIT_Hydro/merged_AK_MERIT_Hydro/riv_pfaf_78_81_82_MERIT_Hydro_v07_Basins_v01.shp",
"aster_dem": "data/merged_AK_MERIT_Hydro/dem.tif",
@@ -253,15 +252,15 @@
"merit_fac": "data/merged_AK_MERIT_Hydro/ak_merit_fac.tif",
"ak_source": "data/AK/ak.gpkg",
"hi_source": "data/islands/hi.gpkg",
- "nwm_network": "data/NWM_parameters_v2.1/RouteLink_CONUS.nc",
- "nwm_parm": "data/NWM_v2.1_channel_hydrofabric_10262020/nwm_v2_1_hydrofabric.gdb",
- "new_nhdp_atts": "cache/enhd_nhdplusatts.csv",
"GFv11_gages_lyr": "data/GFv11/GFv11_gages.rds",
"GFv11_gdb": "data/GFv11/GFv1.1.gdb",
"GFv11_tgf": "data/GFv11/TGF.gdb",
"gagesii_lyr": "data/SWIM_gage_loc/gagesII_9322_point_shapefile",
- "hilari_sites": "data/HILARRI/HILARRI_v2.csv",
+ "hilarri_sites": "data/HILARRI/HILARRI_v2.csv",
+ "res_attributes": "data/reservoir_data/ResOpsUS/attributes/reservoir_attributes.csv",
"istarf": "data/reservoir_data/ISTARF-CONUS.csv",
- "istarf.1": "data/reservoir_data/ISTARF-CONUS.csv",
- "resops_NID_CW": "data/reservoir_data/cw_ResOpsUS_NID.csv"
+ "GRanD": "data/reservoir_data/GRanD_Version_1_3",
+ "resops_NID_CW": "data/reservoir_data/cw_ResOpsUS_NID.csv",
+ "istarf_xwalk": "data/reservoir_data/istarf_xwalk_final_48_gfv11.csv",
+ "usgs_nldi_gages": "data/nldi/usgs_nldi_gages.geojson"
}
diff --git a/workspace/hyfabric_0.5.9.tar.gz b/workspace/hyfabric_0.5.9.tar.gz
deleted file mode 100644
index 31b616395357564b799e956bb67c1708b4e4d9b6..0000000000000000000000000000000000000000
Binary files a/workspace/hyfabric_0.5.9.tar.gz and /dev/null differ
diff --git a/workspace/hyfabric_0.6.0.tar.gz b/workspace/hyfabric_0.6.0.tar.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9d4aee4e3607bb314991ab4c3fa035436f3a3024
Binary files /dev/null and b/workspace/hyfabric_0.6.0.tar.gz differ
diff --git a/workspace/runners/README.md b/workspace/runners/README.md
deleted file mode 100644
index d79d9dbba9e6772000c806f07f9ea2fa2665f878..0000000000000000000000000000000000000000
--- a/workspace/runners/README.md
+++ /dev/null
@@ -1,19 +0,0 @@
-gfv2 runners
-
-## 1. make_docker_calls.Rmd
-
-Generates `navigate_calls.txt` and `hyRefactor_calls.txt` and checks already generated outputs for completeness.
-
-Intended to be run from within a running Docker / Jupyter instance started with docker-compose in the root of this project.
-
-## 2. make_shifter_calls.Rmd
-
-Clone of `make_docker_calls.Rmd` but tailored for the shifter-based containerization environment on Denali.
-
-## 3. batch.sh
-
-Useful on a linux environment with Docker available. Can run `navigate_calls.txt` and `hyRefactor_calls.txt` in parallel.
-
-## 4. run_all_R.R
-
-Simple runner to execute calls in parallel on Windows with Docker.
diff --git a/workspace/runners/batch.sh b/workspace/runners/batch.sh
deleted file mode 100644
index 538501445085dd14a95ed6301724599597dc564a..0000000000000000000000000000000000000000
--- a/workspace/runners/batch.sh
+++ /dev/null
@@ -1,13 +0,0 @@
-#!/bin/bash
-#SBATCH -A impd
-#SBATCH -N 1i
-#SBATCH -c 40
-#SBATCH -n 1
-#SBATCH --job-name=gfv2
-#SBATCH --time=24:00:00
-
-parallel --jobs 20 < workspace/runners/shifter_navigate_calls.txt
-
-shifter --volume="/absolute/path/gfv2/gfv2.0/workspace:/jupyter" --image=dblodgett/hydrogeoenv-custom:latest R -e "rmarkdown::render('/jupyter/04_merge.Rmd', output_file='/jupyter/04_merge.html')"
-
-parallel --tmpdir workspace/temp --delay 30s --jobs 10 < workspace/runners/shifter_hyRefactor_calls.txt
diff --git a/workspace/runners/cleaner.R b/workspace/runners/cleaner.R
deleted file mode 100644
index 304dea66e9ec54be79f68ca46136abdb00df87d3..0000000000000000000000000000000000000000
--- a/workspace/runners/cleaner.R
+++ /dev/null
@@ -1,70 +0,0 @@
-possible_vpu <- c("01", "08", "10L", "15", "02", "04", "05", "06",
- "07", "09", "03S", "03W",
- "03N", "10U", "11", "12",
- "13", "14", "16", "17", "18")
-
-
-vpu_codes <- possible_vpu
-
-# remove all reference fabric content
-reference <- FALSE
-# remove al POI content
-POI <- TRUE
-# remove refactored content leaving rpu-based reference content behind
-refactor <- TRUE
-# remove all aggregate content
-aggregate <- FALSE
-
-for(VPU in vpu_codes) {
-
- rm(rpu_code)
-
- source("R/config.R")
- source("R/utils.R")
-
- if(reference) {
- unlink(nav_gpkg)
- }
-
- if(POI) {
- sf::st_delete(nav_gpkg, final_poi_layer)
- sf::st_delete(nav_gpkg, lookup_table_refactor)
- unlink(temp_gpkg)
- }
-
- if(refactor) {
- unlink(rfc_gpkg)
- }
-
- if(aggregate) {
- unlink(gf_gpkg)
- unlink(ND_gpkg)
- }
-
- if(refactor | aggregate) {
- unlink(vpu_lookup_table_file)
- }
-
- for(r in rpu_codes$rpuid) {
- f <- paste0("cache/", r, "_refactor.gpkg")
- if(refactor & !reference) {
- sf::st_delete(f, lookup_table_refactor)
- sf::st_delete(f, refactored_layer)
- sf::st_delete(f, reconciled_layer)
- sf::st_delete(f, outlets_layer)
- sf::st_delete(f, divide_layer)
- unlink(paste0("cache/", r, "_lookup.csv"))
- }
-
- if(refactor & reference) {
- unlink(f)
- unlink(paste0("cache/", r, "_lookup.csv"))
- }
-
- if(aggregate) {
- unlink(paste0("cache/", r, "_aggregate.gpkg"))
- unlink(paste0("cache/", r, "_lookup.csv"))
- }
- }
-
-}
diff --git a/workspace/runners/local_batch.sh b/workspace/runners/local_batch.sh
deleted file mode 100644
index d3a1761043d52db3b83df22e96b6ca77e121a134..0000000000000000000000000000000000000000
--- a/workspace/runners/local_batch.sh
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/bash
-
-docker run --mount type=bind,source=$PWD/workspace,target=/jupyter dblodgett/hydrogeoenv-custom:latest R -e "rmarkdown::render('/jupyter/01_NHD_prep.Rmd', output_file='/jupyter/reports/01_NHD_prep.html')"
-
-parallel --jobs 5 < workspace/runners/navigate_calls.txt
-
-parallel --jobs 5 < workspace/runners/hyRefactor_calls.txt
-
-parallel --jobs 5 < workspace/runners/finalize_calls.txt
diff --git a/workspace/runners/make_docker_calls.Rmd b/workspace/runners/make_docker_calls.Rmd
deleted file mode 100644
index 3d35450b38a8d9b6a2a0b6738179ab17565ed6ed..0000000000000000000000000000000000000000
--- a/workspace/runners/make_docker_calls.Rmd
+++ /dev/null
@@ -1,191 +0,0 @@
----
-title: "Make Docker Calls"
-output: html_document
----
-
-First chunk creates calls for NHD_navigate and POI_Collapse.
-
-Includes one environment variable for the Hydro Region.
-
-The output .txt file can be executed with GNU parallel like:
-`parallel --jobs 10 < workspace/navigate_calls.txt`
-
-```{r}
-data_paths <- jsonlite::read_json(file.path("../cache", "data_paths.json"))
-
-out_script <- "navigate_calls.txt"
-
-call <- "docker run"
-mount <- "--mount type=bind,source=$PWD/workspace,target=/jupyter"
-docker_image <- "dblodgett/hydrogeoenv-custom:latest"
-
-e1 <- "--env HYDREG=z!z"
-
-command <- paste("R -e \"rmarkdown::render('/jupyter/02_NHD_navigate.Rmd', output_file='/jupyter/reports/02_NHD_navigate_z!z.html')\" \n")
-
-hus <- c(paste0("0", c(1:2, 4:9)),
- "03S", "03W", "03N",
- "10U", "10L",
- paste0("1", c(1:8)))
-
-calls <- sapply(hus, function(hu) gsub("z!z", hu, paste(call, mount, e1, docker_image, command)))
-
-cat("", file = out_script, append = FALSE)
-for(i in 1:length(calls)) {
- cat(calls[i], file = out_script, append = TRUE)
-}
-
- hus
-```
-
-The second chunk checks for completion of the NHD_navigate and POI_Collapse steps.
-
-Any completely missing geopackages and specific missing layers are printed if any.
-
-```{r}
-expect_files <- paste0("reference_", hus, ".gpkg")
-
-have_files <- list.files("/jupyter/cache")
-
-(missing_files <- expect_files[!expect_files %in% have_files])
-
-have_files <- expect_files[expect_files %in% have_files]
-
-expect_layers <- c("POIs", "reference_flowline")
-
-layers <- lapply(file.path("/jupyter/cache", have_files), function(x) sf::st_layers(x)$name)
-
-check <- lapply(layers, function(x, expect_layers) {
- sapply(paste0("^", expect_layers, ".*"), function(y, x) {
- any(grepl(y, unlist(x)))
- }, x = x)
-}, expect_layers = expect_layers)
-
-for(f in seq_along(have_files)) {
- if(any(!check[[f]])) {
- print(paste0(have_files[f], ": ", paste(names(check[[f]])[which(!check[[f]])], collapse = ", ")))
- }
-}
-```
-
-The following creates docker commands for hyRefactor flines and cats.
-
-Three environment variables are set for the output geopackage pack, the Raster Processing Unit, and a cache to be used for error output environments.
-
-The txt file can be used with GNU parallel like:
-`parallel --jobs 10 < workspace/hyRefactor_calls.txt`
-
-```{r}
-out_script <- "hyRefactor_calls.txt"
-
-e1 <- "--env OUT_GPKG=/jupyter/cache/z!z_aggregate.gpkg"
-e11 <- "--env OUT_REFACTOR_GPKG=/jupyter/cache/z!z_refactor.gpkg"
-e2 <- "--env RPU_CODE=z!z"
-e3 <- "--env SPLIT_CACHE=/jupyter/temp/z!z_split.rda"
-e4 <- "--env LOOKUP_TABLE=/jupyter/cache/z!z_lookup.csv"
-
-command <- paste("R -e \"rmarkdown::render('/jupyter/05_hyRefactor_flines.Rmd', output_file='/jupyter/reports/05_hyRefactor_flines_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/06-1_hyRefactor_cats.Rmd', output_file='/jupyter/reports/06-1_hyRefactor_cats_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/06-2_aggregate_cats.Rmd', output_file='/jupyter/reports/06-2_aggregate_cats_z!z.html')\" \n")
-
-all_hus <- gsub("rpu_", "", names(data_paths$fdr))
-
-all_hus <- all_hus[!grepl("^2", all_hus)]
-
-errors <- list.files("temp", "*.rda$", full.names = TRUE)
-errors <- gsub(".rda", "", gsub("temp/", "", errors))
-
-hus <- all_hus[!all_hus %in% errors]
-
-calls <- sapply(hus, function(hu) gsub("z!z", hu, paste(call, mount, e1, e11, e2, e3, e4, docker_image, command)))
-
-cat("", file = out_script, append = FALSE)
-for(i in 1:length(calls)) {
- cat(calls[i], file = out_script, append = TRUE)
-}
-```
-
-The next chunk checks for the expected output geopackages from the above calls.
-
-```{r}
-agg <- paste0(all_hus, "_aggregate.gpkg")
-ref <- paste0(all_hus, "_refactor.gpkg")
-expect_files <- c(ref, agg)
-
-have_files <- list.files("/jupyter/cache")
-
-(missing_files <- expect_files[!expect_files %in% have_files])
-```
-
-The next chunk checks which existing geopackages are missing the reconciled output.
-
-```{r}
-ref <- ref[ref %in% have_files]
-
-missing_reconciled <- sapply(file.path("/jupyter/cache", ref),
- function(x) !"refactored_flowpaths" %in% sf::st_layers(x)$name)
-
-missing_reconciled <- missing_reconciled[missing_reconciled]
-
-dplyr::arrange(tibble::tibble(file = names(missing_reconciled)))
-```
-
-The next chunk checks which divides have been competed and which haven't. This is the first step in catchment refactoring.
-
-```{r}
-missing_div <- sapply(file.path("/jupyter/cache", ref),
- function(x) !"refactored_divides" %in% sf::st_layers(x)$name)
-
-has_div <- missing_div[!missing_div]
-
-missing_div <- missing_div[missing_div]
-
-dplyr::arrange(tibble::tibble(file = names(missing_div)), file)
-
-# dplyr::arrange(tibble::tibble(file = names(has_div)), file)
-```
-
-The next chunk checks which final aggregation have been completed and which haven't.
-
-```{r}
-agg <- agg[agg %in% have_files]
-
-missing_agg <- sapply(file.path("/jupyter/cache", agg),
- function(x) !"aggregated_divides" %in% sf::st_layers(x)$name)
-
-has_agg <- missing_agg[!missing_agg]
-
-missing_agg <- missing_agg[missing_agg]
-
-dplyr::arrange(tibble::tibble(file = names(missing_agg)), file)
-
-dplyr::arrange(tibble::tibble(file = names(has_agg)), file)
-```
-
-```{r}
-out_script <- "finalize_calls.txt"
-
-e1 <- "--env HYDREG=z!z"
-
-command <- paste("R -e \"rmarkdown::render('/jupyter/07-1_merge.Rmd', output_file='/jupyter/reports/07-1_merge_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/07-2_NonDend.Rmd', output_file='/jupyter/reports/07-2_NonDend_z!z.html')\" \n")
-
-command <- paste("R -e \"rmarkdown::render('/jupyter/07-1_merge.Rmd', output_file='/jupyter/reports/07-1_merge_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/07-2_NonDend.Rmd', output_file='/jupyter/reports/07-2_NonDend_z!z.html')\" \n")
-
-hus <- c(paste0("0", c(1:2, 4:9)),
- "03S", "03W", "03N",
- "10U", "10L",
- paste0("1", c(1:8)))
-
-calls <- sapply(hus, function(hu) gsub("z!z", hu, paste(call, mount, e1, docker_image, command)))
-
-cat("", file = out_script, append = FALSE)
-for(i in 1:length(calls)) {
- cat(calls[i], file = out_script, append = TRUE)
-}
-```
-
-```{r}
-
-```
diff --git a/workspace/runners/make_shifter_calls.Rmd b/workspace/runners/make_shifter_calls.Rmd
deleted file mode 100644
index 045fdd2e01acae7aa825284b9b3e8f5ef11f1661..0000000000000000000000000000000000000000
--- a/workspace/runners/make_shifter_calls.Rmd
+++ /dev/null
@@ -1,63 +0,0 @@
----
- title: "Make Shifter Calls"
- output: html_document
----
-
- First chunk creates calls for NHD_navigate and POI_Collapse.
-
-Includes one environment variable for the Hydro Region.
-
-The output .txt file can be executed with GNU parallel like:
- `parallel --jobs 10 < workspace/shifter_navigate_calls.txt`
-
-```{r}
-data_paths <- jsonlite::read_json(file.path("cache", "data_paths.json"))
-
-out_script <- "shifter_navigate_calls.txt"
-
-call <- "shifter"
-mount <- '--volume="/absolute/path/gfv2/gfv2.0/workspace:/jupyter"'
-docker_image <- '--image=dblodgett/hydrogeoenv-custom:latest'
-
-command <- paste("R -e \"Sys.setenv(HYDREG='z!z')\"",
- "-e \"rmarkdown::render('/jupyter/02_NHD_navigate.Rmd', output_file='/jupyter/reports/02_NHD_navigate_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/03_POI_Collapse.Rmd', output_file='/jupyter/reports/03_POI_Collapse_z!z.html')\" \n")
-
-hus <- c(paste0("0", c(1:9)), paste0("1", c(1:8)), "10U", "10L")
-
-calls <- sapply(hus, function(hu) gsub("z!z", hu, paste(call, mount, docker_image, command)))
-
-cat("", file = out_script, append = FALSE)
-for(i in 1:length(calls)) {
- cat(calls[i], file = out_script, append = TRUE)
-}
-```
-
-The following creates docker commands for hyRefactor flines and cats.
-
-Three environment variables are set for the output geopackage pack, the Raster Processing Unit, and a cache to be used for error output environments.
-
-The txt file can be used with GNU parallel like:
- `parallel --jobs 10 < workspace/shifter_hyRefactor_calls.txt`
-
-```{r}
-out_script <- "shifter_hyRefactor_calls.txt"
-
-command <- paste("R -e \"Sys.setenv(OUT_GPKG='/jupyter/cache/z!z.gpkg', RPU_CODE='z!z', SPLIT_CACHE='/jupyter/temp/z!z_split.rda', LOOKUP_TABLE='/jupyter/cache/z!z_lookup.csv')\"",
- "-e \"rmarkdown::render('/jupyter/05_hyRefactor_flines.Rmd', output_file='/jupyter/reports/05_hyRefactor_flines_z!z.html')\"",
- "-e \"rmarkdown::render('/jupyter/07_hyRefactor_cats.Rmd', output_file='/jupyter/reports/07_hyRefactor_cats_z!z.html')\" \n")
-
-all_hus <- gsub("rpu_", "", names(data_paths$fdr))
-
-errors <- list.files("temp", "*.rda$", full.names = TRUE)
-errors <- gsub(".rda", "", gsub("temp/", "", errors))
-
-hus <- all_hus[!all_hus %in% errors]
-
-calls <- sapply(hus, function(hu) gsub("z!z", hu, paste(call, mount, docker_image, command)))
-
-cat("", file = out_script, append = FALSE)
-for(i in 1:length(calls)) {
- cat(calls[i], file = out_script, append = TRUE)
-}
-```
diff --git a/workspace/runners/run_all_R.R b/workspace/runners/run_all_R.R
deleted file mode 100644
index 228c6316d04d2e5a8ece80ab8596c7b85597f442..0000000000000000000000000000000000000000
--- a/workspace/runners/run_all_R.R
+++ /dev/null
@@ -1,16 +0,0 @@
-rmarkdown::render('01_NHD_prep.Rmd',
- output_file='temp/01_NHD_prep_test.html')
-
-setwd("../")
-
-calls <- readLines("workspace/runners/navigate_calls.txt")
-
-cl <- parallel::makeCluster(5, outfile = "workspace/temp/error.log")
-
-pbapply::pblapply(calls, shell, cl = cl)
-
-calls <- readLines("workspace/runners/hyRefactor_calls.txt")
-
-parallel::parLapply(cl = cl, X = calls, fun = shell)
-
-parallel::stopCluster(cl)
diff --git a/workspace/runners/run_one_R.R b/workspace/runners/run_one_R.R
deleted file mode 100644
index 1bfba3df1181372a8435a63302e7b86c6dc987e7..0000000000000000000000000000000000000000
--- a/workspace/runners/run_one_R.R
+++ /dev/null
@@ -1,74 +0,0 @@
-possible_vpu <- c("01", "08", "10L", "15", "02", "04", "05", "06",
- "07", "09", "03S", "03W",
- "03N", "10U", "11", "12",
- "13", "14", "16", "17", "18")
-
-
-vpu_codes <- VPU <- vpu <- "01"
-
-check_file <- file.path("temp/", paste0(VPU, ".lock"))
-
-if(!file.exists(check_file)) {
- cat("...", file = check_file)
-
- source("R/config.R")
- source("R/utils.R")
-
- unlink(rfc_gpkg)
- unlink(nav_gpkg)
- unlink(ND_gpkg)
- unlink(gf_gpkg)
- unlink(temp_gpkg)
- unlink(vpu_lookup_table_file)
-
- for(r in rpu_codes$rpuid) {
- unlink(paste0("cache/", r, "_refactor.gpkg"))
- }
-
- rmarkdown::render('01_NHD_prep.Rmd',
- output_file=paste0('temp/01_NHD_prep_', VPU, '.html'))
-
- rmarkdown::render('02_NHD_navigate.Rmd',
- output_file=paste0('temp/02_NHD_navigate_', VPU, '.html'))
-
- for(rpu_code in rpu_codes$rpuid) {
-
- source("R/config.R")
-
- unlink(out_agg_gpkg)
- unlink(lookup_table_file)
-
- rmarkdown::render("05_hyRefactor_flines.Rmd",
- output_file = paste0("temp/05_hyRefactor_flines_", rpu_code, ".html"))
-
- rmarkdown::render("06-1_hyRefactor_cats.Rmd",
- output_file = paste0("temp/06-1_hyRefactor_cats_", rpu_code, ".html"))
-
- rmarkdown::render("06-2_aggregate_cats.Rmd",
- output_file = paste0("temp/06-2_aggregate_cats_", rpu_code, ".html"))
- }
-
- rmarkdown::render("07-1_merge.Rmd",
- output_file = "temp/07-1_merge_test.html")
-
- rmarkdown::render("07-2_NonDend.Rmd",
- output_file = "temp/07-2_NonDend_test.html")
-
- if(is.na(Sys.getenv("sb_user", unset=NA))){
- message("upload skipped due to lack of login info")
- } else {
-
- library(sbtools)
-
- authenticate_sb(Sys.getenv("sb_user", unset=""), Sys.getenv("sb_pass", unset=""))
-
- sb_reference <- "61295190d34e40dd9c06bcd7"
- sb_refactor <- "61fbfdced34e622189cb1b0a"
- sb_gf <- "60be1502d34e86b9389102cc"
-
- sbtools::item_replace_files(sb_reference, nav_gpkg)
- sbtools::item_replace_files(sb_refactor, rfc_gpkg)
- sbtools::item_replace_files(sb_gf, gf_gpkg)
- }
-
-}
diff --git a/workspace/templates/01_Gage_Selection.Rmd b/workspace/templates/01_Gage_Selection.Rmd
new file mode 100644
index 0000000000000000000000000000000000000000..cd42b86558c916846cf18547efdc94038689760b
--- /dev/null
+++ b/workspace/templates/01_Gage_Selection.Rmd
@@ -0,0 +1,76 @@
+---
+title: "Gage Selection"
+output: html_document
+params:
+ SWIM: list()
+ NHDPlusV2_gages: list()
+ gfv11_gages: list()
+ final_gages: list()
+ min_da_km_gages: 5
+---
+This notebook builds a final set of gages for GFv2.0 from data sources assembled in 00_gage_info.rmd
+
+```{r setup_0, echo=FALSE, cache=FALSE}
+library(mapview)
+knitr::opts_chunk$set(
+ collapse = TRUE,
+ comment = "#>",
+ fig.width = 6,
+ fig.height = 4,
+ cache = FALSE,
+ echo = FALSE)
+```
+
+TODO: write what criteria are used to select gagesIII gages.
+TODO: convert "gagesIII" to SWIM throughout
+
+```{r GAGESIII-SWIM}
+mapview(SWIM$full, layer.name = "all GAGES-III") +
+ mapview(filter(SWIM$full, !site_no %in% SWIM$filtered$site_no),
+ layer.name = "No Q; COMID", col.regions = "red") +
+ # nodata in this layer?
+ # mapview(filter(SWIM$filtered, !site_no %in% SWIM$db$site_no),
+ # layer.name = "Non-ST; POR", col.regions = "purple") +
+ mapview(filter(SWIM$filtered, site_no %in% SWIM$potCanals$site_no),
+ layer.name = "Canals, man. checked", col.regions = "blue") +
+ mapview(filter(SWIM$filtered %>%
+ inner_join(select(SWIM$db, site_no, drain_area),
+ by = "site_no"), drain_area < min_da_km_gages),
+ layer.name = "below min DA", col.regions = "green") +
+ mapview(SWIM$final, layer.name = "Final GAGES-III", col.regions = "orange")
+
+```
+
+TODO: write what criteria are used to select gageloc gages.
+
+```{r GageLoc}
+mapview(NHDPlusV2_gages$full, layer.name = "all GageLoc") +
+ mapview(filter(NHDPlusV2_gages$full, !site_no %in% NHDPlusV2_gages$filtered$site_no),
+ layer.name = "No Q; COMID", col.regions = "red") +
+ # no data in this layer?
+ # mapview(filter(NHDPlusV2_gages$filtered, !site_no %in% NHDPlusV2_gages$db$site_no),
+ # layer.name = "Non-ST; POR", col.regions = "purple") +
+ mapview(filter(NHDPlusV2_gages$filtered, site_no %in% NHDPlusV2_gages$potCanals$site_no),
+ layer.name = "Canals, man. checked", col.regions = "blue") +
+ mapview(filter(NHDPlusV2_gages$filtered %>%
+ inner_join(select(NHDPlusV2_gages$db, site_no, drain_area), by = "site_no"),
+ drain_area < min_da_km_gages),
+ layer.name = "below min DA", col.regions = "green") +
+ mapview(NHDPlusV2_gages$final, layer.name = "Final GageLoc", col.regions = "orange")
+```
+
+TODO: write what criteria was used to select gfv11_gages
+
+```{r Gfv11}
+mapview(gfv11_gages$final, layer.name = "gfv11")
+```
+
+TODO: write summary
+
+```{r Wrapup}
+mapview(final_gages$final, layer.name = "GFv2.0 streamgages", zcol = "source")
+```
+
+
+
+