Merge fc8b9fd into e833b47

DOI-USGS · Oct 2, 2019 · 40b44d8 · 40b44d8
2 parents e833b47 + fc8b9fd
commit 40b44d8
Show file tree

Hide file tree

Showing 9 changed files with 176 additions and 33 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -6,7 +6,7 @@ Authors@R: c(person(given = "David",
                     family = "Blodgett", 
                     role = c("aut", "cre"), 
                     email = "dblodgett@usgs.gov"),
-             person(given = "Michael",
+             person(given = "Mike",
                     family = "Johnson",
                     role = "ctb"))
 Description: Tools for traversing and working with National Hydrography Dataset Plus (NHDPlus) data. All methods implemented in 'nhdplusTools' are available in the NHDPlus documentation available from the US Environmental Protection Agency <https://www.epa.gov/waterdata/basic-information>.

diff --git a/NAMESPACE b/NAMESPACE
@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(align_nhdplus_names)
 export(calculate_arbolate_sum)
 export(calculate_levelpaths)
 export(calculate_total_drainage_area)
@@ -23,6 +24,7 @@ export(prepare_nhdplus)
 export(stage_national_data)
 export(subset_nhdplus)
 importFrom(RANN,nn2)
+importFrom(dplyr,arrange)
 importFrom(dplyr,desc)
 importFrom(dplyr,distinct)
 importFrom(dplyr,filter)

diff --git a/R/get_network.R b/R/get_network.R
@@ -90,8 +90,8 @@ private_get_UT <- function(network, comid) {
 #' @param distance numeric distance in km to limit how many COMIDs are
 #' returned. The COMID that exceeds the distance specified is returned.
 #' @return integer vector of all COMIDs upstream of the starting COMID
-#' along the mainstem.
-#' @importFrom dplyr filter
+#' along the mainstem in order of distance from the input COMID (nearest to farthest)
+#' @importFrom dplyr filter select arrange
 #' @export
 #' @examples
 #' library(sf)
@@ -108,15 +108,17 @@ private_get_UT <- function(network, comid) {
 #' plot(dplyr::filter(sample_flines, COMID %in% UM_COMIDs)$geom,
 #'      col = "blue", add = TRUE, lwd = 2)
 #'
+
 get_UM <- function(network, comid, distance = NULL) {
 
   network <- check_names(network, "get_UM")
 
-  main <- filter(network, COMID %in% comid)
+  main <- filter(network, COMID %in% comid) %>%
+    select(COMID, LevelPathI, Hydroseq, Pathlength, LENGTHKM)
 
-  main_us <- filter(network, LevelPathI %in% main$LevelPathI &
-                      Hydroseq >= main$Hydroseq)[c("COMID", "Hydroseq",
-                                                   "Pathlength", "LENGTHKM")]
+  main_us <- network %>%
+    filter(LevelPathI %in% main$LevelPathI & Hydroseq >= main$Hydroseq) %>%
+    select(COMID, Hydroseq, Pathlength, LENGTHKM)
 
   if (!is.null(distance)) {
 
@@ -127,7 +129,12 @@ get_UM <- function(network, comid, distance = NULL) {
     stop_pathlength <- main$Pathlength - main$LENGTHKM + distance
 
     main_us <- filter(main_us, Pathlength <= stop_pathlength)
+
   }
+
+  main_us <- arrange(main_us, Pathlength) %>%
+    filter(COMID != comid)
+
   return(main_us$COMID)
 }
 
@@ -139,8 +146,8 @@ get_UM <- function(network, comid, distance = NULL) {
 #' @param distance numeric distance in km to limit how many COMIDs are
 #' returned. The COMID that exceeds the distance specified is returned.
 #' @return integer vector of all COMIDs downstream of the starting COMID
-#' along the mainstem.
-#' @importFrom dplyr filter
+#' along the mainstem in order of distance from the input COMID (nearest to farthest)
+#' @importFrom dplyr select filter arrange desc
 #' @export
 #' @examples
 #' library(sf)
@@ -158,6 +165,8 @@ get_UM <- function(network, comid, distance = NULL) {
 #'      col = "blue", add = TRUE, lwd = 2)
 #'
 #'
+
+
 get_DM <- function(network, comid, distance = NULL) {
 
   if (!is.null(distance)) {
@@ -169,10 +178,10 @@ get_DM <- function(network, comid, distance = NULL) {
     network <- check_names(network, "get_DM_nolength")
 
     network <- dplyr::select(network, get("get_DM_nolength_attributes",
-                                          nhdplusTools_env))
+                                          nhdplusTools_env), Pathlength)
   }
 
-  if ("sf" %in% class(network)) network <- sf::st_set_geometry(network, NULL)
+  if ("sf" %in% class(network)) { network <- sf::st_set_geometry(network, NULL) }
 
   start_comid <- filter(network, COMID == comid)
 
@@ -183,15 +192,22 @@ get_DM <- function(network, comid, distance = NULL) {
   all <- private_get_DM(network, comid)
 
   if (!is.null(distance)) {
-    stop_pathlength <- start_comid$Pathlength +
-      start_comid$LENGTHKM -
-      distance
+    stop_pathlength <- start_comid$Pathlength + start_comid$LENGTHKM - distance
 
-    network <- filter(network, COMID %in% all)
+    network <- network %>%
+      filter(COMID %in% all$COMID,
+             (Pathlength + LENGTHKM) >= stop_pathlength,
+             COMID != comid) %>%
+      arrange(desc(Pathlength))
+
+    return(network$COMID)
 
-    return(filter(network, (Pathlength + LENGTHKM) >= stop_pathlength)$COMID)
   } else {
-    return(all)
+
+    all <- all %>%
+      arrange(desc(Pathlength)) %>%
+      filter(COMID != comid)
+    return(all$COMID)
   }
 
 }
@@ -209,17 +225,20 @@ private_get_DM <- function(network, comid) {
   ds_hs <- filter(ds_main, !DnLevelPat %in% main$LevelPathI)$DnHydroseq
 
   if(length(ds_hs) > 0) {
+
     ds_lpid <- filter(network, Hydroseq == ds_hs)$LevelPathI
+
     if (length(ds_lpid) > 0) {
       ds_comid <- filter(network,
                          LevelPathI == ds_lpid &
-                           Hydroseq <= ds_hs)$COMID
-      c(ds_main$COMID, private_get_DM(network, ds_comid))
+                         Hydroseq <= ds_hs)$COMID
+
+      rbind(select(ds_main, COMID, Pathlength), private_get_DM(network, ds_comid))
     } else {
-      return(ds_main$COMID)
+      return(select(ds_main, COMID, Pathlength))
     }
   } else {
-    return(ds_main$COMID)
+    return(select(ds_main, COMID, Pathlength))
   }
 }
 

diff --git a/R/nhdplusTools.R b/R/nhdplusTools.R
@@ -203,3 +203,75 @@ nhdplus_path <- function(path = NULL, warn = FALSE) {
       return(get("nhdplus_data", envir = nhdplusTools_env))
   }
 }
+
+#' @noRd
+#' These are the names that come from the packaged data: "petapsco_flowlines.gpkg"
+#' and thus the assumed names all nhdplusTools functions work on:
+
+good_names = c("COMID", "FDATE", "RESOLUTION",
+               "GNIS_ID", "GNIS_NAME", "LENGTHKM",
+               "REACHCODE", "FLOWDIR", "WBAREACOMI",
+               "FTYPE", "FCODE", "Shape_Length",
+               "StreamLeve", "StreamOrde", "StreamCalc",
+               "FromNode", "ToNode", "Hydroseq",
+               "LevelPathI", "Pathlength", "TerminalPa",
+               "ArbolateSu", "Divergence", "StartFlag",
+               "TerminalFl", "DnLevel", "UpLevelPat",
+               "UpHydroseq", "DnLevelPat", "DnMinorHyd",
+               "DnDrainCou", "DnHydroseq", "FromMeas",
+               "ToMeas", "RtnDiv", "VPUIn",
+               "VPUOut", "AreaSqKM", "TotDASqKM",
+               "DivDASqKM", "Tidal", "TOTMA",
+               "WBAreaType", "HWNodeSqKM", "MAXELEVRAW",
+               "MINELEVRAW", "MAXELEVSMO", "MINELEVSMO",
+               "SLOPE", "ELEVFIXED", "HWTYPE",
+               "SLOPELENKM",
+               "QA_MA", "VA_MA", "QC_MA", "VC_MA", "QE_MA", "VE_MA",
+               "QA_01", "VA_01", "QC_01", "VC_01", "QE_01", "VE_01",
+               "QA_02", "VA_02", "QC_02", "VC_02", "QE_02", "VE_02",
+               "QA_03", "VA_03", "QC_03", "VC_03", "QE_03", "VE_03",
+               "QA_04", "VA_04", "QC_04", "VC_04", "QE_04", "VE_04",
+               "QA_05", "VA_05", "QC_05", "VC_05", "QE_05", "VE_05",
+               "QA_06", "VA_06", "QC_06", "VC_06", "QE_06", "VE_06",
+               "QA_07", "VA_07", "QC_07", "VC_07", "QE_07", "VE_07",
+               "QA_08", "VA_08", "QC_08", "VC_08", "QE_08", "VE_08",
+               "QA_09", "VA_09", "QC_09", "VC_09", "QE_09", "VE_09",
+               "QA_10", "VA_10", "QC_10", "VC_10", "QE_10", "VE_10",
+               "QA_11", "VA_11", "QC_11", "VC_11", "QE_11", "VE_11",
+               "QA_12", "VA_12", "QC_12", "VC_12", "QE_12", "VE_12",
+               "LakeFract", "SurfArea", "RAreaHLoad",
+               "RPUID", "VPUID", "Enabled",
+               "geom")
+
+
+#' @title Align NHD Dataset Names
+#' @description this function takes any NHDPlus dataset and aligns the attribute names with those used in nhdplusTools.
+#' @param x a \code{sf} object of nhdplus flowlines
+#' @return a renamed \code{sf} object
+#' @export
+#' @examples
+#' \dontrun{
+#' a = AOI::getAOI(list("UCSB", 1, 1))
+#' n = HydroData::findNHD(a)[[2]] %>% align_nhdplus_names()
+#' UM_comids = get_UM(n, n$COMID[3])
+#' }
+
+align_nhdplus_names = function(x){
+
+  old_names <- names(x)
+  new_names <- old_names
+
+  matched <- match(toupper(names(x)), toupper(good_names))
+
+  replacement_names <- as.character(good_names[matched[which(!is.na(matched))]])
+
+  new_names[which(toupper(old_names) %in% toupper(good_names))] <- replacement_names
+  names(x) <- new_names
+  return(x)
+
+}
+
+
+
+
+
diff --git a/inst/extdata/cida_flowlines.gpkg b/inst/extdata/cida_flowlines.gpkg
diff --git a/man/align_nhdplus_names.Rd b/man/align_nhdplus_names.Rd
diff --git a/tests/testthat/test_align_nhdplus_names.R b/tests/testthat/test_align_nhdplus_names.R
@@ -0,0 +1,14 @@
+context("align_nhdplus_names")
+
+cida = sf::read_sf(system.file("extdata", "cida_flowlines.gpkg", package = "nhdplusTools"))
+comid = cida$comid[33]
+
+test_that("cida names dont work with get_UM", {
+  expect_error(get_DM(cida, 8585070))
+})
+
+test_that("aligned cida names work", {
+  aligned = align_nhdplus_names(cida)
+  result <- get_DM(aligned, 8585070)
+  expect_equal(length(result), 25)
+})
diff --git a/tests/testthat/test_get_network.R b/tests/testthat/test_get_network.R
@@ -5,25 +5,29 @@ pt_data <- sf::read_sf(system.file("extdata/petapsco_flowlines.gpkg",
 
 test_that("get_DM works normal", {
   result <- get_DM(pt_data, 11689050)
-  expect_equal(length(result), 26)
+  #expect_equal(length(result), 26)
+  expect_equal(length(result), 25)
 })
 
 test_that("get_DM works short", {
   result <- get_DM(pt_data, 11690570)
-  expect_equal(length(result), 6)
+  # expect_equal(length(result), 6)
+  expect_equal(length(result), 5)
 })
 
 test_that("get_DM works for no divergence", {
   result <- get_DM(pt_data, 11688810)
   expect_true(!11688828 %in% result)
-  expect_equal(length(result), 35)
+  # expect_equal(length(result), 35)
+  expect_equal(length(result), 34)
 })
 
 test_that("get_DM works upstream of diversion", {
   result <- get_DM(pt_data, 11689280)
   expect_true(!11689758 %in% result)
   expect_true(11689286 %in% result)
-  expect_equal(length(result), 29)
+  # expect_equal(length(result), 29)
+  expect_equal(length(result), 28)
 })
 
 test_that("get_DM with distance 0 returns 1 comid", {
@@ -35,8 +39,10 @@ test_that("get_DM with distance 0 returns 1 comid", {
 test_that("get_DM with distance 2 returns specific COMIDs", {
   result <- get_DM(pt_data,
                    11688810, distance = 2)
-  expect_equal(length(result), 3)
-  expect_true(all(c(11688810, 11688826, 11688884) %in% result))
+  # expect_equal(length(result), 3)
+  # expect_true(all(c(11688810, 11688826, 11688884) %in% result))
+  expect_equal(length(result), 2)
+  expect_true(all(c(11688826, 11688884) %in% result))
 })
 
 test_that("get_DM with distance big returns specific same as no distance", {
@@ -50,19 +56,22 @@ test_that("get_DM works upstream of diversion", {
   result <- get_DM(pt_data, 11689280)
   expect_true(!11689758 %in% result)
   expect_true(11689286 %in% result)
-  expect_equal(length(result), 29)
+  # expect_equal(length(result), 29)
+  expect_equal(length(result), 28)
 })
 
 context("get_UM")
 
 test_that("get_UM works short", {
   result <- get_UM(pt_data, 11689050)
-  expect_equal(length(result), 18)
+  # expect_equal(length(result), 18)
+  expect_equal(length(result), 17)
 })
 
 test_that("get_UM works long", {
   result <- get_UM(pt_data, 11690570)
-  expect_equal(length(result), 80)
+  # expect_equal(length(result), 80)
+  expect_equal(length(result), 79)
 })
 
 test_that("get_UM returns 1 for distance 0", {
@@ -74,7 +83,8 @@ test_that("get_UM returns 1 for distance 0", {
 test_that("get_UM returns a certain length for given distance", {
   result <- get_UM(pt_data,
                    11690570, distance = 10)
-  expect_equal(length(result), 12)
+  # expect_equal(length(result), 12)
+  expect_equal(length(result), 11)
 })
 
 context("get_UT")
@@ -145,6 +155,7 @@ test_that("get_DD with distance 2 returns 4 specific", {
 test_that("get_DM works if missing the outlet", {
   pt_data_borkd <- dplyr::filter(pt_data, TerminalFl == 0)
   result <- get_DM(pt_data_borkd, 11688810)
-  expect_equal(length(result), 34)
+  # expect_equal(length(result), 34)
+  expect_equal(length(result), 33)
 
 })
diff --git a/tests/testthat/test_subset.R b/tests/testthat/test_subset.R
@@ -52,7 +52,8 @@ test_that("subset runs as expected", {
   expect_equal(length(messages), 15)
 
   check_layers <- function() {
-    expect_equal(nrow(sf::read_sf(out_file, "CatchmentSP")), 4)
+    # expect_equal(nrow(sf::read_sf(out_file, "CatchmentSP")), 4)
+    expect_equal(nrow(sf::read_sf(out_file, "CatchmentSP")), 3)
     expect_equal(nrow(sf::read_sf(out_file, "NHDWaterbody")), 1)
   }