-
Blodgett, David L. authoredBlodgett, David L. authored
NHD_navigate.R 25.57 KiB
#' 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)
}
#' ### DEPRECATED ###
#' #' Identifies and connects dangles in network generated by Network Nav function
#' #' @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 connecting dangle to existing network
#' NetworkConnection <- function(incom, nhd){
#'
#' upnet_DF <- filter(nhd, COMID %in% incom) %>%
#' filter(!DnHydroseq %in% Hydroseq)
#'
#' # while the number of dangles is greater than 0
#' while (length(upnet_DF$COMID) > 0){
#' # create item for number of dangles
#' count <- dim(upnet_DF)[1]
#' print (dim(upnet_DF))
#' # find out which level paths are downstream of dangling huc12 POIs
#' DSLP <- upnet_DF %>% pull(DnLevelPat)#[upnet_DF$COMID %in% incom]
#' # Get the COMID of the hydroseq with level path value
#' # the lowest downstream flowline within the levelpath
#' inCom2 <- nhd$COMID[nhd$Hydroseq %in% DSLP]
#' # Run the upstream navigation code
#' upNet <- unique(unlist(lapply(inCom2, NetworkNav, nhd)))
#' # Append result to existing segment list
#' incom <- append(incom, upNet)
#' # Get the same variable as above
#' upnet_DF <- filter(nhd, COMID %in% incom, !DnHydroseq %in% Hydroseq)
#' # Get the count
#' count2 <- dim(upnet_DF)[1]
#' # if the count has remained the same we are done and return the flowline list
#' if (count == count2){
#' return (incom)
#' }
#' }
#' # Not sure this other return is needed
#' return(incom)
#' }
#' Switches valid POIs from minor to major path divergences
#' @param inSegs (list) list of input COMIDs representing POIs
#' @param nhdDF (sf data.frame) (data frame) valid data frame of NHD flowlines
#'
#' @return (sf data.frame) Corresponding major path COMID for POI
switchDiv <- function(insegs, nhdDF){
div_segs <- filter(nhdDF, COMID %in% insegs$COMID)
if (2 %in% div_segs$Divergence){
print ("Switching divergence to other fork")
# Look Upstream upstream <- st_drop_geometry(nhdDF) %>%
inner_join(st_drop_geometry(div_segs) %>%
filter(Divergence == 2) %>%
select(COMID, Hydroseq),
by = c("DnMinorHyd" = "Hydroseq"))
# From Upstream Segment switch POI to the downstream major/main path
insegs_maj <- st_drop_geometry(nhdDF) %>%
inner_join(upstream %>% select(COMID.y, DnHydroseq),
by = c("Hydroseq" = "DnHydroseq")) %>%
select(COMID, COMID.y)
insegs <- insegs %>%
left_join(insegs_maj, by = c("COMID" = "COMID.y")) %>%
mutate(COMID = ifelse(!is.na(COMID.y), COMID.y, COMID)) %>% select(-COMID.y)
} else {
print ("no divergences present in POI set")
}
return(insegs)
}
#' Creates POIs for a given data theme
#' @param srcData (data.frame) (data frame) DF with two columns:
# 1 - COMID
# 2 - Unique ID value for POI (Streamgage ID, etc.)
#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
#' @param IDfield character) Name of 'Type' field to be modified in POI
#'
#' @return (sf data.frame) OIs for the specific data theme
POI_creation<-function(srcData, nhdDF, IDfield){
# Give generic ID to Identity field
colnames(srcData) <- c("COMID", "ID")
sub_segs <- filter(nhdDF, COMID %in% srcData$COMID)
POIs <- sub_segs %>%
get_node(., position = "end") %>%
mutate(COMID = sub_segs$COMID) %>%
mutate(Type_HUC12 = NA, Type_WBIn = NA, Type_WBOut = NA, Type_Gages = NA, Type_TE = NA, Type_NID = NA, Type_Conf = NA) %>%
inner_join(srcData %>% select(COMID, ID), by = "COMID") %>%
mutate(!!(paste0("Type_", IDfield)) := ID)
if(!(paste0("Type_", IDfield)) %in% colnames(POIs)){
POIs <- POIs %>% select(COMID, Type_HUC12, Type_Gages, Type_TE, Type_NID, Type_WBIn, Type_WBOut, Type_Conf)
} else {
POIs <- POIs %>% select(COMID, Type_HUC12, Type_Gages, Type_TE,
Type_NID, Type_WBIn, Type_WBOut, Type_Conf, !!(paste0("Type_", IDfield)))
}
return(POIs)
}
#' Adds the type attribute for co-located POIs of multiple themes
#' @param new_POIs (sf data.frame) new POIs to be tested against existing
#' @param POIs (sf data.frame) Existing POIs
#' @param IDfield (character) Name of 'Type' field to be modified in existing POI
#' @param bind (logical) whether to bind non co-located POIs to data frame or just
#' attribute existing POIs
#'
#' @return (sf data.frame) xisting POIs with Type field modified for
# duplicate POIs for given data theme
addType<-function(new_POIs, POIs, IDfield, bind){
new_POIs <- st_compatibalize(new_POIs, POIs)
if(paste0("Type_", IDfield) %in% colnames(POIs)){
POIs_exist <- POIs %>% rename(ID = !!(paste0("Type_", IDfield)))
} else {
POIs_exist <- POIs %>%
mutate(ID = NA)
}
# Add columns missing between master POI and new set
missing_cols <- colnames(POIs)[!colnames(POIs) %in% colnames(new_POIs)]
for(col in missing_cols){
new_POIs <- new_POIs %>%
mutate(!!col := NA)
}
POIs_newAtt <- filter(new_POIs, COMID %in% POIs$COMID) %>%
rename(ID2 = !!(paste0("Type_", IDfield)))
POIs_fin <- POIs_exist %>%
left_join(st_drop_geometry(POIs_newAtt) %>%
select(COMID, ID2), by = "COMID", all.x = TRUE) %>%
mutate(ID = ifelse(!is.na(ID2), ID2, ID)) %>%
rename(!!(paste0("Type_", IDfield)) := ID) %>%
select(-ID2)
# Bind unless indicated not to
if(missing(bind)){
POIs_fin <- rbind(POIs_fin, filter(new_POIs, !COMID %in% POIs_fin$COMID))
}
return(POIs_fin)
}
#' 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){
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 (missing(routing_fix) == FALSE){
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){
POIs <- st_drop_geometry(POIs_wgeom) %>%
arrange(COMID)
# DF of downstream segment
tocomDF <- select(nhd, COMID, DnHydroseq) %>%
inner_join(select(st_drop_geometry(nhd), COMID, Hydroseq), by = c("DnHydroseq" = "Hydroseq"))
# Find segments with POIs where there is no corresponding catchment
unCon_POIs <- filter(nhd, COMID %in% POIs$COMID, AreaSqKM == 0)
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"))
# 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_fix_unique <- filter(POIs, COMID %in% poi_fix$COMID) %>%
bind_rows(poi_fix) %>%
group_by(COMID) %>%
filter(n() > 1) %>%
# Spurs warnings where there are NAs for a column
# for a given grouped COMID, but output is what I expect
summarise_all(funs(min(unique(.[!is.na(.)]), na.rm = T))) %>%
# Replace -Inf with NA where applicaable
mutate_all(~na_if(., -Inf))
# Join new POI COMIDs and geometry with the old Type fields
new_POIs <- bind_rows(filter(poi_fix, !COMID %in% poi_fix_unique$COMID), poi_fix_unique) %>%
arrange(COMID) %>%
bind_cols(get_node(filter(nhd, COMID %in% .$COMID) %>% arrange(COMID), position = "end")) %>%
mutate(to_com = NA) %>%
st_sf() %>%
st_compatibalize(., POIs_wgeom)
# If the DS replacement flowlines with Inc Area > 0 equals the number of replacement comIDs
replacement_tocoms <- st_drop_geometry(new_POIs) %>%
inner_join(select(st_drop_geometry(nhd), COMID, Hydroseq), by = c("DnHydroseq" = "Hydroseq")) %>%
mutate(to_com = COMID.y) %>%
select(oldPOI, COMID.x, COMID.y, AreaSqKM)
# Add downstream COMIDS to the newCOMID
fin_POIs <- new_POIs %>%
left_join(replacement_tocoms, by = "oldPOI") %>%
mutate(to_com = ifelse(!is.na(COMID.y), COMID.y, NA)) %>%
select(-c(TotDASqKM, AreaSqKM.x, DnHydroseq, COMID.x, COMID.y, AreaSqKM.y))
return (list(xWalk = select(poi_fix, COMID, oldPOI), 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){
# Closest POI/US/DS
up_segs <- nhdplusTools::get_UM(nhdDF, poi_fix, sort=T)
seg2fix <- filter(nhdDF, COMID == poi_fix)
# Sorted results and filter out all flowlines w/o catchments
upstuff <- filter(nhdDF, COMID %in% unlist(up_segs)) %>%
arrange(factor(COMID, levels = up_segs)) %>%
filter(AreaSqKM > 0)
down_segs <- nhdplusTools::get_DM(nhdDF, poi_fix, sort=T)
downstuff <- filter(nhdDF, COMID %in% unlist(down_segs)) %>%
arrange(factor(COMID, levels = down_segs)) %>%
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)
}
#' 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
#' @param Seg (sf data.frame) dissolved segments
#' @param Seg2 (sf data.frame) (data frame) raw segments/flowlines
#' @param exp (string) Type of thematic POI being moved round
#' @param DA_diff (float) threshold of drainage area difference to
# consider when merging two POIs
#'
#' @return (list of data.frames) 1 - New set of POIs
# 2/3 - correpsonding segments (both raw and dissolved)
POI_move_down<-function(out_gpkg, POIs, Seg, Seg2, exp, DA_diff){
POIs <- POIs %>% mutate_if(is.numeric, function(x) ifelse(is.infinite(x), NA, x))
# downstream POIs and their drainage area ratios and incremental drainage areas
segs_down <- Seg %>%
inner_join(select(st_drop_geometry(.), c(POI_ID, TotalDA, TotalLength)),
by = c("To_POI_ID" = "POI_ID")) %>%
inner_join(st_drop_geometry(POIs), by = c("POI_ID" = "COMID")) %>%
# Keep WBOut and In to preserve NHD Waterbody geometry, Keep Confluences and TE where they are
filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_TE), all_vars(is.na(.))) %>%
# Select POIs within the correct drainage area ratio and fit the size criteria
mutate(DAR = TotalDA.y/TotalDA.x, IncDA = TotalDA.y - TotalDA.x) %>%
# If the drainage area ratio is within acceptable range (1.05) filter(DAR < (1 + DA_diff), POI_ID != To_POI_ID) %>%
# select and re-order
select(POI_ID, HW, To_POI_ID, Type_HUC12, Type_Gages, Type_TE, Type_NID, Type_WBIn, Type_WBOut, Type_Conf, Type_Term, DAR, IncDA)
# upstream POIs and their drainage area ratios and incremental drainage areas
up_POIs <- filter(POIs, is.na(Type_Conf))
segs_up <- Seg %>% inner_join(select(filter(st_drop_geometry(.), POI_ID %in% up_POIs$COMID),
c(POI_ID, To_POI_ID, TotalDA, TotalLength)),
by = c("POI_ID" = "To_POI_ID")) %>%
inner_join(st_drop_geometry(POIs), by = c("POI_ID" = "COMID")) %>%
rename(From_POI_ID = POI_ID.y) %>%
# Don't want to move outlets upstream, don't move confluences upstream
filter_at(vars(Type_WBOut, Type_WBIn, Type_Conf, Type_TE), all_vars(is.na(.))) %>%
# Select POIs within the correct drainage area ratio and fit the size criteria
mutate(DAR = TotalDA.y/TotalDA.x, IncDA = TotalDA.x - TotalDA.y) %>%
# If the drainage area ratio is within acceptable range (0.95)
filter(DAR >= (1 - DA_diff), POI_ID != From_POI_ID) %>%
# select and re-order
select(POI_ID, HW, From_POI_ID, Type_HUC12, Type_Gages, Type_TE, Type_NID, Type_WBIn, Type_WBOut, Type_Conf, Type_Term, DAR, IncDA)
# Filter by POI Type, this removes the POI theme
Types <- c("Type_Gages", "Type_HUC12", "Type_TE", "Type_Conf", "Type_NID", "Type_WBIn", "Type_WBOut")
Types <- Types[Types != exp]
# Gages coupled with confluences, waterbodies, do not move these
static_POIs <- POIs %>%
filter(!is.na(Type_Gages) & (!is.na(Type_Conf) | !is.na(Type_WBOut) | !is.na(Type_WBIn)))
# compiled list of POIs to move up or down
seg_choices <- filter(POIs, !COMID %in% static_POIs) %>%
left_join(st_drop_geometry(segs_down) %>%
select(POI_ID, To_POI_ID, DAR, IncDA), by = c("COMID" = "POI_ID")) %>%
left_join(st_drop_geometry(segs_up) %>%
select(POI_ID, From_POI_ID, DAR, IncDA), by = c("COMID" = "POI_ID")) %>%
filter(!is.na(To_POI_ID) | !is.na(From_POI_ID)) %>%
filter(IncDA.x < min_da_km | IncDA.y < min_da_km)
# We only want to move POIs that are not coupled within another theme
seg_sub <- seg_choices %>%
filter_at(Types, all_vars(is.na(.))) %>%
# Don't want to move the static POIS either
filter(!COMID %in% static_POIs$COMID) %>%
select (COMID, To_POI_ID, DAR.x, IncDA.x, From_POI_ID, DAR.y, DAR.y, IncDA.y) %>%
st_sf()
# Commented for QAQCing
#st_write(seg_sub, out_gpkg, "Seg_choices", delete_layer = F, append = T)
# Data frame to indicate whether POIs should be grouped upstream or downstream
segsub_dir <- mutate(seg_sub, DirDA = ifelse(is.na(DAR.y), "Down",
ifelse(is.na(DAR.x), "Up",
ifelse(IncDA.x < IncDA.y, "Down", "Up"))),
Move = ifelse(DirDA == "Down", To_POI_ID, From_POI_ID))
# POIs whose moves correspond to each others locations
Mult <- select(segsub_dir, -c(To_POI_ID, From_POI_ID)) %>% #select(segsub_dir, COMID, Move) %>%
inner_join(st_drop_geometry(.), by = c("Move" = "COMID"), suffix = c(".A", ".B"))
# Basicly just chose one of the pair in Mult.
segsub_dir <- filter(segsub_dir, !COMID %in% Mult$Move)
#1 - POIs that need to be moved downstream
move_POI <- filter(POIs, COMID %in% segsub_dir$COMID)
# POIs that are stationary and their infomration will be merged with upstream POIs
stationary_POI <- filter(POIs, !COMID %in% move_POI$COMID)
# Final Set to be merged with that don't involve either sets above
#FinalPOI <- POIs %>% filter(!COMID %in% SegSub_Dir$COMID & !COMID %in% SegSub_Dir$Move) %>%
# mutate(merged_COMID = NA)
#2 - Join SegSub assignment to POIs to bring over POI attributes
movedownPOI_withatt <- select(st_drop_geometry(segsub_dir), COMID, DirDA, Move) %>%
left_join(st_drop_geometry(move_POI), by = "COMID")
# Join SegSub mod to downstream POIs, COMID.x is the final COMID
merged_POIs <- stationary_POI %>%
inner_join(movedownPOI_withatt,
by = c("COMID" = "Move"), suffix = c(".x", ".y")) %>%
mutate_all(., list(~na_if(.,""))) %>%
# Don't overwrite existing gages or HUC12s
filter(is.na(!!as.symbol(paste0(exp, ".x")))) %>%
# Bring over relevant attributes
mutate(Type_HUC12 = ifelse(is.na(Type_HUC12.y), Type_HUC12.x, Type_HUC12.y)) %>%
mutate(Type_Gages = ifelse(is.na(Type_Gages.x), Type_Gages.y, Type_Gages.x)) %>%
mutate(Type_WBIn = ifelse(is.na(Type_WBIn.y), Type_WBIn.x, Type_WBIn.y)) %>%
mutate(Type_WBOut = ifelse(is.na(Type_WBOut.y), Type_WBOut.x, Type_WBOut.y)) %>%
mutate(Type_TE = ifelse(is.na(Type_TE.y), Type_TE.x, Type_TE.y)) %>%
mutate(Type_NID = ifelse(is.na(Type_NID.y), Type_NID.x, Type_NID.y)) %>%
mutate(Type_Conf = ifelse(is.na(Type_Conf.y), Type_Conf.x, Type_Conf.y)) %>%
mutate(Type_Term = ifelse(is.na(Type_Term.y), Type_Term.x, Type_Term.y)) %>%
mutate(oldPOI = COMID.y, to_com = NA) %>%
select(COMID, Type_HUC12, Type_Gages, Type_WBIn, Type_WBOut,
Type_TE, Type_NID, Type_Conf, Type_Term, DirDA, oldPOI = COMID.y) %>%
group_by(COMID) %>%
summarize_all(~paste(unique(na.omit(.)), collapse = ',')) %>%
st_sf()
print(colnames(POIs))
print(colnames(merged_POIs))
# Bring new POI data over to new data
fin_POIs <- filter(POIs, !COMID %in% c(merged_POIs$oldPOI, merged_POIs$COMID)) %>%
rbind(merged_POIs %>% select(-c(DirDA, oldPOI)))
#inner_join(st_drop_geometry(merged_POIs) %>% select(COMID, Type_Gages_A), by = "COMID") %>%
#mutate(Type_Gages = ifelse(!is.na(Type_Gages_A), Type_Gages_A, Type_Gages)) %>% select(-Type_Gages_A)
changed_POIs <- POIs %>%
inner_join(select(st_drop_geometry(merged_POIs), COMID, oldPOI)) %>%
select(COMID, oldPOI, Type_HUC12, Type_Gages, Type_TE, Type_NID, Type_WBIn, Type_WBOut, Type_Conf, Type_Term) %>%
mutate(to_com = COMID) %>%
st_compatibalize(., read_sf(out_gpkg, poi_moved_layer))
st_write(changed_POIs, out_gpkg, poi_moved_layer, append = TRUE) # write_sf not appending?
# Format POI moves to table
xWalk <- select(st_drop_geometry(segsub_dir), Move, COMID) %>%
filter(!is.na(Move), Move %in% merged_POIs$COMID) %>%
rename(COMID = Move, oldPOI = COMID)
st_write(xWalk, out_gpkg, "collapse_xWalk", append = TRUE) # write_sf not appending?
newSegs <- segment_creation(mutate(Seg2, old_POI_ID = POI_ID), xWalk)
newSegs$raw_segs <- distinct(newSegs$raw_segs, .keep_all = T)
# Return POIs, segments, and raw segments
return (list(allPOIs = fin_POIs, segs = newSegs$diss_segs, FL = newSegs$raw_segs))
}
#' Identifies and attributes structural POIs
#' @param nhdDF (sf data.frame) valid data frame of NHD flowlines
#' @param final_POIs (sf data.frame) final POIs
#'
#' @return (data.frame columns) 1/0 Columns indicating structural POIs and the structural network
structPOIsNet <- function(nhdDF, final_POIs){
# subset to flowlines used for nsegments
inc_segs <- filter(nhdDF, !is.na(POI_ID))
# Terminal outlets from the initial network
termout <- filter(nhdDF, !Hydroseq %in% DnHydroseq & TerminalFl == 1 & !COMID %in% final_POIs$COMID)
# POIs that are also terminal outlets
out_POIs <- filter(nhdDF, COMID %in% final_POIs$COMID & TerminalFl == 1)
# Confluence POIs
conf_POIs <- filter(inc_segs, COMID %in% final_POIs$COMID[!is.na(final_POIs$Type_Conf)])
# Waterbody outlet POIs
wb_POIs <- filter(inc_segs, COMID %in% final_POIs$COMID[!is.na(final_POIs$Type_WBOut) | !is.na(final_POIs$Type_WBIn)])
# Waterbody inlets POIs
struc_flines <- termout %>%
bind_rows(out_POIs, conf_POIs, wb_POIs) %>%
arrange(COMID)
struc_flines <- struc_flines[!st_is_empty(struc_flines), , drop = F] %>%
st_cast("LINESTRING")
struc_POIs <- get_node(struc_flines, position = "end") %>%
mutate(COMID = struc_flines$COMID, LevelPathI = struc_flines$LevelPathI)
# Add back in any levelpaths missing (shouldn't be much)
miss_LP <- filter(inc_segs, COMID %in% final_POIs$COMID) %>%
filter(!LevelPathI %in% struc_POIs$LevelPathI)
# Only bind if there are rows present
if (nrow(miss_LP) > 0){
lp_POIs <- c(miss_LP$LevelPathI, struc_POIs$LevelPathI)
} else {
lp_POIs <- struc_POIs$LevelPathI
}
# final stuctural POIs, order by COMID to match with strucPOIs
final_struct <- filter(nhdDF, Hydroseq %in% lp_POIs) %>%
arrange(COMID)
struct_POIs <- get_node(final_struct, position = "end") %>%
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(nhd))))
# Subset NHDPlusV2 flowlines to navigation results and write to shapefile
structnet <- filter(nhdDF, COMID %in% final_net & grepl(paste0("^", VPU, ".*"), .data$VPUID))
# Write out minimally-sufficient network and POIs as a list
return(list(struc_POIs = struc_POIs, structnet = structnet))
}