Bbox

HARP-2023-Summer/Mapping/Config/mapstyle_config.R

@@ -175,12 +175,12 @@ run_sets <- list(
       list(
         data_set = 'rseg_no_geom',
         metric='l30_Qout', 
-        column_name='percentDiff_l30_Qout_runid_0_runid_601', 
+        column_name='percentDiff_l30_Qout_runid_0_runid_600', 
         run_label = '2040 WSP L30 %', 
         show_map = TRUE,
         ramp = 'default',
-        tables_cols = c('name', 'riverseg', 'Metric', 'runid_401_l30_Qout', 'runid_601_l30_Qout', 'percentDiff_l30_Qout_runid_0_runid_601'),
-        sort_col = 'percentDiff_l30_Qout_runid_401_runid_601',
+        tables_cols = c('name', 'riverseg', 'Metric', 'runid_400_l30_Qout', 'runid_600_l30_Qout', 'percentDiff_l30_Qout_runid_0_runid_600'),
+        sort_col = 'percentDiff_l30_Qout_runid_400_runid_600',
         floor = NULL, 
         ceiling = NULL, 
         n_entries = NULL,
@@ -190,12 +190,12 @@ run_sets <- list(
       list(
         data_set = 'rseg_no_geom',
         metric='7q10', 
-        column_name='percentDiff_7q10_runid_0_runid_601', 
+        column_name='percentDiff_7q10_runid_0_runid_600', 
         run_label = '2040 WSP 7q10 %', 
         show_map = TRUE,
         ramp = 'default',
-        tables_cols = c('name', 'riverseg', 'Metric', 'runid_401_7q10', 'runid_601_7q10', 'percentDiff_7q10_runid_0_runid_601'),
-        sort_col = 'percentDiff_7q10_runid_401_runid_601',
+        tables_cols = c('name', 'riverseg', 'Metric', 'runid_400_7q10', 'runid_600_7q10', 'percentDiff_7q10_runid_0_runid_600'),
+        sort_col = 'percentDiff_7q10_runid_400_runid_600',
         floor = NULL, 
         ceiling = NULL, 
         n_entries = NULL,
@@ -205,12 +205,42 @@ run_sets <- list(
       list(
         data_set = 'rseg_no_geom',
         metric='Smin_L30_mg', 
-        column_name='runid_601_Smin_L30_mg', 
+        column_name='runid_600_Smin_L30_mg', 
         run_label = 'Minimum Storage', 
         show_map = TRUE,
         ramp = 'default',
-        tables_cols = c('name', 'riverseg', 'Metric', 'runid_401_Smin_L30_mg', 'runid_601_Smin_L30_mg', 'percentDiff_Smin_L30_mg_runid_0_runid_601'),
-        sort_col = 'runid_601_Smin_L30_mg',
+        tables_cols = c('name', 'riverseg', 'Metric', 'runid_400_Smin_L30_mg', 'runid_600_Smin_L30_mg', 'percentDiff_Smin_L30_mg_runid_0_runid_600'),
+        sort_col = 'runid_600_Smin_L30_mg',
+        floor = NULL, 
+        ceiling = NULL, 
+        n_entries = NULL,
+        sort = 'increasing',
+        exlude_NAs = FALSE
+      ),
+      list(
+        data_set = 'facils_nogeom',
+        metric='base_demand_mgd', #replace with unmet demand req 
+        column_name='runid_600_base_demand_mgd', 
+        run_label = 'Highest 30 Day Potential Unmet Demand (MGD)', 
+        show_map = FALSE,
+        ramp = 'default',
+        tables_cols = c('Facility', 'Facility_hydroid', 'riverseg', 'runid_400_base_demand_mgd',  'runid_600_base_demand_mgd', 'runid_18_base_demand_mgd' ,'gw_frac'),
+        sort_col = 'runid_600_base_demand_mgd',
+        floor = NULL, #floor = 0.001, 
+        ceiling = NULL,
+        n_entries = 999,
+        sort = 'decreasing',
+        exlude_NAs = TRUE #exlude_NAs = FALSE
+      ),
+      list(
+        data_set = 'rseg_no_geom',
+        metric='wd_cumulative_mgd', 
+        column_name='runid_18_wd_cumulative_mgd', 
+        run_label = 'Minimum Storage', 
+        show_map = TRUE,
+        ramp = 'default',
+        tables_cols = c('name', 'riverseg', 'Metric', 'runid_400_wd_cumulative_mgd', 'runid_600_wd_cumulative_mgd', 'percentDiff_wd_cumulative_mgd_runid_0_runid_600'),
+        sort_col = 'runid_600_wd_cumulative_mgd',
         floor = NULL, 
         ceiling = NULL, 
         n_entries = NULL,

HARP-2023-Summer/Mapping/Dataframe_Generator.Rmd

@@ -12,6 +12,7 @@ params:
   rivseg_metric: ["l90_Qout", "l30_Qout", "7q10", "Qout", "Smin_L30_mg"] #l30_Qout, l90_Qout, 7q10
   baseline_runid_list: [ "runid_11", "runid_1000" ]
   crs_default: 4326
+  region_extent: FALSE #region_extent = c(-77.66502, 37.12323, -76.78439, 37.58390)
   limit_featrs_to_origin: FALSE #if TRUE -> featrs will be cutoff at the region/locality specified
                                   #if FALSE --> all featrs in the associated basins will be plotted
   overwrite_files: TRUE #if FALSE -> will stop execution if rivseg and feature files already exist
@@ -43,6 +44,13 @@ if (is.logical(foundation_path)) {
   foundation_path <- foundation_location
 }
 
+if (!is.logical(region_extent)) {
+  names(region_extent) = c("xmin","ymin","xmax","ymax")
+  region_extent = st_as_sfc(st_bbox(region_extent), crs=crs_default)
+  region_extent = st_set_crs(region_extent,crs_default)
+}
+
+
 #note: the variables "github_location" and "export_path" should be defined in config.local
 #github_location provides easy access to functions & dataset resources ; export_path is where generated dataframes will output
 ```
@@ -369,13 +377,17 @@ if (origin_type=="basin") { #finding upstream riversegs for basin maps
 }
 #---Sources/featrs---
 #filtering data to only points within the extent of interest, either locality/region boundary or the basins/riversegs intersecting the extent
-if (limit_featrs_to_origin==FALSE | origin_type=="basin") {
-  featrs <- st_filter(featrs, rsegs)
-} else if (limit_featrs_to_origin==TRUE){
-  if(origin_type=="locality"){
-    featrs <- st_filter(featrs, counties[counties$name==origin, ])
-  } else if (origin_type=="region") {
-    featrs <- st_filter(featrs, regions[regions$region==origin,])
+if (!is.logical(region_extent)) {
+  featrs <- st_filter(featrs, region_extent)
+} else {
+  if (limit_featrs_to_origin==FALSE | origin_type=="basin") {
+    featrs <- st_filter(featrs, rsegs)
+  } else if (limit_featrs_to_origin==TRUE){
+    if(origin_type=="locality"){
+      featrs <- st_filter(featrs, counties[counties$name==origin, ])
+    } else if (origin_type=="region") {
+      featrs <- st_filter(featrs, regions[regions$region==origin,])
+    }
   }
 }
 ```

HARP-2023-Summer/Mapping/Functions/fn_nhd_labs.R

@@ -1,60 +1,65 @@
-#NHD data labeling prep -- originally part of fn_labelprep.R
-# for current specific use:
-# data = nhd
-
-# JK 8.8.23: Need to load the config file for this to run
-# Will need to explicitly pass in params such as nhd_rivname_pattern
-source(paste0(github_uri,"/HARP-2023-Summer/Mapping/Config/mapstyle_config.R"),local = TRUE) #load mapping aesthetics
-fn_nhd_labs <- function(data) {
-
-  for(d in 1:length(data)){
-  ## NHD Data
-    # First organize flowline data with major rivers/streams
-    ## major rivs = orders 5 & 6; streams = order 4
-    flow <- nhd$flowline[nhd$flowline$gnis_name!=' ' & #name!=blank & order 4, 5, or 6
-                           (nhd$flowline$StreamOrde==6 | nhd$flowline$StreamOrde==5 | nhd$flowline$StreamOrde==4),]
-    ## no duplicate names; prioritize higher order names and then the longest segment of each duplicate
-    flow <- flow[order(-flow$StreamOrde, flow$gnis_name, -flow$LENGTHKM) & !duplicated(flow$gnis_name),]
-    ## shorten long names
-    flow$gnis_name <- mgsub(flow$gnis_name,
-                            nhd_rivname_pattern, #pattern
-                            nhd_rivname_replacements) #replacement
-    flow$StreamOrde <- mgsub(flow$StreamOrde, nhd_streamorders, nhd_streamclasses)
-    flow <- flow[,c("gnis_name","StreamOrde")] #geometry is still attached
-    colnames(flow) <- gsub("StreamOrde", "class", colnames(flow))
-
-    # Now do the same for the water bodies
-    wtbd <- rbind(nhd$network_wtbd, nhd$off_network_wtbd)
-    ## remove ones without names and ponds/swamps
-    wtbd <- wtbd[!(wtbd$gnis_name==' ' | wtbd$gnis_name=='Noname'),]
-    wtbd <- wtbd[!grepl(c(wtbd_names_rm), wtbd$gnis_name),] #remove certain names from waterbody labeling, wtbd_names_rm from mapstyles_config
-    wtbd <- wtbd[!is.na(wtbd$lakevolume),]
-    #wtbd <- wtbd[!grepl("Millpond", wtbd$gnis_name),] 
-   # wtbd <- wtbd[!grepl("Swamp", wtbd$gnis_name),]
-
-
-    #classification of waterbodies with classes based on their size
-    wtbd_small <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_sm_pct_range[1], na.rm = T) & 
-                         wtbd$lakevolume < quantile(wtbd$lakevolume, wtbd_sm_pct_range[2], na.rm = T),]
-    wtbd_small$class <- rep("waterbody_sm", nrow(wtbd_small)) #add class column
-
-    wtbd_med <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_med_pct_range[1], na.rm = T) & 
-                       wtbd$lakevolume < quantile(wtbd$lakevolume, wtbd_med_pct_range[2], na.rm = T),]
-    wtbd_med$class <- rep("waterbody_med", nrow(wtbd_med)) #add class column
-
-    wtbd_large <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_med_pct_range[2], na.rm = T),]
-    wtbd_large$class <- rep("waterbody_lg", nrow(wtbd_large)) #add class column
-
-    ##something wrong -- too many bodies classified as large 
-
-    wtbd <- rbind(wtbd_small,wtbd_med,wtbd_large)
-    wtbd <- wtbd[,c("gnis_name","class")]
-    wtbd <- wtbd[!is.na(wtbd$gnis_name),]
-
-    nhdlabs <- rbind(flow, wtbd)
-    names(nhdlabs)[names(nhdlabs) == 'gnis_name'] <- 'label'
-    # now it is ready to have coords calculated like the rest of the labeling data
-#    assign('data', data, envir = globalenv())#save df to environment
-    }
-  return(nhdlabs)
+#NHD data labeling prep -- originally part of fn_labelprep.R
+# for current specific use:
+# data = nhd
+
+# JK 8.8.23: Need to load the config file for this to run
+# Will need to explicitly pass in params such as nhd_rivname_pattern
+source(paste0(github_uri,"/HARP-2023-Summer/Mapping/Config/mapstyle_config.R"),local = TRUE) #load mapping aesthetics
+fn_nhd_labs <- function(data) {
+
+  for(d in 1:length(data)){
+  ## NHD Data
+    # First organize flowline data with major rivers/streams
+    ## major rivs = orders 5 & 6; streams = order 4
+    flow <- nhd$flowline[nhd$flowline$gnis_name!=' ' & #name!=blank & order 4, 5, or 6
+                           (nhd$flowline$StreamOrde==6 | nhd$flowline$StreamOrde==5 | nhd$flowline$StreamOrde==4),]
+    ## no duplicate names; prioritize higher order names and then the longest segment of each duplicate
+    flow <- flow[order(-flow$StreamOrde, flow$gnis_name, -flow$LENGTHKM) & !duplicated(flow$gnis_name),]
+    ## shorten long names
+    flow$gnis_name <- mgsub(flow$gnis_name,
+                            nhd_rivname_pattern, #pattern
+                            nhd_rivname_replacements) #replacement
+    flow$StreamOrde <- mgsub(flow$StreamOrde, nhd_streamorders, nhd_streamclasses)
+    flow <- flow[,c("gnis_name","StreamOrde")] #geometry is still attached
+    colnames(flow) <- gsub("StreamOrde", "class", colnames(flow))
+
+    # Now do the same for the water bodies
+    wtbd <- rbind(nhd$network_wtbd, nhd$off_network_wtbd)
+    ## remove ones without names and ponds/swamps
+    wtbd <- wtbd[!(wtbd$gnis_name==' ' | wtbd$gnis_name=='Noname'),]
+    if (!is.null(wtbd)) {
+      wtbd <- wtbd[!grepl(c(wtbd_names_rm), wtbd$gnis_name),] #remove certain names from waterbody labeling, wtbd_names_rm from mapstyles_config
+      wtbd <- wtbd[!is.na(wtbd$lakevolume),]
+      #wtbd <- wtbd[!grepl("Millpond", wtbd$gnis_name),] 
+      # wtbd <- wtbd[!grepl("Swamp", wtbd$gnis_name),]
+
+
+      #classification of waterbodies with classes based on their size
+      wtbd_small <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_sm_pct_range[1], na.rm = T) & 
+                           wtbd$lakevolume < quantile(wtbd$lakevolume, wtbd_sm_pct_range[2], na.rm = T),]
+      wtbd_small$class <- rep("waterbody_sm", nrow(wtbd_small)) #add class column
+
+      wtbd_med <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_med_pct_range[1], na.rm = T) & 
+                         wtbd$lakevolume < quantile(wtbd$lakevolume, wtbd_med_pct_range[2], na.rm = T),]
+      wtbd_med$class <- rep("waterbody_med", nrow(wtbd_med)) #add class column
+
+      wtbd_large <- wtbd[wtbd$lakevolume > quantile(wtbd$lakevolume, wtbd_med_pct_range[2], na.rm = T),]
+      wtbd_large$class <- rep("waterbody_lg", nrow(wtbd_large)) #add class column
+
+      ##something wrong -- too many bodies classified as large 
+
+      wtbd <- rbind(wtbd_small,wtbd_med,wtbd_large)
+      wtbd <- wtbd[,c("gnis_name","class")]
+      wtbd <- wtbd[!is.na(wtbd$gnis_name),]
+
+      nhdlabs <- rbind(flow, wtbd)
+    } else {
+      nhdlabs <- flow
+    }
+
+    names(nhdlabs)[names(nhdlabs) == 'gnis_name'] <- 'label'
+    # now it is ready to have coords calculated like the rest of the labeling data
+#    assign('data', data, envir = globalenv())#save df to environment
+    }
+  return(nhdlabs)
 }  

HARP-2023-Summer/Mapping/Functions/fns_mapgen.R

@@ -511,6 +511,7 @@ fn_gw_mapgen <- function(bbox, crs_default, mp_layer, featr_type,
   fn_labelsAndFilter(maplabs, bbox_coords, nhd, roads, map_style_set, bbox_sf, crs_default, rsegs)
   #begin mapping:
   map <- ggplot() + coord_sf(xlim=bbox_coords$lng,ylim=bbox_coords$lat)
+  map$errors = c()
   map <- fn_catchMapErrors(map_layer = ggplot2::theme(text=ggplot2::element_text(size=20), 
                                                       title=ggplot2::element_text(size=40), #setting text sizes
                                                       legend.title = ggplot2::element_text(size=25),