From f9ff2b624b4d0bb84bae8575b66ecab604adcb06 Mon Sep 17 00:00:00 2001
From: Bock <abock@usgs.gov>
Date: Tue, 16 May 2023 16:54:47 -0600
Subject: [PATCH] minor mods to AddType after testing
---
hyfabric/R/poi_creation.R | 62 +++++++++++++++++++++++++++------------
1 file changed, 43 insertions(+), 19 deletions(-)
diff --git a/hyfabric/R/poi_creation.R b/hyfabric/R/poi_creation.R
index 506d3e8..f4be000 100644
--- a/hyfabric/R/poi_creation.R
+++ b/hyfabric/R/poi_creation.R
@@ -45,14 +45,19 @@ POI_creation<-function(srcData, nhdDF, IDfield){
#'
addType <- function(new_POIs, POIs, IDfield, nexus = TRUE, bind = TRUE){
+ # Compatibalize new points to add
new_POIs <- st_compatibalize(new_POIs, POIs)
- # subset Nexus POIs from Type
- if(nexus){
- nexus_POIs <- filter(POIs, nexus == TRUE)
- POIs <- filter(POIs, nexus %in% c(FALSE, NA))
+ # If nexus not a field, add it to existing POIs
+ if(!"nexus" %in% colnames(POIs)){
+ POIs <- mutate(POIs, nexus = FALSE)
+ }
+
+ if(!"nexus" %in% colnames(new_POIs)){
+ new_POIs <- mutate(new_POIs, nexus = FALSE)
}
+ # Check if ID field exists in POIs, add if not
if(paste0("Type_", IDfield) %in% colnames(POIs)){
POIs_exist <- POIs %>%
rename(ID = !!(paste0("Type_", IDfield)))
@@ -61,33 +66,52 @@ addType <- function(new_POIs, POIs, IDfield, nexus = TRUE, bind = TRUE){
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)
+ # subset Nexus POIs from old POIs (if they exist)
+ if(nexus){
+ # subset existing nexus/split locations to keep unique
+ nexus_POIs <- filter(POIs, nexus)
+ # Non-nexus POIs
+ POIs <- filter(POIs, !nexus)
}
- POIs_newAtt <- filter(new_POIs, COMID %in% POIs$COMID) %>%
+ # Non-nexus POIs to bind attributes to existing POI
+ POIs_newAtt <- filter(new_POIs, COMID %in% POIs$COMID,
+ !nexus) %>%
rename(ID2 = !!(paste0("Type_", IDfield)))
- POIs_fin <- POIs_exist %>%
+ # Bind attributes
+ POIs_orig <- POIs_exist %>%
left_join(st_drop_geometry(POIs_newAtt) %>%
- select(COMID, ID2), by = "COMID") %>% #, all.x = TRUE) %>%
+ select(COMID, ID2), by = "COMID") %>%
mutate(ID = ifelse(!is.na(ID2), ID2, ID)) %>%
rename(!!(paste0("Type_", IDfield)) := ID) %>%
select(-ID2)
- # Bind unless indicated not to
+ # Non-nex POI new to POI set
+ POIs_new <- filter(new_POIs, !COMID %in% POIs$COMID)
+
+ # If binding and non-nexus HL values exist to bind
if(bind){
- POIs_fin <- data.table::rbindlist(list(POIs_fin, filter(new_POIs, !COMID %in% POIs_fin$COMID)),
- fill = TRUE) %>%
- st_as_sf()
+ # If POIs exist for new HL reference
+ if (nrow(POIs_new) > 0){
+ POIs_fin <- data.table::rbindlist(list(POIs_orig,
+ POIs_new),
+ fill = TRUE) %>%
+ st_as_sf()
+ } else {
+ POIs_fin <- POIs_orig
+ }
+ } else {
+ POIs_fin <- POIs_orig
}
- # Add nexus back in if excluded
- if(nexus){
- POIs_fin <- data.table::rbindlist(list(POIs_fin, nexus_POIs), fill = TRUE) %>%
+ # Split events that are added
+ new_nexus <- filter(new_POIs, nexus)
+
+ # Bind and is nexus
+ if(nrow(new_nexus) > 0){
+ POIs_fin <- data.table::rbindlist(list(POIs_orig, new_nexus),
+ fill = TRUE) %>%
st_as_sf()
}
--
GitLab