CRAN update

joshualerickson · May 10, 2024 · e46167b · e46167b
1 parent 067d111
commit e46167b
Show file tree

Hide file tree

Showing 11 changed files with 119 additions and 50 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
diff --git a/man/df_site_new.Rd b/man/df_site_new.Rd
diff --git a/man/get_basin_interactively.Rd b/man/get_basin_interactively.Rd
diff --git 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
@@ -1,3 +1,5 @@
+testthat::skip_on_cran()
+
 test_that("usgs functions", {
 
 
@@ -23,3 +25,5 @@ test_that("usgs functions", {
     comment.char = '#')), 2)
 
 })
+
+