Skip to content

Commit

Permalink
working on streamnetwork really need to be on a branch....
Browse files Browse the repository at this point in the history
  • Loading branch information
@joshualerickson
joshualerickson committed Sep 11, 2023
1 parent 4ac93eb commit 02a1d6f
Show file tree
Hide file tree
Showing 8 changed files with 171 additions and 72 deletions.
13 changes: 8 additions & 5 deletions R/basin.R
View file
Expand Up @@ -3,6 +3,7 @@
#' @description This function allows the user to delineate watershed basins interactively with a
#' shiny app. It uses the {elevatr} package to acquire the Digital Elevation Model (DEM) or user inputted DEM
#' and {whitebox} package to delineate the basin (see details).
#' @param map a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.
#' @param ns \code{string} name for the Shiny \code{namespace} to use. The \code{ns}
#' is unlikely to require a change.
#' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}.
Expand Down Expand Up @@ -45,11 +46,12 @@
#' }
#'
#'
get_basin_interactively <- function(ns = 'basin-ui',
viewer = shiny::paneViewer(),
title = 'Delineate Basin',
dem = NULL,
...) {
get_basin_interactively <- function(map = NULL,
ns = 'basin-ui',
viewer = shiny::paneViewer(),
title = 'Delineate Basin',
dem = NULL,
...) {

## Some code hijacked from mapedit throughout; to get miniUI look, etc

Expand Down Expand Up @@ -96,6 +98,7 @@ $(document).on('shiny:disconnected', function() {
values <- reactiveValues()

crud_mod <- reactive(shiny::callModule(
map = map,
basinMod,
ns,
values = values,
Expand Down
197 changes: 135 additions & 62 deletions R/modules.R
View file
Expand Up @@ -616,10 +616,12 @@ basinModUI <- function(id, ...){
#' @param session Shiny server function session
#' @param values A reactive Values list to pass
#' @param dem A raster or terra object dem.
#' @param map
#' @param map a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.
#' @return server function for Shiny module
#' @importFrom promises finally "%...>%"
#' @export
basinMod <- function(input, output, session, values, dem){
basinMod <- function(input, output, session, values, dem, map){

ns <- session$ns

Expand All @@ -637,6 +639,38 @@ basinMod <- function(input, output, session, values, dem){
padding: 2.5px;}"

leaf_map <-

if(!is.null(map)){

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('threshold'), 'Cell Threshold',value = 1000,min = 1, max = 15000,
width = '100%')),
className = "fieldset { border: 0;}") %>%
leaflet.extras::addDrawToolbar(polylineOptions = F,
circleOptions = F,
circleMarkerOptions = F,
rectangleOptions = T,
markerOptions = T,
polygonOptions = T,
targetGroup = 'draw',
editOptions = leaflet.extras::editToolbarOptions(F, T)) %>%
leaflet::addControl(html = shiny::actionButton(ns("deletebtn"), "remove drawn"),
position = 'bottomright',
className = 'fieldset {border:0;}')%>%
htmlwidgets::onRender("
function(el, x) {
this.on('baselayerchange', function(e) {
e.layer.bringToBack();
})
}
")
} else {

base_map() %>%
leaflet::addControl(html = tags$div(tags$style(css),shiny::numericInput(
ns('map_res'), 'Select Elevation Zoom',value = 8,min = 1, max = 14,
Expand All @@ -662,7 +696,7 @@ leaf_map <-
leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron",
"OpenStreetMap", "CartoDB.DarkMatter"),
overlayGroups = c("Hydrography"))

}
output$leaf_map <- leaflet::renderLeaflet({
leaf_map
})
Expand Down Expand Up @@ -921,10 +955,12 @@ streamnetworkModUI <- function(id, ...){
#' @param values A reactive Values list to pass
#' @param dem A raster or terra object dem. (optional)
#' @param threshold A threshold for stream initiation. 1000 (default).
#' @param map
#' @param map a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.
#' @return server function for Shiny module
#' @importFrom promises finally "%...>%"
#' @export
streamnetworkMod <- function(input, output, session, values, dem, threshold = 1000){
streamnetworkMod <- function(input, output, session, values, dem, threshold = 1000, map){

ns <- session$ns

Expand All @@ -949,7 +985,8 @@ streamnetworkMod <- function(input, output, session, values, dem, threshold = 10
#starting leaflet map
output$leaf_map <- leaflet::renderLeaflet({

base_map() %>%
if(is.null(map)){
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%')),
Expand All @@ -973,6 +1010,36 @@ streamnetworkMod <- function(input, output, session, values, dem, threshold = 10
leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron",
"OpenStreetMap", "CartoDB.DarkMatter"),
overlayGroups = c("Hydrography"))
} else {

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('threshold'), 'Cell Threshold',value = threshold,min = 1, max = 15000,
width = '100%')),
className = "fieldset { border: 0;}") %>%
leaflet::addControl(html = tags$div(tags$style(css),shiny::actionButton(
ns('submit'), 'Run',
width = '100%'))) %>%
leaflet.extras::addDrawToolbar(polylineOptions = F, circleOptions = F,circleMarkerOptions = F,
rectangleOptions = T,
markerOptions = F,
polygonOptions = T, targetGroup = 'draw') %>%
leaflet::addControl(html = shiny::actionButton(ns("deletebtn"), "remove drawn"),
position = 'bottomright',
className = 'fieldset {border:0;}')%>%
htmlwidgets::onRender("
function(el, x) {
this.on('baselayerchange', function(e) {
e.layer.bringToBack();
})
}
")
}

})

observe({
Expand All @@ -992,10 +1059,15 @@ observe({

values$streams <- .[[5]]
values$output_ws <- .[[4]]
values$output_fa <- .[[6]]
values$output_fd <- .[[3]]

bb <- sf::st_bbox(dem)

values$out <- list(watersheds = values$output_ws, streams = values$streams)
values$out <- list(watersheds = values$output_ws,
streams = values$streams,
flow_accum = values$output_fa,
flow_dir = values$output_fd)

values$basin_data_list <- append(values$basin_data_list, list(values$out))

Expand All @@ -1013,9 +1085,8 @@ observe({
"OpenStreetMap", "CartoDB.DarkMatter"),
overlayGroups = c("Hydrography",
paste0('catchment', vals$count),
paste0('stream', vals$count)))
# %>%
# leaflet::fitBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']])
paste0('stream', vals$count))) %>%
leaflet::fitBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']])



Expand Down Expand Up @@ -1073,8 +1144,13 @@ observe({

values$streams <- .[[5]]
values$output_ws <- .[[4]]
values$output_fa <- .[[6]]
values$output_fd <- .[[3]]

values$out <- list(watersheds = values$output_ws, streams = values$streams)
values$out <- list(watersheds = values$output_ws,
streams = values$streams,
flow_accum = values$output_fa,
flow_dir = values$output_fd)

values$basin_data_list <- append(values$basin_data_list, list(values$out))

Expand Down Expand Up @@ -1104,59 +1180,56 @@ observe({

})

# # now for the dynamic threshold
#
# observeEvent(input$threshold, ignoreInit = TRUE, {
#
# req(values$output_fa)
#
# promises::future_promise({
#
#
#
# # extract streams based on threshold
# output_streams <- tempfile(fileext = '.tif')
#
# whitebox::wbt_extract_streams(values$output_fa,
# output_streams,
# threshold = input$threshold)
#
# get_whitebox_streams(values$data_sf,
# input$map_res,
# threshold = input$threshold)
#
# streams_rast <- list(streams = terra::rast(output_streams),
# output_streams = output_streams)
#
# }) %...>% {
#
# values$streams <- .[[5]]
# values$output_ws <- .[[4]]
#
# values$out <- list(watersheds = values$output_ws, streams = values$streams)
#
# values$basin_data_list <- append(values$basin_data_list, list(values$out))
#
#
# if(vals$count > 0){
# leaf_prox <- leaflet::leafletProxy('leaf_map', session) %>%
# leaflet::clearGroup(group = c(paste0('raster', vals$count),paste0('poly', vals$count)))
# } else {
# leaf_prox <- leaflet::leafletProxy('leaf_map', session)
# }
#
# vals$count <- sample(1:10000, size = 1)
#
# leaf_prox %>%
# leaflet::addPolygons(data = values$output_ws, fillOpacity = 0,
# color = 'black', weight = 3, group = paste0('poly', vals$count)) %>%
# leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('raster', vals$count))
#
#
#
# }
#
# })
# now for the dynamic threshold
#
# observeEvent(input$threshold, ignoreInit = TRUE, {
#
# req(values$output_fa)
#
# promises::future_promise({
#
#
#
# # extract streams based on threshold
# output_streams <- tempfile(fileext = '.tif')
#
# whitebox::wbt_extract_streams(values$output_fa,
# output_streams,
# threshold = input$threshold)
#
# ws_poly <- get_whitebox_streams(values$data_sf,
# input$map_res,
# threshold = input$threshold)
#
# }) %...>% {
#
# values$streams <- .[[5]]
# values$output_ws <- .[[4]]
#
# values$out <- list(watersheds = values$output_ws, streams = values$streams)
#
# values$basin_data_list <- append(values$basin_data_list, list(values$out))
#
#
# if(vals$count > 0){
# leaf_prox <- leaflet::leafletProxy('leaf_map', session) %>%
# leaflet::clearGroup(group = c(paste0('raster', vals$count),paste0('poly', vals$count)))
# } else {
# leaf_prox <- leaflet::leafletProxy('leaf_map', session)
# }
#
# vals$count <- sample(1:10000, size = 1)
#
# leaf_prox %>%
# leaflet::addPolygons(data = values$output_ws, fillOpacity = 0,
# color = 'black', weight = 3, group = paste0('catchment', vals$count)) %>%
# leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('stream', vals$count))
#
#
#
# }
#
# })


# keep track of newly drawn shapes
Expand Down
6 changes: 5 additions & 1 deletion R/streamnetwork.R
View file
Expand Up @@ -3,6 +3,7 @@
#' @description This function allows the user to get stream networks and watersheds interactively with a
#' shiny app. It uses the {elevatr} package to acquire the Digital Elevation Model (DEM) or user inputted DEM
#' and {whitebox} package to delineate the stream network and watersheds (see details).
#' @param map a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.
#' @param ns \code{string} name for the Shiny \code{namespace} to use. The \code{ns}
#' is unlikely to require a change.
#' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}.
Expand Down Expand Up @@ -45,7 +46,9 @@
#'
#'
#'
get_stream_network_interactively <- function(ns = 'streamnetwork-ui',
get_stream_network_interactively <- function(
map = NULL,
ns = 'streamnetwork-ui',
viewer = shiny::paneViewer(),
title = 'Streamnetwork',
dem = NULL,
Expand Down Expand Up @@ -100,6 +103,7 @@ $(document).on('shiny:disconnected', function() {
values <- reactiveValues()

crud_mod <- reactive(shiny::callModule(
map = map,
streamnetworkMod,
ns,
values = values,
Expand Down
13 changes: 11 additions & 2 deletions R/utils.R
View file
Expand Up @@ -155,7 +155,14 @@ base_map <- function () {
group = grp[7], options = opt, layers = "0", attribution = att)
opt <- leaflet::layersControlOptions(collapsed = TRUE)
map <- leaflet::addLayersControl(map, baseGroups = grp[1:6],
overlayGroups = grp[7], options = opt)
overlayGroups = grp[7], options = opt) %>%
htmlwidgets::onRender("
function(el, x) {
this.on('baselayerchange', function(e) {
e.layer.bringToBack();
})
}
")
}


Expand Down Expand Up @@ -249,7 +256,9 @@ get_whitebox_streams <- function(aoi,
ele <- elevatr::get_elev_raster(aoi,
z = z,
prj = prj,
clip = 'locations')}
clip = 'locations')

}

# write to temp file
output <- tempfile(fileext = '.tif')
Expand Down
4 changes: 3 additions & 1 deletion man/basinMod.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

3 changes: 3 additions & 0 deletions man/get_basin_interactively.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit 02a1d6f

Please sign in to comment.