",
"HUC Name: ",values$hydro_data$name,
"
", "HUC #: ", values$hydro_data$huc12,
"
", "HUC Area: ",scales::comma(round(values$hydro_data$areaacres,0)), " acres" ) )
} %>%
finally(~p$close())
} else if (input$location_map == "huc8") {
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_huc8(data_sf)
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No HUC 8 Features Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
leaflet::addPolygons(data = values$hydro_data%>%
sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
",
"HUC Name: ",values$hydro_data$name,
"
", "HUC #: ", values$hydro_data$huc8,
"
", "HUC Area: ",scales::comma(round(values$hydro_data$areaacres,0)), " acres" ) )
} %>%
finally(~p$close())
} else if (input$location_map == "catchment") {
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_nhdplus(data_sf, realization = 'catchment')
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No Catchments Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
addPolygons(data = values$hydro_data %>%
sf::st_make_valid() %>%
sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326") , popup = paste0("
",
"Feature ID: ",values$hydro_data$featureid,
"
", "Area: ",scales::comma(round(values$hydro_data$areasqkm,0)*247.105), " acres" ) )
} %>%
finally(~p$close())
} else if (input$location_map == "nhdplus") {
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_nhdplus(data_sf)
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No Flowlines Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
addPolylines(data = values$hydro_data%>%
sf::st_make_valid() %>%
st_as_sf() %>%
sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326") , popup = paste0("
",
"Name: ",values$hydro_data$gnis_name,
"
", "Stream Order (strahler): ", values$hydro_data$streamorde,
"
", "Arbolate Sum: ", paste0(values$hydro_data$arbolatesu, " mi"),
"
", "Drainage Area: ", paste0(comma(round(values$hydro_data$totdasqkm*247.105, 0)), ' acres'),
"
", "Mean Annual Flow (MAF): ", paste0(values$hydro_data$qa_ma, ' cfs'),
"
", "MAF with Ref. Gage (MAFqc): ", paste0(values$hydro_data$qc_ma, ' cfs'),
"
", "Mean Flow (April, May, June): ", paste0(values$hydro_data$qa_04, ' , ', values$hydro_data$qa_05, ' , ', values$hydro_data$qa_06 ),
"
", "Slope: ", paste0(round(values$hydro_data$slope*100,2), " %"),
"
", "Length: ", paste0(round(values$hydro_data$lengthkm*0.621371,2), " mi"),
"
", "Path Length (terminal): ", paste0(comma(round(values$hydro_data$pathlength,0)), " mi" ),
"
", "Mean Annual Time of Travel: ", paste0(round(values$hydro_data$totma,3), " days" ),
"
", "COMID #: ", values$hydro_data$comid,
"
", "F-type: ",values$hydro_data$ftype,
"
", "F-code: ",values$hydro_data$fcode))
} %>%
finally(~p$close())
} else if (input$location_map == "outlet") {
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_nhdplus(data_sf, realization = 'outlet')
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No Outlets Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
addCircles(data = values$hydro_data, weight = 15, popup = paste0("
",
"Name: ",values$hydro_data$gnis_name,
"
", "Path Length (terminal): ", paste0(comma(round(values$hydro_data$pathlength,0)), " mi" ),
"
", "Mean Annual Time of Travel: ", paste0(round(values$hydro_data$totma,4), " days" ),
"
", "COMID #: ", values$hydro_data$comid,
"
", "F-type: ",values$hydro_data$ftype))
} %>%
finally(~p$close())
} else if (input$location_map == "nwis") {
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_nwis(data_sf)
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No NWIS Sites Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
addCircles(data = values$hydro_data %>%
st_as_sf() %>%
st_transform(crs = 4326,proj4string = "+init=epsg:4326"),radius = 15, weight = 15,
color = "red", popup = paste0("
",
"Name: ",values$hydro_data$station_nm,
"
", "Site #: ", values$hydro_data$site_no))
} %>%
finally(~p$close())
} else if (input$location_map == 'waterbody'){
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
nhdplusTools::get_waterbodies(data_sf)
}) %...>% {
values$hydro_data <- .
values$out <- list(values$hydro_data)
names(values$out) <- paste0(input$location_map, '_',sample(1:10000,size = 1, replace = T))
values$hydro_data_list <- append(values$hydro_data_list, values$out)
if(class(values$hydro_data)[[1]] != 'sf'){
shinyWidgets::show_alert('No Waterbodies Found',
'please try a new area',
type = 'warning')}
req(class(values$hydro_data)[[1]] == 'sf')
leaflet::leafletProxy("leaf_map", session) %>%
addPolygons(data = values$hydro_data %>%
sf::st_make_valid() %>%
sf::st_as_sf() %>%
sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
",
"Name: ",values$hydro_data$gnis_name,
"
", "Area: ",paste(comma(round(values$hydro_data$areasqkm*247.105,0)), " acres" ),
"
", "F-type: ",values$hydro_data$ftype,
"
", "F-code: ",values$hydro_data$fcode,
"
", "Mean Depth: ",paste(round(values$hydro_data$meandepth*3.28084, 2), " ft"),
"
", "Lake Volume: ",paste(comma(round(values$hydro_data$lakevolume*35.3147,2)), " cf"),
"
", "Max Depth: ", paste(round(values$hydro_data$maxdepth*3.28084, 2), " ft")))
} %>%
finally(~p$close())
}
})
# # keep track of newly drawn shapes
# values$drawnshapes <- list()
#
#
# js_ping <- shiny::reactiveTimer(5000)
#
# # observe our simple little button to remove
# observeEvent(
# js_ping(),
# {
# lapply(
# values$drawnshapes,
# function(todelete) {
# session$sendCustomMessage(
# "removeleaflet",
# list(elid=paste0(session$ns('leaf_map')), layerid=todelete)
# )
# }
# )
# }
# )
# we are fortunate here since we get an event
# draw_all_features
observeEvent(
input$leaf_map_draw_all_features,
{
values$drawnshapes <- lapply(
input$leaf_map_draw_all_features$features,
function(ftr) {
ftr$properties$`_leaflet_id`
}
)
}
)
}
#' Shiny Module UI for basins
#'
#' @description A shiny Module to.
#'
#' @param id \code{character} id for the the Shiny namespace
#' @param ... other arguments to \code{leafletOutput()}
#'
#' @importFrom shiny NS tagList reactiveValues observe
#' @importFrom dplyr filter select mutate slice_max ungroup rename
#' @importFrom grDevices hcl.colors
#' @importFrom sf st_area st_transform st_geometry st_as_sf
#' @importFrom scales comma
#' @importFrom leaflet addPolygons addPolylines addCircles
#' @return UI function for Shiny module
#' @export
#'
basinModUI <- function(id, ...){
ns <- shiny::NS(id)
leaflet::leafletOutput(ns('leaf_map'), ...)
}
#' Shiny Module Server for nhdplus
#' @param input Shiny server function input
#' @param output Shiny server function output
#' @param session Shiny server function session
#' @param values A reactive Values list to pass
#' @return server function for Shiny module
#' @importFrom promises finally "%...>%"
#' @export
basinMod <- function(input, output, session, values){
ns <- session$ns
values$basin_data_list <- list()
css <- "
label {background-color: rgba(255, 255, 255, 0.75);
display: inline-block;
max-width: 100%;
margin-bottom: 5px;
font-weight: 700;
color: black;
font-size: small;
font-family: inherit;
padding: 2.5px;}"
#starting leaflet map
output$leaf_map <- leaflet::renderLeaflet({
base_map() %>%
leaflet::addControl(html = tags$div(tags$style(css),shiny::numericInput(
ns('map_res'), 'Select Elevation Zoom',value = 8,min = 1, max = 14,
width = '100%')),
className = "fieldset { border: 0;}") %>%
leaflet::addControl(html = tags$div(tags$style(css),shiny::numericInput(
ns('snap_dist'), 'Snap Distance (m)',value = 10,min = 1, max = 15000,
width = '100%')),
className = "fieldset { border: 0;}") %>%
leaflet.extras::addDrawToolbar(polylineOptions = F, circleOptions = F,circleMarkerOptions = F,
rectangleOptions = F,
markerOptions = T,
polygonOptions = F, targetGroup = 'draw') %>%
leaflet::setView(lat = 37.0902, lng = -95.7129, zoom = 5) %>%
leaflet::hideGroup(group = 'Hydrography') %>%
leaflet::addLayersControl(baseGroups = c("OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron",
"OpenStreetMap", "CartoDB.DarkMatter"),
overlayGroups = c("Hydrography"))
})
observeEvent(input$leaf_map_draw_new_feature, {
click <- input$leaf_map_draw_new_feature
clat <- click$geometry$coordinates[[2]]
clng <- click$geometry$coordinates[[1]]
data_sf <- tidyr::tibble(Lat = clat, Lon = clng)
data_sf <- data_sf %>% sf::st_as_sf(coords = c('Lon', 'Lat')) %>%
sf::st_set_crs(4326) %>%
sf::st_transform(crs = 4326)
p <- shiny::Progress$new()
p$set(message = "Downloading data...",
detail = "This may take a little bit...",
value = 1/2)
promises::future_promise({
sf::sf_use_s2(FALSE)
ws_poly <- get_whitebox_basin(data_sf, input$map_res, input$snap_dist)
}) %...>% {
values$basin <- .
values$out <- list(values$basin)
names(values$out) <- paste0('Basin_',sample(1:10000,size = 1, replace = T))
values$basin_data_list <- append(values$basin_data_list, values$out)
leaflet::leafletProxy('leaf_map', session) %>%
leaflet::addPolygons(data = values$basin)
} %>%
finally(~p$close())
})
}