Merge pull request #228 from dblodgett-usgs/master

Fixes #227 -- updated nhdplus network attributes

R/get_paths.R

@@ -147,7 +147,7 @@ get_levelpaths <- function(x, override_factor = NULL, status = FALSE, cores = NU
 
   outlets <- x %>%
     group_by(.data$levelpath) %>%
-    filter(topo_sort == min(topo_sort)) %>%
+    filter(.data$topo_sort == min(.data$topo_sort)) %>%
     ungroup() %>%
     select(outletID = .data$ID, .data$levelpath)
 
@@ -284,17 +284,18 @@ reweight <- function(x, ..., override_factor) {
 }
 
 .datatable.aware <- TRUE
+. <- fromid <- id <- NULL
 
 get_fromids <- function(index_ids, return_list = FALSE) {
   index_ids <- data.table::as.data.table(index_ids)
 
   froms <- merge(
-    index_ids[,.(id)],
+    index_ids[,list(id)],
     data.table::setnames(index_ids, c("toid", "id"), c("id", "fromid")),
     by = "id", all.x = TRUE
   )
 
-  froms <- froms[,.(froms = list(c(fromid))), by = id]
+  froms <- froms[,list(froms = list(c(fromid))), by = id]
 
   froms_l <- lengths(froms$froms)
   max_from <- max(froms_l)

R/get_vaa.R

@@ -3,14 +3,23 @@
 #' NHDPlusV2 attribute data sans geometry. This function returns the
 #' file path to the cached file. Will use the user data dir indicated
 #' by \link{nhdplusTools_data_dir}.
+#' @param updated_network logical default FALSE. If TRUE, returns path to updated
+#' network parameters. See \link{get_vaa} for more.
 #' @inherit download_vaa details
 #' @return character file path
 #' @export
 #' @examples
 #' get_vaa_path()
+#'
+#' get_vaa_path(updated_network = TRUE)
+#'
 
-get_vaa_path <- function() {
-  file.path(nhdplusTools_data_dir(), "nhdplusVAA.fst")
+get_vaa_path <- function(updated_network = FALSE) {
+  if(updated_network) {
+    file.path(nhdplusTools_data_dir(), "enhd_nhdplusatts.fst")
+  } else {
+    file.path(nhdplusTools_data_dir(), "nhdplusVAA.fst")
+  }
 }
 
 #' @title Available NHDPlusV2 Attributes
@@ -36,14 +45,17 @@ get_vaa_names <- function() {
 }
 
 #' @title NHDPlusV2 Attribute Subset
-#' @description Return requested NHDPlusv2 Attributes
+#' @description Return requested NHDPlusv2 Attributes.
 #' @inherit download_vaa details
 #' @param atts character The variable names you would like, always includes comid
 #' @param path character path where the file should be saved. Default is a
 #' persistent system data as retrieved by \link{nhdplusTools_data_dir}.
 #' Also see: \link{get_vaa_path}
 #' @param download logical if TRUE, the default, will download VAA table if not
 #' found at path.
+#' @param updated_network logical default FALSE. If TRUE, updated network attributes
+#' from E2NHD and National Water Model retrieved from
+#' \href{https://www.sciencebase.gov/catalog/item/60c92503d34e86b9389df1c9}{here.}
 #' @return data.frame containing requested VAA data
 #' @importFrom fst read.fst
 #' @export
@@ -54,39 +66,90 @@ get_vaa_names <- function() {
 #' get_vaa("slope")
 #' get_vaa(c("slope", "lengthkm"))
 #'
+#' get_vaa(updated_network = TRUE)
+#' get_vaa("reachcode", updated_network = TRUE)
+#'
 #' #cleanup if desired
 #' unlink(dirname(get_vaa_path()), recursive = TRUE)
 #' }
 
 get_vaa <- function(atts = NULL,
                     path = get_vaa_path(),
-                    download = TRUE) {
+                    download = TRUE,
+                    updated_network = FALSE) {
+
+  check_vaa_path(path, download, FALSE)
 
-  check_vaa_path(path, download)
+  if(updated_network) {
+    updated_net_path <- file.path(dirname(path), "enhd_nhdplusatts.fst")
 
-  avaliable_names = get_vaa_names()
+    check_vaa_path(updated_net_path, download, TRUE)
 
-  bad_atts = atts[!atts %in% avaliable_names]
-  atts      = atts[atts %in% avaliable_names]
-  if(length(bad_atts) > 0){
-    message(paste(bad_atts, collapse = ", "), " not in vaa data. Ignoring...")
+    new_names <- fst::metadata_fst(updated_net_path)[["columnNames"]]
   }
 
-  if(is.null(atts)){
-    return(fst::read.fst(path))
+  available_names = get_vaa_names()
+
+  if(is.null(atts)) {
+
+    atts <- available_names
+
+  } else {
+
+    bad_atts = atts[!atts %in% available_names]
+    atts      = atts[atts %in% available_names]
+    if(length(bad_atts) > 0){
+
+      message(paste(bad_atts, collapse = ", "), " not in vaa data. Ignoring...")
+
+    }
+
   }
 
-  if(all(atts %in% avaliable_names)){
-    return(fst::read_fst(path, c('comid', atts)))
+  if(updated_network) {
+
+    message("Caution: updated attributes drop some catchments and attributes")
+
+    deprecated_names <- c("streamcalc", "fromnode", "tonode",
+                          "dnlevel", "uplevelpat", "uphydroseq",
+                          "dnminorhyd", "divdasqkm")
+
+    include_names <- c("comid",
+                       atts[!atts %in%
+                              c(deprecated_names, new_names)])
+
+    replace_names <- atts[atts %in% new_names & !atts %in% deprecated_names]
+
+    # Grab the original vaas but not the ones we are going to replace.
+    out <- fst::read.fst(path, include_names)
+
+    # grab all the new attributes.
+    new_comid <- fst::read.fst(updated_net_path, "comid")
+
+    # reorder out to match new -- also drop stuff missing from new.
+    out <- out[match(new_comid$comid, out$comid), , drop = FALSE]
+
+    out <- cbind(out, fst::read.fst(updated_net_path,
+                                    c(replace_names[replace_names != "comid"])))
+
+    reorder <- match(get_vaa_names(), names(out))
+
+    reorder <- reorder[!is.na(reorder)]
+
+    return(out[, reorder])
+
+  } else {
+
+    return(fst::read_fst(path, c('comid', atts[atts != 'comid'])))
   }
 
 }
 
-check_vaa_path <- function(path = get_vaa_path(), download = TRUE) {
+check_vaa_path <- function(path, download, updated_network = FALSE) {
   if(!file.exists(path)){
     if(download) {
       message("didn't find data, downloading.")
-      path <- download_vaa(path = path)
+      path <- download_vaa(path, updated_network = updated_network)
     } else {
       stop("need to download data: run `download_vaa()`")
     }
@@ -103,20 +166,20 @@ check_vaa_path <- function(path = get_vaa_path(), download = TRUE) {
 #' \code{\link{get_vaa_path}}.
 #' To view aggregate data and documentation, see
 #' \href{https://www.hydroshare.org/resource/6092c8a62fac45be97a09bfd0b0bf726/}{here}
-#' @inheritParams  get_vaa
+#' @inheritParams get_vaa
 #' @param force logical. Force data re-download. Default = FALSE
 #' @return character path to cached data
 #' @export
 #' @importFrom httr GET progress write_disk
 
-download_vaa <- function(path = get_vaa_path(), force = FALSE) {
+download_vaa <- function(path = get_vaa_path(), force = FALSE, updated_network = FALSE) {
 
   if (file.exists(path) & !force) {
     message("File already cached")
   } else {
     dir.create(dirname(path), showWarnings = FALSE, recursive = TRUE)
 
-    resp <- httr::GET(vaa_hydroshare,
+    resp <- httr::GET(ifelse(updated_network, vaa_sciencebase, vaa_hydroshare),
                       httr::write_disk(path, overwrite = TRUE),
                       httr::progress())
 
@@ -128,3 +191,5 @@ download_vaa <- function(path = get_vaa_path(), force = FALSE) {
   return(path)
 }
 
+
+

R/nhdplusTools.R

@@ -2,6 +2,9 @@
 vaa_hydroshare <-
   'https://www.hydroshare.org/resource/6092c8a62fac45be97a09bfd0b0bf726/data/contents/nhdplusVAA.fst'
 
+vaa_sciencebase <-
+  'https://www.sciencebase.gov/catalog/file/get/60c92503d34e86b9389df1c9?f=__disk__eb%2Fe0%2F3f%2Febe03f6e23c5b37a854e50c4ae7875dbb846c143'
+
 nhdplusTools_env <- new.env()
 
 # NHDPlus Attributes

R/run_plus_attributes.R

@@ -60,7 +60,7 @@ combine_networks <- function(lp) {
   }
 
   lp <- lapply(lp, function(x) {
-    mutate(x, terminalpath = min(topo_sort))
+    mutate(x, terminalpath = min(.data$topo_sort))
   })
 
   bind_rows(lp)

R/subset_nhdplus.R

@@ -218,28 +218,6 @@ subset_nhdplus <- function(comids = NULL, output_file = NULL, nhdplus_data = NUL
 
   if (nhdplus_data == "download") {
 
-    if(!is.null(bbox)) {
-      # Just hacking in some test mock data
-      test_cache_f <- paste0("nhd_data",
-                             paste0(as.character(round(bbox, 2)), collapse = ""), ".rds")
-    } else {
-      test_cache_f <- "nope.nope.nope"
-    }
-
-    if(!exists("out_list")) {
-      out_list <- NULL
-    }
-    check_geom <- TRUE
-
-    tc <- list.files(pattern = test_cache_f,
-                     recursive = TRUE,
-                     full.names = TRUE)
-
-    if(length(tc) > 0 && file.exists(tc)) {
-      out_list <- readRDS(tc)
-      check_geom <- FALSE
-    }
-
     for (layer_name in intersection_names) {
       if(is.null(out_list[layer_name][[1]])) {
         layer <- sf::st_transform(envelope, 4326) %>%
@@ -250,8 +228,7 @@ subset_nhdplus <- function(comids = NULL, output_file = NULL, nhdplus_data = NUL
 
       if(!is.null(nrow(layer)) && nrow(layer) > 0) {
 
-        if(check_geom)
-          layer <- check_valid(layer, out_prj)
+        layer <- check_valid(layer, out_prj)
 
         if(return_data) {
           out_list[layer_name] <- list(layer)
@@ -646,8 +623,8 @@ check_valid <- function(x, out_prj = sf::st_crs(x)) {
 
           sf::st_geometry(x) <-
             sf::st_sfc(lapply(sf::st_geometry(x), fix_g_type,
-                                         type = gsub("^MULTI", "", orig_type),
-                                         orig_type = orig_type),
+                              type = gsub("^MULTI", "", orig_type),
+                              orig_type = orig_type),
                        crs = sf::st_crs(x))
 
           x <- sf::st_cast(x, orig_type)
@@ -658,7 +635,13 @@ check_valid <- function(x, out_prj = sf::st_crs(x)) {
   }
 
   if (any(grepl("POLYGON", class(sf::st_geometry(x))))) {
-    suppressMessages(suppressWarnings(x <- sf::st_buffer(x, 0)))
+    suppressMessages(suppressWarnings(
+      {
+        use_s2 <- sf::sf_use_s2()
+        sf::sf_use_s2(FALSE)
+        x <- sf::st_buffer(x, 0)
+        sf::sf_use_s2(use_s2)
+      }))
   }
 
   if (sf::st_crs(x) != sf::st_crs(out_prj)) {

nhdplusTools.Rproj

@@ -19,5 +19,5 @@ BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
 PackageBuildArgs: --no-manual --no-build-vignettes
-PackageCheckArgs: --no-vignettes --no-manual
+PackageCheckArgs: --no-multiarch --no-vignettes --no-manual
 PackageRoxygenize: rd,collate,namespace

tests/testthat/test_get_vaa.R

@@ -22,4 +22,11 @@ test_that("vaa examples", {
   expect_message(vaa_path_2 <- download_vaa(), "File already cached")
 
   expect_equal(vaa_path, vaa_path_2)
+
+  expect_message(update <- get_vaa("reachcode", updated_network = TRUE))
+
+  expect_equal(names(update), c("comid", "reachcode"))
+
+  expect_error(capture_messages(get_vaa("bad", updated_network = TRUE)))
+
 })