#' @title Discover Characteristics Metadata
#' @description Provides access to metadata for characteristics that are returned by `get_nldi_characteristics()`.
#' @param type character "all", "local", "total", or "divergence_routed".
#' @export
#' @return data.frame containing available characteristics
#' @examples
#' chars <- discover_nldi_characteristics()
#' names(chars)
#' head(chars$local, 10)
discover_nldi_characteristics <- function(type="all") {
tc <- type_check(type)
out <- lapply(tc$type_options[[type]], function(x) {
o <- query_nldi(paste0(x, "/characteristics"),
base_path = "/lookups")
if(is.null(o)) {
return(NULL)
}
o$characteristicMetadata$characteristic
})
names(out) <- tc$char_names
out
}
type_check <- function(type) {
type_options <- list("all" = c("local", "tot", "div"),
"local" = "local",
"total" = "tot",
"divergence_routed" = "div")
if(!type %in% names(type_options)) stop(paste("Type must be one of", paste(names(type_options), collapse = ", ")))
char_names <- type
if(type == "all") char_names <- names(type_options)[2:4]
return(list(type_options = type_options, char_names = char_names))
}
#' @title Navigate NLDI
#' @description Navigate the Network Linked Data Index network.
#' @param nldi_feature list with names `featureSource` and `featureID` where
#' `featureSource` is derived from the "source" column of the response of
#' \link[dataRetrieval]{get_nldi_sources} and the `featureID` is a known identifier
#' from the specified `featureSource`.
#' @param mode character chosen from ("UM", "UT", DM", "DD"). See examples.
#' @param data_source character chosen from "source" column of the response
#' of \link[dataRetrieval]{get_nldi_sources} or empty string for flowline geometry.
#' @param distance_km numeric distance in km to stop navigating.
#' @return sf data.frame with result
#' @export
#' @importFrom utils tail
#' @examples
#' \donttest{
#' library(sf)
#' library(dplyr)
#'
#' nldi_nwis <- list(featureSource = "nwissite", featureID = "USGS-05428500")
#'
#' navigate_nldi(nldi_feature = nldi_nwis,
#' mode = "upstreamTributaries")$UT %>%
#' st_geometry() %>%
#' plot()
#'
#' navigate_nldi(nldi_feature = nldi_nwis,
#' mode = "UM")$UM %>%
#' st_geometry() %>%
#' plot(col = "blue", add = TRUE)
#'
#'
#'
#' nwissite <- navigate_nldi(nldi_feature = nldi_nwis,
#' mode = "UT",
#' data_source = "nwissite")$UT_nwissite
#'
#' st_geometry(nwissite) %>%
#' plot(col = "green", add = TRUE)
#'
#' nwissite
#' }
#'
navigate_nldi <- function(nldi_feature, mode = "upstreamMain",
data_source = "flowlines", distance_km = 10) {
nldi_feature <- check_nldi_feature(nldi_feature)
nav_lookup <- list(upstreamMain = "UM",
upstreamTributaries = "UT",
downstreamMain = "DM",
downstreamDiversions = "DD")
if (nchar(mode) > 2) {
if (nchar(mode) < 30) {
mode <- nav_lookup[[mode]]
} else {
mode <- tail(unlist(strsplit(mode, "/")), n = 1)
}
}
# For backward compatibility
if(data_source == "flowline" | data_source == "") {
data_source <- "flowlines"
warning("data source specified as flowline or '' is deprecated")
}
tryCatch(dataRetrieval::findNLDI(origin = nldi_feature,
nav = mode,
find = data_source,
distance_km = distance_km,
no_sf = FALSE),
error = function(e) NULL)
}
#' @title Get NLDI Basin Boundary
#' @description Get a basin boundary for a given NLDI feature.
#' @details Only resolves to the nearest NHDPlus catchment divide. See:
#' https://waterdata.usgs.gov/blog/nldi-intro/ for more info on the nldi.
#' @inheritParams navigate_nldi
#' @param simplify logical should response geometry be simplified for
#' visualization and performance?
#' @param split logical should response resolve precisely to the location
#' of the `nldi_feature`? Setting `TRUE` calls an additional service and
#' will be slower and less robust.
#' @return sf data.frame with result basin boundary
#' @export
#' @importFrom sf read_sf
#' @examples
#' \donttest{
#' library(sf)
#' library(dplyr)
#'
#' nldi_nwis <- list(featureSource = "nwissite", featureID = "USGS-05428500")
#'
#' site <- get_nldi_feature(nldi_nwis)
#'
#' basin <- get_nldi_basin(nldi_feature = nldi_nwis)
#'
#' plot(st_geometry(basin))
#'
#' basin
#'
#' basin2 <- get_nldi_basin(nldi_feature = nldi_nwis,
#' simplify = FALSE, split = TRUE)
#'
#' if(inherits(basin, "sf") & inherits(basin2, "sf")) {
#'
#' length(st_coordinates(basin))
#' length(st_coordinates(basin2))
#'
#' plot(st_geometry(st_buffer(site, units::set_units(3000, "m"))), border = NA)
#'
#' plot(st_geometry(site), add = TRUE)
#' plot(st_geometry(basin2), add = TRUE)
#'
#' plot(st_geometry(basin), border = "red", add = TRUE)
#'
#' }
#' }
get_nldi_basin <- function(nldi_feature, simplify = TRUE, split = FALSE) {
tryCatch({
nldi_feature <- check_nldi_feature(nldi_feature, convert = FALSE)
o <- query_nldi(
paste0(nldi_feature[["featureSource"]], "/",
nldi_feature[["featureID"]], "/",
"basin?simplify=",
ifelse(simplify, "true", "false"), "&",
"splitCatchment=",
ifelse(split, "true", "false")),
parse_json = FALSE)
if(is.null(o)) return(NULL)
read_sf(o)
}, error = function(e) {
warning(e)
return(NULL)
})
}
#' @title Get NLDI Feature
#' @description Get a single feature from the NLDI
#' @inheritParams navigate_nldi
#' @return sf data.frame with one feature
#' @examples
#' \donttest{
#' get_nldi_feature(list("featureSource" = "nwissite", featureID = "USGS-05428500"))
#' }
#' @export
get_nldi_feature <- function(nldi_feature) {
nldi_feature <- check_nldi_feature(nldi_feature)
out <- tryCatch(dataRetrieval::findNLDI(origin = nldi_feature),
error = function(e) NULL)
return(out$origin)
}
#' @title Get Catchment Characteristics
#' @description Retrieves catchment characteristics from the Network Linked Data Index.
#' Metadata for these characteristics can be found using `discover_nldi_characteristics()`.
#' @inheritParams navigate_nldi
#' @inheritParams discover_nldi_characteristics
#' @return data.frame containing requested characteristics
#' @export
#' @examples
#' \donttest{
#' chars <- get_nldi_characteristics(list(featureSource = "nwissite", featureID = "USGS-05429700"))
#' names(chars)
#' head(chars$local, 10)
#' }
get_nldi_characteristics <- function(nldi_feature, type="local") {
tc <- type_check(type)
nldi_feature <- check_nldi_feature(nldi_feature, convert = FALSE)
out <- lapply(tc$type_options[[type]], function(x) {
o <- query_nldi(paste(nldi_feature[["featureSource"]],
nldi_feature[["featureID"]],
x,
sep = "/"))
o$characteristics
})
names(out) <- tc$char_names
out
}
#' Get NLDI Index
#' @description uses the Network Linked Data Index to retrieve and estimated
#' network location for the given point. If not within a grid cell of a flowline,
#' will use a raindrop trace service to find the nearest downslope flowline
#' location.
#' @param location numeric WGS84 lon/lat pair (X, Y)
#' @export
#' @examples
#' \donttest{
#' index <- get_nldi_index(c(-89.276, 42.988))
#'
#' if(inherits(index, "sf")) {
#'
#' plot_nhdplus(bbox = sf::st_bbox(sf::st_buffer(index[1,], units::set_units(1000, "m"))))
#' plot(sf::st_geometry(sf::st_transform(index, 3857)), add = TRUE)
#'
#' }
#' }
get_nldi_index <- function(location) {
tryCatch({
sf::read_sf(query_nldi(paste0("hydrolocation?coords=POINT(",
location[1],"%20", location[2],")"),
parse_json = FALSE))
}, error = function(e) {
warning(paste("Something went wrong querying the NLDI.\n", e))
NULL
})
}
#' @importFrom httr GET
#' @importFrom jsonlite fromJSON
#' @noRd
query_nldi <- memoise::memoise(function(query, base_path = "/linked-data", parse_json = TRUE) {
nldi_base_url <- paste0(get_nldi_url(), base_path)
url <- paste(nldi_base_url, query,
sep = "/")
tryCatch({
if(nhdplus_debug()) {
message(url)
}
req_data <- rawToChar(httr::RETRY("GET", url)$content)
if (nchar(req_data) == 0) {
NULL
} else {
if (parse_json) {
tryCatch(jsonlite::fromJSON(req_data, simplifyVector = TRUE),
error = function(e) {
message("Something went wrong accessing the NLDI.\n", e)
}, warning = function(w) {
message("Something went wrong accessing the NLDI.\n", w)
})
} else {
req_data
}
}
}, error = function(e) {
warning("Something went wrong accessing the NLDI.\n", e)
NULL
})
}, ~memoise::timeout(nhdplusTools_memoise_timeout()), cache = nhdplusTools_memoise_cache())
#' @noRd
check_nldi_feature <- function(nldi_feature, convert = TRUE) {
expect_names <- c("featureSource", "featureID")
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 vector or list with optional names: ",
paste(expect_names[which(!(expect_names %in%
names(nldi_feature)))],
collapse = ", ")))
}
nldi_feature <- as.list(nldi_feature)
names(nldi_feature) <- expect_names
if(nldi_feature$featureSource == "nwissite" && convert) {
if(grepl("^USGS-", nldi_feature$featureID)) {
nldi_feature$featureID <- gsub("USGS-", "", nldi_feature$featureID)
nldi_feature$featureSource <- "nwis"
}
}
names(nldi_feature) <- expect_names
if(convert) {
stats::setNames(list(nldi_feature[["featureID"]]), nldi_feature[["featureSource"]])
} else {
nldi_feature
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.