diff --git a/workspace/R/02_POI_creation_functions.R b/workspace/R/02_POI_creation_functions.R
index e4ed26080afd29fd50a9d98b3448783d54eacf2c..aa89549ac23c9dd7b847b5e647b88551196a97de 100644
--- a/workspace/R/02_POI_creation_functions.R
+++ b/workspace/R/02_POI_creation_functions.R
@@ -1393,10 +1393,12 @@ create_wb_inlet_pois <- function(tmp_POIs, wb_lyr, events,
if(!all(is.na(wb_layers$events))) {
wb_inlet_events <- wb_layers$events %>%
select(COMID, REACHCODE, REACH_meas, POI_identifier,
- event_type, nexus)
+ event_type, nexus)
+
+ events <- rbind(events, st_compatibalize(wb_inlet_events, events))
}
- list(tmp_POIs = wb_in_col$POIs, wb_inlet_events = wb_inlet_events)
+ list(tmp_POIs = wb_in_col$POIs, events = events)
}
### used as part of waterbody poi creation in the workflow
@@ -1738,7 +1740,7 @@ create_time_of_travel_pois <- function(tmp_POIs, flowline, all_nhdplus_attribute
#TODO Add magic numbers to config file
tt_splits <- tt_pois_split %>%
st_drop_geometry() %>%
- group_by(POI_ID) %>%ave
+ group_by(POI_ID) %>%
arrange(-Hydroseq) %>%
mutate(ind = cs_group(FL_tt_hrs, travt_diff * 0.75)) %>%
ungroup() %>%
@@ -1757,4 +1759,665 @@ create_time_of_travel_pois <- function(tmp_POIs, flowline, all_nhdplus_attribute
list(tmp_POIs = tmp_POIs)
+}
+
+#' create final POIs
+#' @param tmp_POIs POIs from previous step
+#' @param flowline flowlines to attach pois to
+create_final_pois <- function(tmp_POIs, flowline) {
+
+ unCon_POIs <- filter(tmp_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(tmp_POIs, filter(flowline, 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")))
+
+ } 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.
+ final_POIs <- mutate(tmp_POIs, Type_Term = ifelse(nexus == 1, NA, Type_Term))
+
+ }
+
+ list(final_POIs = final_POIs, xwalk = xWalk, new_POIs = new_POIs,
+ unCon_POIs = unCon_POIs)
+}
+
+### 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(final_POIs, flowline, xWalk) {
+
+ 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% final_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)
+
+}
+
+#' 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) {
+
+ # number POIs
+ final_POIs_prec <- mutate(final_POIs, id = row_number(), moved = NA)
+
+ collapse <- TRUE
+
+ moved_pois <- get_moved_pois(final_POIs_prec, poi_dar_move, poi_distance_move, flowline)
+
+ check_dups <- moved_pois$final_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(final_POIs = final_POIs_prec,
+ duplicate_pois = dups,
+ pois_collapsed = moved_pois$pois_collapsed)
+}
+
+### used when poi_move.R is sourced in POI collapse phase of workflow
+### consider calling at the end of each poi creation process?
+#' 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(final_POIs = final_POIs, pois_collapsed = moved_pois_table)
+
+}
+
+create_poi_lookup <- function(final_POIs, events, full_cats,
+ flowline, pois_collapsed) {
+
+ # 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(!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
+ # full_cats <- readRDS(data_paths$fullcats_table)
+
+ 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)
+
}
\ No newline at end of file
diff --git a/workspace/R/NHD_navigate.R b/workspace/R/NHD_navigate.R
index ec76a7dafd061e301d2212065192e9061217b3eb..644912655e3bd951430eddd7cf7fa119f7d4d7b7 100644
--- a/workspace/R/NHD_navigate.R
+++ b/workspace/R/NHD_navigate.R
@@ -1,202 +1,3 @@
-#' 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))
-}
-
-### 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)
-}
-
### NOTUSED?
#' Collaposes/merges POIs together based on drainage area ratio and data theme
#' @param out_gpkg (geopackage) output geopackage to write intermediate results to
@@ -507,136 +308,3 @@ split_elev <- function(in_POI_ID, split_DF, elev_diff, max_DA){
}
return(split_elev_DF)
}
-
-### used when poi_move.R is sourced in POI collapse phase of workflow
-### consider calling at the end of each poi creation process?
-#' 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))
-
-}
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/_targets/02_POI_creation_targets.R b/workspace/_targets/02_POI_creation_targets.R
index f6c19d43be425ce89ab4bab571b2f86ca49947a4..b66c4956c319aa800204c92554e08417e3d2af96 100644
--- a/workspace/_targets/02_POI_creation_targets.R
+++ b/workspace/_targets/02_POI_creation_targets.R
@@ -12,6 +12,7 @@ source("R/config.R")
source("R/user_vars.R")
source("R/utils.R")
source("R/02_POI_creation_functions.R")
+source("R/poi_move.R")
prep_path <- ".targets_stores/01_prep/objects/"
@@ -27,6 +28,8 @@ list(tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
pattern = map(nav_gpkg), deployment = "worker"),
tar_target(all_nhdplus_attributes,
sf::st_drop_geometry(sf::read_sf(data_paths$nhdplus_gdb, "NHDFlowline_Network"))),
+ tar_target(full_cat_file, data_paths$fullcats_table, format = "file"),
+ tar_target(full_cat_table, readRDS(full_cat_file)),
### huc12 pois
tar_target(huc12_poi, create_hu12_pois(read_sf(data_paths$hu12_points_path, "hu_points"),
@@ -148,5 +151,23 @@ list(tar_target(data_paths_file, "cache/data_paths.json", format = "file"),
updated_flowline_confluence,
all_nhdplus_attributes,
"Travel"),
- pattern = map(elevation_break_pois, updated_flowline_confluence), deployment = "worker")
+ pattern = map(elevation_break_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(final_pois, create_final_pois(time_of_travel_pois$tmp_POIs,
+ updated_flowline_confluence),
+ pattern = map(time_of_travel_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(draft_segments, create_draft_segments(final_pois$final_POIs,
+ updated_flowline_confluence,
+ final_pois$xwalk),
+ pattern = map(final_pois, updated_flowline_confluence), deployment = "worker"),
+
+ tar_target(collapsed_pois, collapse_pois(final_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$final_POIs, wb_inlet_pois$events,
+ full_cat_table, updated_flowline_confluence, collapsed_pois$pois_collapsed),
+ pattern = map(collapsed_pois, wb_inlet_pois, updated_flowline_confluence))
)
\ No newline at end of file
diff --git a/workspace/workflow_runner.R b/workspace/workflow_runner.R
index 090e00a77e60da7468df00fdd368d1f4a514b1fb..9fd575782d61558c8867925b7bdcc82afc7485ed 100644
--- a/workspace/workflow_runner.R
+++ b/workspace/workflow_runner.R
@@ -38,9 +38,11 @@ if(FALSE) { # this won't run if you just bang through this file
tar_make(callr_function = NULL)
}
+workers <- 8
+
# 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 = 8)
+tar_make_future(rpu_vpu_out_list, workers = workers)
tar_make(rpu_vpu_out)
# make sure to run all too!
@@ -48,19 +50,22 @@ tar_make()
Sys.setenv(TAR_PROJECT = "02_POI_creation")
-tar_make_future(huc12_poi, workers = 8)
-tar_make_future(gage_pois, workers = 8)
-tar_make_future(te_pois, workers = 8)
-tar_make_future(resops_pois, workers = 8)
-tar_make_future(hilarri_pois, workers = 8)
-tar_make_future(wb_outlet_pois, workers = 8)
-tar_make_future(write_wb_flowline_mod, workers = 8)
-tar_make_future(ar_event_pois, workers = 8)
-tar_make_future(terminal_pois, workers = 8)
-tar_make_future(updated_flowline_confluence, workers = 8)
-tar_make_future(wb_inlet_pois, workers = 8)
-tar_make_future(nid_pois, workers = 8)
-tar_make_future(headwater_pois, workers = 8)
-tar_make_future(elevation_break_pois, workers = 8)
-tar_make_future(time_of_travel_pois, workers = 8)
-
+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)