", @@ -192,6 +198,12 @@ nhdplusMod <- function(input, output, session, values){ req(class(values$hydro_data)[[1]] == 'sf') + if(sf::st_geometry_type(values$hydro_data) == 'GEOMETRYCOLLECTION') { + + values$hydro_data <- convert_sf_geocollection(values$hydro_data) + + } + leaflet::leafletProxy("leaf_map", session) %>% leaflet::addPolygons(data = values$hydro_data%>% sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
", @@ -229,6 +241,13 @@ nhdplusMod <- function(input, output, session, values){ req(class(values$hydro_data)[[1]] == 'sf') + if(sf::st_geometry_type(values$hydro_data) == 'GEOMETRYCOLLECTION') { + + values$hydro_data <- convert_sf_geocollection(values$hydro_data) + + + } + leaflet::leafletProxy("leaf_map", session) %>% leaflet::addPolygons(data = values$hydro_data%>% sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
", @@ -266,6 +285,12 @@ nhdplusMod <- function(input, output, session, values){ req(class(values$hydro_data)[[1]] == 'sf') + if(sf::st_geometry_type(values$hydro_data) == 'GEOMETRYCOLLECTION') { + + values$hydro_data <- convert_sf_geocollection(values$hydro_data) + + } + leaflet::leafletProxy("leaf_map", session) %>% leaflet::addPolygons(data = values$hydro_data%>% sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
", @@ -303,6 +328,12 @@ nhdplusMod <- function(input, output, session, values){ req(class(values$hydro_data)[[1]] == 'sf') + if(sf::st_geometry_type(values$hydro_data) == 'GEOMETRYCOLLECTION') { + + values$hydro_data <- convert_sf_geocollection(values$hydro_data) + + } + leaflet::leafletProxy("leaf_map", session) %>% leaflet::addPolygons(data = values$hydro_data%>% sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
", @@ -340,6 +371,12 @@ nhdplusMod <- function(input, output, session, values){ req(class(values$hydro_data)[[1]] == 'sf') + if(sf::st_geometry_type(values$hydro_data) == 'GEOMETRYCOLLECTION') { + + values$hydro_data <- convert_sf_geocollection(values$hydro_data) + + } + leaflet::leafletProxy("leaf_map", session) %>% leaflet::addPolygons(data = values$hydro_data%>% sf::st_transform(crs = 4326,proj4string = "+init=epsg:4326"), popup = paste0("
", @@ -616,12 +653,13 @@ 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 threshold A threshold for stream initiation. 1000 (default). #' @param map a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided. +#' @param ... arguments to pass to wbt_* functions. #' @return server function for Shiny module #' @importFrom promises finally "%...>%" #' @export -basinMod <- function(input, output, session, values, dem, map){ +basinMod <- function(input, output, session, values, dem, threshold = 1000, map, ...){ ns <- session$ns @@ -668,6 +706,7 @@ leaf_map <- e.layer.bringToBack(); }) } +}) ") } else { @@ -711,22 +750,28 @@ observe({ promises::future_promise({ ws_dem <- get_whitebox_streams(ele = dem, - threshold = 1000) + threshold = threshold, + ...) }) %...>% { - values$streams <- .[['output_streams_rast']] values$output_streams <- .[[2]] values$output_pointer <- .[[3]] + values$streams <- .[[5]] values$output_fa <- .[[6]] bb <- sf::st_bbox(dem) - leaflet::leafletProxy('leaf_map', session) %>% - leaflet::addRasterImage(x = values$streams, - colors = 'blue', - group = paste0('raster', vals$count))%>% - leaflet::fitBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']]) + bb <- sf::st_bbox(sf::st_transform(sf::st_as_sfc(bb), 4326)) + + vals$count <- sample(1:10000, size = 1) + + leaflet::leafletProxy('leaf_map', session) %>% + leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('stream', vals$count))%>% + leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", + "OpenStreetMap", "CartoDB.DarkMatter"), + overlayGroups = c("Hydrography", + paste0('stream', vals$count))) @@ -740,9 +785,10 @@ observe({ observeEvent(input$leaf_map_draw_new_feature, { + checking <<- input$leaf_map if(input$leaf_map_draw_new_feature$geometry$type != 'Point') { - # make sure counter is at zero + # make sure ding the counter vals$count <- sample(0:10000, size = 1) @@ -766,11 +812,21 @@ observe({ sf::st_transform(crs = 4326) } + if(input$leaf_map_draw_new_feature$geometry$type != 'Point'){ + p <- shiny::Progress$new() - p$set(message = "Downloading data...", + p$set(message = "Running DEM through algorithms...", detail = "This may take a little bit...", value = 1/2) + } else { + + p <- shiny::Progress$new() + p$set(message = "Generating basin...", + detail = "Just a sec...", + value = 1/2) + } + promises::future_promise({ if(is.null(dem)){ @@ -781,7 +837,8 @@ observe({ ws_dem <- get_whitebox_streams(data_sf, input$map_res, - threshold = input$threshold) + threshold = input$threshold, + ...) } else { req(values$output_streams) @@ -800,7 +857,8 @@ observe({ ws_dem <- get_whitebox_streams(data_sf, input$map_res, - threshold = input$threshold) + threshold = input$threshold, + ...) } else { req(values$output_streams) @@ -817,34 +875,72 @@ observe({ if(input$leaf_map_draw_new_feature$geometry$type != 'Point') { - values$streams <- .[['output_streams_rast']] values$output_streams <- .[[2]] values$output_pointer <- .[[3]] + values$streams <- .[[5]] values$output_fa <- .[[6]] leaflet::leafletProxy('leaf_map', session) %>% - leaflet::addRasterImage(x = values$streams, colors = 'blue', group = paste0('raster', vals$count)) + leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('stream', vals$count))%>% + leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", + "OpenStreetMap", "CartoDB.DarkMatter"), + overlayGroups = c("Hydrography", + paste0('stream', vals$count))) } else { values$basin <- . - samp <- sample(1:10000,size = 1, replace = T) - values$basin <- values$basin %>% mutate(id = samp) - values$out <- list(values$basin) - names(values$out) <- paste0('Basin_',samp) + samp <- input$leaf_map_draw_new_feature$properties$`_leaflet_id` + values$basin <- values$basin %>% dplyr::mutate(id = samp) + values$out <- list(values$basin) values$basin_data_list <- append(values$basin_data_list, values$out) + values$basin_data <- dplyr::bind_rows(values$basin_data_list) + values$bd_og <- values$basin_data + values$basin_data <- values$basin_data %>% dplyr::filter(id %in% as.numeric(unlist(drawnshapes))) - leaflet::leafletProxy('leaf_map', session) %>% - leaflet::addPolygons(data = values$basin) + values$deleted_data <- values$bd_og %>% dplyr::filter(!id %in% as.numeric(unlist(drawnshapes))) + + if(!is.null(values$deleted_data)){ + leaf_prox <- leaflet::leafletProxy('leaf_map', session) %>% + leaflet::clearGroup(group = do.call(paste0, list('basin', values$deleted_data$id))) + } else { + leaf_prox <- leaflet::leafletProxy('leaf_map', session) + } + + leaf_prox %>% + leaflet::addPolygons(data = values$basin, group = paste0('basin',values$basin$id)) %>% + leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", + "OpenStreetMap", "CartoDB.DarkMatter"), + overlayGroups = c("Hydrography", + paste0('stream', vals$count), + do.call(paste0, list('basin', values$basin_data$id)))) } } %>% finally(~p$close()) + }) +# +# + # observeEvent(input$leaf_map_draw_new_feature,{ + # req(!is.null(values$basin_data)) + # values$basin_data <- values$basin_data %>% dplyr::filter(id %in% as.numeric(unlist(drawnshapes))) + # print(values$basin_data) + # + # leaflet::leafletProxy('leaf_map', session) %>% + # leaflet::addPolygons(data = values$basin_data)%>% + # leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", + # "OpenStreetMap", "CartoDB.DarkMatter"), + # overlayGroups = c("Hydrography", + # paste0('stream', vals$count))) + # + # + # }) + # now for the dynamic threshold @@ -861,22 +957,34 @@ observe({ whitebox::wbt_extract_streams(values$output_fa, output_streams, - threshold = input$threshold) - streams_rast <- list(streams = terra::rast(output_streams), - output_streams = output_streams) + threshold = input$threshold, + ...) + + # generate a stream vector + output_stream_vector <- tempfile(fileext = '.shp') + + whitebox::wbt_raster_streams_to_vector(output_streams, values$output_pointer, output_stream_vector, verbose_mode = F) + stream_vector <- sf::st_as_sf(sf::read_sf(output_stream_vector)) %>% + sf::st_set_crs(3857) %>% sf::st_transform(4326) + + streams <- list(streams = stream_vector) }) %...>% { values$streams <- .[[1]] - values$output_streams <- .[[2]] - leaf_prox <- leaflet::leafletProxy('leaf_map', session) %>% - leaflet::clearGroup(group = paste0('raster', vals$count)) + leaf_prox <- leaflet::leafletProxy('leaf_map', session)%>% + leaflet::clearGroup(group = paste0('stream', vals$count)) vals$count <- sample(0:10000, size = 1) leaf_prox %>% - leaflet::addRasterImage(x = values$streams, colors = 'blue', group = paste0('raster', vals$count)) + leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('stream', vals$count))%>% + leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", + "OpenStreetMap", "CartoDB.DarkMatter"), + overlayGroups = c("Hydrography", + paste0('stream', vals$count), + do.call(paste0, list('basin', values$basin_data$id)))) @@ -888,19 +996,20 @@ observe({ # keep track of newly drawn shapes - drawnshapes <- list() + drawnshapes <- list() # we are fortunate here since we get an event # draw_all_features observeEvent( input$leaf_map_draw_all_features, { - drawnshapes <<- lapply( + drawnshapes <<- lapply( input$leaf_map_draw_all_features$features, function(ftr) { ftr$properties$`_leaflet_id` } ) + } ) @@ -910,7 +1019,7 @@ observe({ input$deletebtn, { lapply( - drawnshapes, + drawnshapes, function(todelete) { session$sendCustomMessage( "removeleaflet", @@ -955,12 +1064,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. +#' @param ... arguments to pass to wbt_* functions. #' @return server function for Shiny module #' @importFrom promises finally "%...>%" #' @export -streamnetworkMod <- function(input, output, session, values, dem, threshold = 1000, map){ +streamnetworkMod <- function(input, output, session, values, dem, threshold = 1000, map, ...){ ns <- session$ns @@ -1053,7 +1162,8 @@ observe({ ws_poly <- get_whitebox_streams(ele = dem, threshold = threshold, - prj = sf::st_crs(dem)) + prj = sf::st_crs(dem), + ...) }) %...>% { @@ -1064,6 +1174,8 @@ observe({ bb <- sf::st_bbox(dem) + bb <- sf::st_bbox(sf::st_transform(sf::st_as_sfc(bb), 4326)) + values$out <- list(watersheds = values$output_ws, streams = values$streams, flow_accum = values$output_fa, @@ -1132,12 +1244,14 @@ observe({ ws_poly <- get_whitebox_streams(values$data_sf, input$map_res, - threshold = input$threshold) + threshold = input$threshold, + ...) } else { ws_poly <- get_whitebox_streams(ele = dem, threshold = input$threshold, - prj = sf::st_crs(dem)) + prj = sf::st_crs(dem), + ...) } }) %...>% { diff --git a/R/streamnetwork.R b/R/streamnetwork.R index 9f9bdea..03df21d 100644 --- a/R/streamnetwork.R +++ b/R/streamnetwork.R @@ -14,9 +14,9 @@ #' behaviour in Firefox. #' @param title \code{string} to customize the title of the UI window. The default #' is "Delineate Basin". -#' @param ... other arguments to \code{leafletOutput()} in module. #' @param dem A raster or terra object dem. (optional) #' @param threshold A threshold for stream initiation. 1000 (default). +#' @param ... other arguments to \code{leafletOutput()} in module and/or wbt_* functions. #' @note If you add your own DEM then you don't need to draw a bounding box. #' @details This function uses the package \link{elevatr} to download the DEM (unless you provide your own). #' Once the user has drawn the bounding box or inputed DEM and selected appropriate zoom (resolution) and threshold then @@ -24,17 +24,20 @@ #' #' **Steps** #' -#' 1. Input a well-suited DEM zoom level (or your own DEM) and stream threshold (resolution). +#' 1. Input a well-suited DEM zoom level and threshold. (skip if own DEM is inputted) #' 2. Draw bounding box (rectangle or polygon) (skip if own DEM is inputted). #' 3. Wait for layers to respond. -#' 4. when finished, press 'done' and stream network and watersheds will be saved as a list in local environment. +#' 4. Repeat steps 1-4 if needed. +#' 5. when finished, press 'done' and stream network and watersheds will be saved as a list in local environment with the associated +#' flow accumulation and flow direction. +#' #' #' In addition, this function uses both `whitebox::wbt_feature_preserving_smoothing()` and `whitebox::wbt_breach_depressions()` #' prior to running the flow direction and flow accumulation (both d8) algorithms. #' #' #' -#' @return A list of sf objects that the user collected during shiny session. +#' @return A list of sf objects that the user collected during shiny session as well as flow accumulation and direction paths to tif. #' Each list will contain two sf objects: `watersheds` and `streams`. The `streams` object will also return these attributes: #' `tribid`, `strahler`, `slope`, `length`, `mainstem`, `FID`, `STRM_VAL`. #' @export @@ -108,7 +111,8 @@ $(document).on('shiny:disconnected', function() { ns, values = values, dem = dem, - threshold = threshold + threshold = threshold, + ... )) observe({crud_mod()}) diff --git a/R/utils.R b/R/utils.R index 6d4b311..d185994 100644 --- a/R/utils.R +++ b/R/utils.R @@ -228,6 +228,36 @@ nldi_basin_function <- function(point){ } +#' @title Convert GEOMETRYCOLLECTION to POLYGONS +#' @param x A sf object +#' +#' @return A converted sf object from GEOMETRYCOLLECTION to POLYGON or MULTIPOLYGON. +#' +convert_sf_geocollection <- function(x) { + + data <- x %>% sf::st_drop_geometry() + + sf::st_union(sf::st_as_sf(sf::st_collection_extract(x %>% sf::st_union(), c('POLYGON')))) %>% + sf::st_as_sf() %>% + dplyr::bind_cols(data) %>% + rename_geometry('geometry') + +} + +#' Rename Geometry Column +#' +#' @param g A sf object +#' @param name character. +#' +#' @return A sf object with a renamed geometry column. +#' @notes This function was grabbed from [stack overflow](https://gis.stackexchange.com/questions/386584/sf-geometry-column-naming-differences-r) from the legend spacedman. +rename_geometry <- function(g, name){ + current = attr(g, "sf_column") + names(g)[names(g)==current] = name + sf::st_geometry(g)=name + g +} + #' #' @title whitebox helpers for streams #' @param aoi a sf polygon @@ -235,13 +265,15 @@ nldi_basin_function <- function(point){ #' @param threshold numeric; cell threshold for stream delineation #' @param prj A character vector with proj4string. #' @param ele A dem added by the user. +#' @param ... Pass arguments to wbt_* functions. #' @noRd #' @return a list of file paths to .tif files and a terra::rast object get_whitebox_streams <- function(aoi, z, threshold, prj, - ele){ + ele, + ...){ @@ -268,11 +300,13 @@ get_whitebox_streams <- function(aoi, whitebox::wbt_feature_preserving_smoothing( dem = output, output = output, - verbose_mode = F + verbose_mode = F, + ... ) whitebox::wbt_breach_depressions(dem = output, - output = output, verbose_mode = F) + output = output, verbose_mode = F, + ...) # get pointer (flow direction) and accumulation output_pointer <- tempfile(fileext = '.tif') @@ -287,6 +321,9 @@ get_whitebox_streams <- function(aoi, whitebox::wbt_extract_streams(output_fa, output_streams, threshold = threshold, verbose_mode = F) + # thin out the stream layer + whitebox::wbt_line_thinning(output_streams, output_streams) + # get stream link identifier pour_pts <- tempfile(fileext = '.tif') whitebox::wbt_stream_link_identifier(output_pointer,output_streams, pour_pts, verbose_mode = F) diff --git a/man/basinMod.Rd b/man/basinMod.Rd index d5b3b52..d95e6e1 100644 --- a/man/basinMod.Rd +++ b/man/basinMod.Rd @@ -4,7 +4,7 @@ \alias{basinMod} \title{Shiny Module Server for basin generation} \usage{ -basinMod(input, output, session, values, dem, map) +basinMod(input, output, session, values, dem, threshold = 1000, map, ...) } \arguments{ \item{input}{Shiny server function input} @@ -17,7 +17,11 @@ basinMod(input, output, session, values, dem, map) \item{dem}{A raster or terra object dem.} +\item{threshold}{A threshold for stream initiation. 1000 (default).} + \item{map}{a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.} + +\item{...}{arguments to pass to wbt_* functions.} } \value{ server function for Shiny module diff --git a/man/convert_sf_geocollection.Rd b/man/convert_sf_geocollection.Rd new file mode 100644 index 0000000..003274f --- /dev/null +++ b/man/convert_sf_geocollection.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{convert_sf_geocollection} +\alias{convert_sf_geocollection} +\title{Convert GEOMETRYCOLLECTION to POLYGONS} +\usage{ +convert_sf_geocollection(x) +} +\arguments{ +\item{x}{A sf object} +} +\value{ +A converted sf object from GEOMETRYCOLLECTION to POLYGON or MULTIPOLYGON. +} +\description{ +Convert GEOMETRYCOLLECTION to POLYGONS +} diff --git a/man/get_basin_interactively.Rd b/man/get_basin_interactively.Rd index d34f055..846b2f4 100644 --- a/man/get_basin_interactively.Rd +++ b/man/get_basin_interactively.Rd @@ -10,6 +10,7 @@ get_basin_interactively( viewer = shiny::paneViewer(), title = "Delineate Basin", dem = NULL, + threshold = 1000, ... ) } @@ -29,9 +30,11 @@ behaviour in Firefox.} \item{title}{\code{string} to customize the title of the UI window. The default is "Delineate Basin".} -\item{dem}{A terra or raster DEM object if you want to add.} +\item{dem}{A raster or terra object dem. (optional)} -\item{...}{other arguments to \code{leafletOutput()} in module.} +\item{threshold}{A threshold for stream initiation. 1000 (default).} + +\item{...}{other arguments to \code{leafletOutput()} in module and/or wbt_* functions.} } \value{ A sf object that contains watershed polygons @@ -44,11 +47,11 @@ and {whitebox} package to delineate the basin (see details). } \details{ \strong{This function will throw an error if you don't draw the bounding box (rectangle) first and you didn't include your own DEM.} -Once the user has drawn the bounding box then you can use the marker as a pour point location. +Once the user has drawn the bounding box (or added own DEM) then you can use the marker as a pour point location. \strong{Steps} \enumerate{ -\item Input a well-suited DEM zoom level (or your own DEM) and stream threshold (resolution). +\item Input a well-suited DEM zoom level and threshold. (skip if own DEM is inputted) \item Draw bounding box (rectangle or polygon) (skip if own DEM is inputted). \item Use marker to place pour point(s). \item If necessary, change 'Cell Threshold' to change drainage density. diff --git a/man/get_stream_network_interactively.Rd b/man/get_stream_network_interactively.Rd index f1771be..123477d 100644 --- a/man/get_stream_network_interactively.Rd +++ b/man/get_stream_network_interactively.Rd @@ -34,10 +34,10 @@ is "Delineate Basin".} \item{threshold}{A threshold for stream initiation. 1000 (default).} -\item{...}{other arguments to \code{leafletOutput()} in module.} +\item{...}{other arguments to \code{leafletOutput()} in module and/or wbt_* functions.} } \value{ -A list of sf objects that the user collected during shiny session. +A list of sf objects that the user collected during shiny session as well as flow accumulation and direction paths to tif. Each list will contain two sf objects: \code{watersheds} and \code{streams}. The \code{streams} object will also return these attributes: \code{tribid}, \code{strahler}, \code{slope}, \code{length}, \code{mainstem}, \code{FID}, \code{STRM_VAL}. } @@ -53,10 +53,12 @@ the app will create basins and streams. \strong{Steps} \enumerate{ -\item Input a well-suited DEM zoom level (or your own DEM) and stream threshold (resolution). +\item Input a well-suited DEM zoom level and threshold. (skip if own DEM is inputted) \item Draw bounding box (rectangle or polygon) (skip if own DEM is inputted). \item Wait for layers to respond. -\item when finished, press 'done' and stream network and watersheds will be saved as a list in local environment. +\item Repeat steps 1-4 if needed. +\item when finished, press 'done' and stream network and watersheds will be saved as a list in local environment with the associated +flow accumulation and flow direction. } In addition, this function uses both \code{whitebox::wbt_feature_preserving_smoothing()} and \code{whitebox::wbt_breach_depressions()} diff --git a/man/rename_geometry.Rd b/man/rename_geometry.Rd new file mode 100644 index 0000000..4f328cd --- /dev/null +++ b/man/rename_geometry.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{rename_geometry} +\alias{rename_geometry} +\title{Rename Geometry Column} +\usage{ +rename_geometry(g, name) +} +\arguments{ +\item{g}{A sf object} + +\item{name}{character.} +} +\value{ +A sf object with a renamed geometry column. +} +\description{ +Rename Geometry Column +} diff --git a/man/streamnetworkMod.Rd b/man/streamnetworkMod.Rd index 60afe3e..c0de62e 100644 --- a/man/streamnetworkMod.Rd +++ b/man/streamnetworkMod.Rd @@ -4,7 +4,16 @@ \alias{streamnetworkMod} \title{Shiny Module Server for stream networks} \usage{ -streamnetworkMod(input, output, session, values, dem, threshold = 1000, map) +streamnetworkMod( + input, + output, + session, + values, + dem, + threshold = 1000, + map, + ... +) } \arguments{ \item{input}{Shiny server function input} @@ -20,6 +29,8 @@ streamnetworkMod(input, output, session, values, dem, threshold = 1000, map) \item{threshold}{A threshold for stream initiation. 1000 (default).} \item{map}{a background leaflet or mapview map to be used for editing. If NULL a blank mapview canvas will be provided.} + +\item{...}{arguments to pass to wbt_* functions.} } \value{ server function for Shiny module