diff --git a/DESCRIPTION b/DESCRIPTION index 6375725..23ef88d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,7 @@ BugReports: https://github.com/joshualerickson/gwavr/issues/ License: MIT + file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Imports: dplyr, httr, @@ -41,3 +41,4 @@ Suggests: testthat (>= 3.0.0) Language: en-US Config/testthat/edition: 3 +LazyData: true diff --git a/R/basin.R b/R/basin.R index 6488993..850c96c 100644 --- a/R/basin.R +++ b/R/basin.R @@ -14,7 +14,7 @@ #' behaviour in Firefox. #' @param title \code{string} to customize the title of the UI window. The default #' is "Delineate Basin". -#' @param dem A raster or terra object dem. (optional) +#' @param dem A 'SpatRaster' object dem. (optional) #' @param threshold A threshold for stream initiation. 1000 (default). #' @param ... other arguments to \code{leafletOutput()} in module and/or wbt_* functions. #' @return A sf object that contains watershed polygons @@ -124,6 +124,7 @@ $(document).on('shiny:disconnected', function() { shiny::stopApp( values$basin_data %>% dplyr::select(geometry, id) %>% + sf::st_make_valid() %>% dplyr::mutate(area_acres = as.numeric(units::set_units(sf::st_area(.), 'acres')), area_miles = as.numeric(units::set_units(sf::st_area(.), 'mi^2')), area_hectares = as.numeric(units::set_units(sf::st_area(.), 'ha')), diff --git a/R/data.R b/R/data.R new file mode 100644 index 0000000..9da332b --- /dev/null +++ b/R/data.R @@ -0,0 +1,14 @@ +#' Retired USGS Sites +#' +#' A subset of data that has retired USGS sites and coordinates. +#' +#' @format ## `df_site_new` +#' A data frame with 14,966 rows and 4 columns: +#' \describe{ +#' \item{SiteNumber}{Site Number} +#' \item{SiteName}{Site Name} +#' \item{location.coordinates1}{Longitude coordinates} +#' \item{location.coordinates2}{Latitude coordinates} +#' ... +#' } +"df_site_new" diff --git a/R/globals.R b/R/globals.R index 53fc755..10b1ab5 100644 --- a/R/globals.R +++ b/R/globals.R @@ -3,6 +3,6 @@ utils::globalVariables(c("COMID", "HTML", "ID", "acres", "characteristic_id", "group_by", "mi", "req", "sessionEnded", "setProgress", "tags", "withProgress",".", "rowid", "site_no", "datetime", "flow_chr", "StatisticsStatusColorFill", "StatisticsStatusColorStroke", - "StatisticsStatusDescription", "FID", "df_site_new") + "StatisticsStatusDescription", "FID", "df_site_new", "id", "geometry") ) diff --git a/R/modules.R b/R/modules.R index f65f92c..9e63564 100644 --- a/R/modules.R +++ b/R/modules.R @@ -712,6 +712,11 @@ basinMod <- function(input, output, session, values, dem, threshold = 1000, map, font-family: inherit; padding: 2.5px;}" + + # create a counter + + vals <- shiny::reactiveValues(count = 0, dem_count = 0) + leaf_map <- if(!is.null(map)){ @@ -725,6 +730,9 @@ leaf_map <- ns('threshold'), 'Cell Threshold',value = 1000,min = 1, max = 15000, width = '100%')), className = "fieldset { border: 0;}") %>% + leaflet::addControl(html = tags$div(tags$style(css),shiny::actionButton( + ns('submit'), 'Change Threshold', + width = '100%'))) %>% leaflet.extras::addDrawToolbar(polylineOptions = F, circleOptions = F, circleMarkerOptions = F, @@ -733,9 +741,9 @@ leaf_map <- 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;}')%>% + # 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) { @@ -755,6 +763,9 @@ leaf_map <- ns('threshold'), 'Cell Threshold',value = 1000,min = 1, max = 15000, width = '100%')), className = "fieldset { border: 0;}") %>% + leaflet::addControl(html = tags$div(tags$style(css),shiny::actionButton( + ns('submit'), 'Change Threshold', + width = '100%'))) %>% leaflet.extras::addDrawToolbar(polylineOptions = F, circleOptions = F, circleMarkerOptions = F, @@ -763,21 +774,23 @@ leaf_map <- 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;}') %>% + # leaflet::addControl(html = shiny::actionButton(ns("deletebtn"), "remove drawn"), + # position = 'bottomright', + # className = 'fieldset {border:0;}') %>% leaflet::setView(lat = 37.0902, lng = -95.7129, zoom = 5) %>% leaflet::hideGroup(group = 'Hydrography') %>% leaflet::addLayersControl(baseGroups = c("Esri.WorldStreetMap","OpenTopoMap","Esri.WorldImagery", "CartoDB.Positron", "OpenStreetMap", "CartoDB.DarkMatter"), overlayGroups = c("Hydrography")) } - output$leaf_map <- leaflet::renderLeaflet({ + + +output$leaf_map <- leaflet::renderLeaflet({ leaf_map }) observe({ - if(!is.null(dem) & vals$count == 0) { + req(!is.null(dem) & vals$count == 0) p <- shiny::Progress$new() p$set(message = "Uploading your DEM...", detail = "This may take a little bit...", @@ -787,46 +800,45 @@ observe({ ws_dem <- get_whitebox_streams(ele = dem, threshold = threshold, + prj = sf::st_crs(dem), ...) - }) %...>% { - values$output_streams <- .[[2]] - values$output_pointer <- .[[3]] - values$streams <- .[[5]] - values$output_fa <- .[[6]] + + values$output_streams <- .[[2]] + values$output_pointer <- .[[3]] + values$streams <- .[[5]] + values$output_fa <- .[[6]] bb <- sf::st_bbox(dem) bb <- sf::st_bbox(sf::st_transform(sf::st_as_sfc(bb), 4326)) + + leaf_prox <- leaflet::leafletProxy('leaf_map', session) + vals$count <- sample(1:10000, size = 1) - leaflet::leafletProxy('leaf_map', session) %>% + leaf_prox %>% 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))) - - + paste0('stream', vals$count))) %>% + leaflet::fitBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']]) } %>% finally(~p$close()) -} -}) - # create a counter - vals <- shiny::reactiveValues(count = 0) +}) - observeEvent(input$leaf_map_draw_new_feature, { +observeEvent(input$leaf_map_draw_new_feature, { - checking <<- input$leaf_map if(input$leaf_map_draw_new_feature$geometry$type != 'Point') { # make sure ding the counter - vals$count <- sample(0:10000, size = 1) + vals$count <- sample(1:10000, size = 1) feat <- input$leaf_map_draw_new_feature coords <- unlist(feat$geometry$coordinates) @@ -889,7 +901,7 @@ observe({ if(input$leaf_map_draw_new_feature$geometry$type != 'Point') { - req(data_sf) + req(data_sf) ws_dem <- get_whitebox_streams(data_sf, input$map_res, @@ -980,28 +992,37 @@ observe({ # now for the dynamic threshold - observeEvent(input$threshold, ignoreInit = TRUE, { + observeEvent(input$submit, { 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, - ...) + whitebox::wbt_extract_streams(values$output_fa, output_streams, threshold = input$threshold, verbose_mode = F) + + # thin out the stream layer + whitebox::wbt_line_thinning(output_streams, output_streams) - # 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) + + if(is.null(dem)){ + + stream_vector <- sf::st_as_sf(sf::read_sf(output_stream_vector)) %>% + sf::st_set_crs(3857) %>% + sf::st_transform(4326) + + } else { + + stream_vector <- sf::st_as_sf(sf::read_sf(output_stream_vector)) %>% + sf::st_set_crs(sf::st_crs(dem)) %>% + sf::st_transform(4326) + + } streams <- list(streams = stream_vector) @@ -1012,7 +1033,7 @@ observe({ leaf_prox <- leaflet::leafletProxy('leaf_map', session)%>% leaflet::clearGroup(group = paste0('stream', vals$count)) - vals$count <- sample(0:10000, size = 1) + vals$count <- sample(1:10000, size = 1) leaf_prox %>% leaflet::addPolylines(data = values$streams, color = 'blue', group = paste0('stream', vals$count))%>% @@ -1195,7 +1216,6 @@ observe({ value = 1/2) promises::future_promise({ - ws_poly <- get_whitebox_streams(ele = dem, threshold = threshold, prj = sf::st_crs(dem), @@ -1244,10 +1264,6 @@ observe({ }) - # create a counter - - vals <- shiny::reactiveValues(count = 0) - observeEvent(input$submit, { if(!is.null(input$leaf_map_draw_new_feature)){ @@ -1635,7 +1651,6 @@ usgsdvMod <- function(input, output, session, values){ promises::future_promise({ - data('old_usgs_sites', package = 'gwavr') sites <- sf::st_as_sf(df_site_new, coords = c('location.coordinates1', 'location.coordinates2'), diff --git a/R/utils.R b/R/utils.R index 6ecd9b2..f8e492a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -232,10 +232,12 @@ get_whitebox_streams <- function(aoi, - if(missing(prj)){prj = "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +no_defs"} + if(!missing(ele) & missing(prj)) prj <- terra::crs(ele)@projargs if(missing(ele)){ + if(missing(prj)){prj = "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +no_defs"} + aoi <- aoi %>% sf::st_transform(prj) # download elevation @@ -650,8 +652,9 @@ get_dv <- function(sites) { } #' @title Selecting for Leaflet +#' @author Tim Appelhans, Kenton Russell, Lorenzo Busetto. #' @keywords internal -#' @description Taken from the interals of the \link{mapedit} package +#' @description Taken from the interals of the mapedit package. add_select_script <- function(lf, styleFalse, styleTrue, ns="") { ## check for existing onRender jsHook? diff --git a/man/add_select_script.Rd b/man/add_select_script.Rd index 1290d88..883dac5 100644 --- a/man/add_select_script.Rd +++ b/man/add_select_script.Rd @@ -7,6 +7,9 @@ add_select_script(lf, styleFalse, styleTrue, ns = "") } \description{ -Taken from the interals of the \link{mapedit} package +Taken from the interals of the mapedit package. +} +\author{ +Tim Appelhans, Kenton Russell, Lorenzo Busetto. } \keyword{internal} diff --git a/man/df_site_new.Rd b/man/df_site_new.Rd new file mode 100644 index 0000000..f5e2947 --- /dev/null +++ b/man/df_site_new.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{df_site_new} +\alias{df_site_new} +\title{Retired USGS Sites} +\format{ +\subsection{\code{df_site_new}}{ + +A data frame with 14,966 rows and 4 columns: +\describe{ +\item{SiteNumber}{Site Number} +\item{SiteName}{Site Name} +\item{location.coordinates1}{Longitude coordinates} +\item{location.coordinates2}{Latitude coordinates} +... +} +} +} +\usage{ +df_site_new +} +\description{ +A subset of data that has retired USGS sites and coordinates. +} +\keyword{datasets} diff --git a/man/get_basin_interactively.Rd b/man/get_basin_interactively.Rd index 846b2f4..42d5da9 100644 --- a/man/get_basin_interactively.Rd +++ b/man/get_basin_interactively.Rd @@ -30,7 +30,7 @@ behaviour in Firefox.} \item{title}{\code{string} to customize the title of the UI window. The default is "Delineate Basin".} -\item{dem}{A raster or terra object dem. (optional)} +\item{dem}{A 'SpatRaster' object dem. (optional)} \item{threshold}{A threshold for stream initiation. 1000 (default).} diff --git a/tests/testthat/test-nldi.R b/tests/testthat/test-nldi.R index 241e48e..4ab03be 100644 --- a/tests/testthat/test-nldi.R +++ b/tests/testthat/test-nldi.R @@ -1,3 +1,5 @@ +testthat::skip_on_cran() + test_that("testing get catchment characteristics from nhdplusTools", { point <- dplyr::tibble(Long = -115.2312,Lat = 48.83037) @@ -32,7 +34,7 @@ test_that("testing upstream main and tribs from nhdplusTools", { comid <- nhdplusTools::discover_nhdplus_id(point) nldiURLs <- list(site_data = paste0("https://labs.waterdata.usgs.gov/api/nldi/linked-data/comid/position?coords=POINT%28", - clng,"%20", clat, "%29"), + point[1,1],"%20", point[1,2], "%29"), basin_boundary = paste0("https://labs.waterdata.usgs.gov/api/nldi/linked-data/comid/",comid,"/basin"), UT = paste0("https://labs.waterdata.usgs.gov/api/nldi/linked-data/comid/",comid,"/navigation/UT/flowlines?distance=999"), UM = paste0("https://labs.waterdata.usgs.gov/api/nldi/linked-data/comid/",comid,"/navigation/UM/flowlines?distance=999")) diff --git a/tests/testthat/test-usgs.R b/tests/testthat/test-usgs.R index 589dea6..79c208a 100644 --- a/tests/testthat/test-usgs.R +++ b/tests/testthat/test-usgs.R @@ -1,3 +1,5 @@ +testthat::skip_on_cran() + test_that("usgs functions", { @@ -23,3 +25,5 @@ test_that("usgs functions", { comment.char = '#')), 2) }) + +