Merge c5680da into 26b1c63

NAMESPACE

@@ -18,8 +18,10 @@ export(get_UT)
 export(get_flowline_index)
 export(get_nhdplushr)
 export(get_nldi_basin)
+export(get_nldi_feature)
 export(navigate_nldi)
 export(nhdplus_path)
+export(plot_nhdplus)
 export(prepare_nhdplus)
 export(stage_national_data)
 export(subset_nhdplus)

R/get_nhdplus.R

@@ -52,11 +52,10 @@ discover_nhdplus_id <- function(point = NULL, nldi_feature = NULL) {
 
     if (is.null(nldi_feature[["tier"]])) nldi_feature[["tier"]] <- "prod"
 
-    nldi <- get_nldi_feature(nldi_feature[["featureSource"]],
-                             nldi_feature[["featureID"]],
+    nldi <- get_nldi_feature(nldi_feature,
                              nldi_feature[["tier"]])
 
-    return(as.integer(nldi$features$properties$comid))
+    return(as.integer(nldi$comid))
 
   } else {
 

R/get_nldi.R

@@ -16,13 +16,12 @@ discover_nldi_sources <- function(tier = "prod") {
 #' @title Discover NLDI Navigation Options
 #' @description Discover available navigation options for a
 #' given feature source and id.
-#' @param nldi_feature list with names `featureSource` and `featureID` where
-#' `featureSource` is derived from the "source" column of  the response of
-#' discover_nldi_sources() and the `featureSource` is a known identifier
-#' from the specified `featureSource`.
+#' @param nldi_feature length 2 list list with optionsal names `featureSource`
+#' and `featureID` where `featureSource` is derived from the "source" column of
+#' the response of discover_nldi_sources() and the `featureSource` is a known identifier
+#' from the specified `featureSource`. e.g. list("nwissite", "USGS-08279500")
 #' @param tier character optional "prod" or "test"
-#' @return data.frame with three columns "source", "sourceName"
-#' and "features"
+#' @return data.frame with three columns "source", "sourceName" and "features"
 #' @export
 #' @examples
 #' \donttest{
@@ -31,9 +30,12 @@ discover_nldi_sources <- function(tier = "prod") {
 #' nldi_nwis <- list(featureSource = "nwissite", featureID = "USGS-08279500")
 #'
 #' discover_nldi_navigation(nldi_nwis)
+#'
+#' discover_nldi_navigation("nwissite", "USGS-08279500")
 #' }
 discover_nldi_navigation <- function(nldi_feature, tier = "prod") {
-  check_nldi_feature(nldi_feature)
+  nldi_feature <- check_nldi_feature(nldi_feature)
+
   query <- paste(nldi_feature[["featureSource"]],
                  nldi_feature[["featureID"]],
                  "navigate", sep = "/")
@@ -61,7 +63,7 @@ discover_nldi_navigation <- function(nldi_feature, tier = "prod") {
 #' library(sf)
 #' library(dplyr)
 #'
-#' nldi_nwis <- list(featureSource = "nwissite", featureID = "USGS-05428500")
+  #' nldi_nwis <- list(featureSource = "nwissite", featureID = "USGS-05428500")
 #'
 #' navigate_nldi(nldi_feature = nldi_nwis,
 #'               mode = "upstreamTributaries",
@@ -88,9 +90,11 @@ discover_nldi_navigation <- function(nldi_feature, tier = "prod") {
 #' }
 #'
 navigate_nldi <- function(nldi_feature, mode = "upstreamMain",
-                          data_source = "comid", distance_km = NULL,
+                          data_source = "flowline", distance_km = NULL,
                           tier = "prod") {
 
+  nldi_feature <- check_nldi_feature(nldi_feature)
+
   nav_lookup <- list(upstreamMain = "UM",
                      upstreamTributaries = "UT",
                      downstreamMain = "DM",
@@ -104,6 +108,8 @@ navigate_nldi <- function(nldi_feature, mode = "upstreamMain",
     }
   }
 
+  if(data_source == "flowline") data_source <- ""
+
   query <- paste(nldi_feature[["featureSource"]],
                  nldi_feature[["featureID"]],
                  "navigate", mode, data_source,
@@ -152,6 +158,8 @@ navigate_nldi <- function(nldi_feature, mode = "upstreamMain",
 get_nldi_basin <- function(nldi_feature,
                           tier = "prod") {
 
+  nldi_feature <- check_nldi_feature(nldi_feature)
+
   query <- paste(nldi_feature[["featureSource"]],
                  nldi_feature[["featureID"]],
                  "basin",
@@ -162,12 +170,23 @@ get_nldi_basin <- function(nldi_feature,
 }
 
 
-
-#' @noRd
-get_nldi_feature <- function(f_source, f_id, tier = "prod") {
-  return(query_nldi(paste(f_source, f_id,
-                          sep = "/"),
-                    tier))
+#' @title Get NLDI Feature
+#' @description Get a single feature from the NLDI
+#' @param nldi_feature list with names `featureSource` and `featureID` where
+#' `featureSource` is derived from the "source" column of  the response of
+#' discover_nldi_sources() and the `featureSource` is a known identifier
+#' from the specified `featureSource`.
+#' @param tier character optional "prod" or "test"
+#' @return sf feature collection with one feature
+#' @examples
+#' get_nldi_feature(list("featureSource" = "nwissite", featureID = "USGS-05428500"))
+#' @export
+get_nldi_feature <- function(nldi_feature, tier = "prod") {
+  nldi_feature <- check_nldi_feature(nldi_feature)
+  return(sf::read_sf(query_nldi(paste(nldi_feature[["featureSource"]],
+                                      nldi_feature[["featureID"]],
+                                      sep = "/"),
+                                tier, parse_json = FALSE)))
 }
 
 #' @importFrom httr GET
@@ -211,12 +230,14 @@ get_nldi_url <- function(tier = "prod") {
 #' @noRd
 check_nldi_feature <- function(nldi_feature) {
   expect_names <- c("featureSource", "featureID")
-  if (!all(expect_names %in%
-           names(nldi_feature))) {
-    stop(paste0("Missing some required input for NLDI. ",
-                "Expected: ",
-                paste(expect_names[which(!(expect_names %in%
-                                             names(nldi_feature)))],
-                      collapse = ", ")))
+  if (!all(expect_names %in% names(nldi_feature))) {
+    if(length(nldi_feature) != 2 | !all(sapply(nldi_feature, is.character)))
+      stop(paste0("Missing some required input for NLDI. ",
+                  "Expected length 2 character fector with optional names: ",
+                  paste(expect_names[which(!(expect_names %in%
+                                               names(nldi_feature)))],
+                        collapse = ", ")))
   }
+  names(nldi_feature) <- expect_names
+  return(nldi_feature[expect_names])
 }

R/plot_nhdplus.R

@@ -0,0 +1,58 @@
+#' @title Plot NHDPlus
+#' @description Given a list of sites, get their basin boundaries and network and return a plot.
+#' @param sites character vector of site ids in the format "USGS-01234567"
+#' @param bbox vector of map limits (xmin, ymin, xmax, ymax) that can be coerced into an object of class bbox.
+#' @param streamorder integer only streams of order greater than or equal will be returned
+#' @param gpkg path and file with .gpkg ending. If NA, no file is written.
+#' @export
+#' @examples
+#' plot_nhdplus("USGS-05428500")
+#'
+plot_nhdplus <- function(sites, bbox = NA, streamorder = NA, gpkg = NA) {
+
+  if(!is.na(bbox) | !is.na(streamorder) | !is.na(gpkg)) {
+    # Only sites implemented so far.
+  }
+
+  pd <- get_plot_data(sites, bbox, streamorder, gpkg)
+
+  prettymapr::prettymap({
+    rosm::osm.plot(pd$plot_bbox, type = "cartolight", quiet = TRUE)
+    # plot(gt(catchment), lwd = 0.5, col = NA, border = "grey", add = TRUE)
+    graphics::plot(gt(pd$basin), lwd = 1, col = NA, border = "black", add = TRUE)
+    graphics::plot(gt(pd$flowline), lwd = 1, col = "blue", add = TRUE)
+    graphics::plot(gt(pd$sites), col = "grey40", pch = 17, add = TRUE)
+  },
+  drawarrow = TRUE)
+}
+
+get_plot_data <- function(sites, bbox = NA, streamorder = 3, gpkg = NA) {
+  basin <- do.call(rbind,
+                   lapply(sites, function(x)
+                     get_nldi_basin(list(featureSource = "nwissite",
+                                         featureID = x))))
+
+  plot_bbox <- sp_bbox(sf::st_transform(basin, 4326))
+
+  flowline <- do.call(rbind,
+                      lapply(sites, function(x)
+                        navigate_nldi(list(featureSource = "nwissite",
+                                           featureID = x),
+                                      mode = "UT",
+                                      data_source = "")))
+
+  sites <- do.call(rbind,
+                   lapply(sites, function(x)
+                     get_nldi_feature(list(featureSource = "nwissite",
+                                           featureID = x))))
+
+  return(list(plot_bbox = plot_bbox, sites = sites, flowline = flowline, basin = basin))
+}
+
+gt <- function(x) sf::st_geometry(sf::st_transform(x, 3857))
+
+sp_bbox <- function(g) {
+  matrix(as.numeric(sf::st_bbox(g)),
+         nrow = 2, dimnames = list(c("x", "y"),
+                                   c("min", "max")))
+}