R/load.R

Defines functions nhd_plus_load_vpu nhd_plus_load nhd_load

Documented in nhd_load nhd_plus_load

#' Load NHD layers into current session
#'
#' @param state character state abbreviation
#' @param dsn character name of a NHD layer
#' @param file_ext character choice of "shp" for spatial data and
#' "dbf" or "gpkg" for non-spatial. optional
#' @param approve_all_dl logical blanket approval to download all missing data. Defaults to TRUE if session is non-interactive.
#' @param ... arguments passed to sf::st_read
#'
#' @return Spatial simple features object or data frame depending on the dsn
#' type and value passed to file_ext
#' @importFrom sf st_read gdal_utils
#' @importFrom rlang quo
#' @importFrom dplyr tbl select src_sqlite
#' @export
#'
#' @details This function will ask the user to approve downloading missing data
#'  unless approve_all_dl is set to TRUE.
#'
#' @examples \dontrun{
#' dt <- nhd_load(c("RI"), c("NHDWaterbody"))
#' dt <- nhd_load(c("CT", "RI"), "NHDWaterbody")
#' dt <- nhd_load(c("CT", "RI"), "NHDWaterbody", quiet = TRUE)
#' dt <- nhd_load("MI", "NHDFlowline")
#' dt <- nhd_load("RI", "NHDReachCrossReference")
#' dt <- nhd_load("RI", "NHDWaterbody", file_ext = "dbf")
#' dt <- nhd_load(c("RI", "DC"), "NHDWaterbody", file_ext = "gpkg")
#' }
nhd_load <- function(state, dsn, file_ext = NA, approve_all_dl = FALSE, ...){

  if(!interactive()){
    approve_all_dl = TRUE
  }

  if(!(file_ext %in% c(NA, "shp", "dbf", "gpkg"))){
    stop(paste0("file_ext must be set to either 'shp' or 'dbf'"))
  }

  nhd_state_exists <- function(state){
    if(any(!file.exists(gdb_path(state)))){
      state_exists <- 0
      if(!approve_all_dl){
        userconsents <- utils::menu(c("Yes", "No"),
                          title = paste0(state,
                          " state gdb file not found. Download it?"))
      }else{
        userconsents <- 1
      }
      if(userconsents == 1){
        yes_dl <- 1
      }else{
        yes_dl <- 0
      }
    }else{
      state_exists <- 1
      yes_dl <- 0
    }
    data.frame(state_exists = state_exists, yes_dl = yes_dl)
  }

  nhd_dl_state <- function(state, state_exists, yes_dl, file_ext, ...){

      if(as.logical(yes_dl)){
        nhd_get(state = state)
      }
      if(as.logical(state_exists) | as.logical(yes_dl)){

        if(is.na(file_ext) | file_ext == "shp"){
          tryCatch({
            suppressWarnings(sf::st_zm(
              sf::st_read(gdb_path(state), dsn,
                          stringsAsFactors = FALSE, ...)
              ))},
          error = function(e) {
            nhd_read_dbf(state, dsn)
          })
        }else{
          if(file_ext == "gpkg"){
            if(!is_gpkg_installed()){
              stop("The geopackage driver is not installed.")
            }
            suppressWarnings(st_read_custom(gdb_path(state), layer = dsn))
          }else{
            nhd_read_dbf(state, dsn)
          }
        }
      }
  }

  first_state_exists <- nhd_state_exists(state[1])

  if(length(state) > 1){
    yes_dl_vec <- rbind(first_state_exists,
          do.call("rbind", lapply(state[2:length(state)],
              nhd_state_exists)))
  }else{
    yes_dl_vec <- first_state_exists
  }

  res <- lapply(seq_len(nrow(yes_dl_vec)),
                function(i) nhd_dl_state(state = state[i],
                                yes_dl = yes_dl_vec[i, "yes_dl"],
                                state_exists = yes_dl_vec[i, "state_exists"],
                                file_ext = file_ext,
                                ...))

  res <- res[!unlist(lapply(res, is.null))]
  res <- do.call("rbind", res)

  if(!all(class(res) != "data.frame") & any(class(res) == "sf")){
    invisible(prj <- sf::st_crs(nhd_dl_state(state = state[1],
                        state_exists = first_state_exists[,"state_exists"],
                        yes_dl = first_state_exists[,"yes_dl"],
                        quiet = TRUE, file_ext = NA)))
    sf::st_crs(res) <- prj
  }
  res
}

#' Load NHDplus layers into current session
#'
#' @param vpu numeric vector processing unit
#' @param component character component name
#' @param dsn data source name
#' @param file_ext character choice of "shp" for spatial data and
#' "dbf" for non-spatial. optional
#' @param approve_all_dl logical blanket approval to download all missing data. Defaults to TRUE if session is non-interactive
#' @param force_dl logical force a re-download of the requested data
#' @param pretty more minimal pretty printing st_read relative to "quiet"
#' @param wkt_filter character. WKT spatial filter for selection. See sf::st_read
#' @param ... parameters passed on to sf::st_read
#' @return spatial object
#'
#' @importFrom sf st_read st_zm
#' @importFrom foreign read.dbf
#' @importFrom curl has_internet
#' @importFrom stringr str_extract
#' @importFrom memoise memoise cache_memory
#'
#' @export
#'
#' @details This function will ask the user to approve downloading missing data
#' unless approve_all_dl is set to TRUE. Output of this function is saved in
#' active memory (memoized) to speed up repeated function calls.
#'
#' @examples \dontrun{
#' # Spatial
#' dt <- nhd_plus_load(4, "NHDSnapshot", "NHDWaterbody")
#' dt <- nhd_plus_load(c(1,2), "NHDSnapshot", "NHDWaterbody")
#' dt <- nhd_plus_load(4, "NHDSnapshot", "NHDFlowline")
#' dt <- nhd_plus_load(4, "NHDPlusCatchment", "Catchment")
#'
#' # Quieter printing
#' dt <- nhd_plus_load(4, "NHDSnapshot", "NHDWaterbody", pretty = TRUE)
#' # Quietest printing
#' dt <- nhd_plus_load(4, "NHDSnapshot", "NHDWaterbody", quiet = TRUE)
#'
#' # Non-spatial
#' dt <- nhd_plus_load(1, "NHDPlusAttributes", "PlusFlow")
#' dt <- nhd_plus_load("National", "V1_To_V2_Crosswalk",
#'  "NHDPlusV1Network_V2Network_Crosswalk")
#' gridcode      <- nhd_plus_load(1, "NHDPlusCatchment", "featuregridcode")
#' flowline_vaa  <- nhd_plus_load(1, "NHDPlusAttributes", "PlusFlowlineVAA")
#' eromflow      <- nhd_plus_load(4, "EROMExtension", "EROM_010001")
#'
#' # Character VPU
#' plusflow <- nhd_plus_load(vpu = "10L", "NHDPlusAttributes", "PlusFlow")
#'
#' # Spatial filtering via wkt_filter
#' dt <- nhd_plus_load(4, "NHDSnapshot", "NHDWaterbody", wkt_filter = "POINT (-85.411 42.399)")
#'
#' }
nhd_plus_load <- function(vpu, component = "NHDSnapshot", dsn,
                          file_ext = NA, approve_all_dl = FALSE, force_dl = FALSE,
                          pretty = FALSE, wkt_filter = NA, ...){

  if(!interactive()){
    approve_all_dl = TRUE
  }

  if(!(file_ext %in% c(NA, "shp", "dbf"))){
    stop(paste0("file_ext must be set to either 'shp' or 'dbf'"))
  }

  res        <- lapply(vpu, nhd_plus_load_vpu,
                       component = component, dsn = dsn,
                       approve_all_dl = approve_all_dl, pretty = pretty,
                       wkt_filter = wkt_filter, ...)
  is_spatial <- unlist(lapply(res, function(x) x$is_spatial))
  # res        <- res[is_spatial]


  # resolve common names among vpus (https://github.com/jsta/nhdR/issues/57)
  names_template <- which.min(unlist(
    lapply(res, function(x) length(names(x$res)))))
  names_template <- names(res[[names_template]]$res)

  res <- lapply(res, function(x){
    names(x$res) <- align_names(names(x$res), names_template)
    x$res <- x$res[,names_template]
    x
    })

  if(nrow(res[[1]]$res) > 0){
    res        <- do.call("rbind", lapply(res, function(x) x$res))
  }else{
    res <- res[[1]]$res
  }

  if(any(is_spatial) & inherits(res, "data.frame")){
    invisible(
      prj <- sf::st_crs(
        nhd_plus_load_vpu(vpu[1],
                        component = component, dsn = dsn, pretty = FALSE,
                        quiet = TRUE, wkt_filter = wkt_filter,
                        query = paste0("SELECT * from ", dsn, " LIMIT 1"))$res
        )
      )
    sf::st_crs(res) <- prj
  }

  res
}

nhd_plus_load_vpu <- function(vpu, component, dsn, pretty, wkt_filter,
                              approve_all_dl = FALSE, force_dl = FALSE, file_ext = NA, ...){

  vpu_path <- list.files(file.path(nhd_path(), "NHDPlus"),
                         include.dirs = TRUE, full.names = TRUE)

  file_vpus <- sapply(
    stringr::str_extract(vpu_path, "_([0-9]{2}[A-z]{0,1})_"),
    function(x) substring(x, 2, nchar(x) - 1))

  vpu_path  <- vpu_path[!is.na(file_vpus)]
  file_vpus <- file_vpus[!is.na(file_vpus)]

  vpu_path <- vpu_path[file_vpus == zero_pad(vpu, 1)]

  vpu_path <- vpu_path[
    seq_len(length(vpu_path)) %in% grep("7z", vpu_path)]
  vpu_path <- vpu_path[grep(component, vpu_path)]

  if(any(!file.exists(vpu_path)) | length(vpu_path) == 0 | force_dl){

    if(!approve_all_dl & !force_dl){
      userconsents <- utils::menu(c("Yes", "No"),
                                  title = paste0(vpu, " vpu file not found. Download it?"))
    }else{
      userconsents <- 1
    }

    if(userconsents == 1){
      nhd_plus_get(vpu = vpu, component = component, force_dl = force_dl)
    }else{
      stop("No file. Cannot load.")
    }
  }

  candidate_files <- nhd_plus_list(vpu, component = component,
                                   full.names = TRUE, file_ext = file_ext)
  res <- candidate_files[grep(paste0(tolower(dsn), "\\."),
                              tolower(candidate_files))]
  if(length(res) == 0){
    stop(paste0("layer '", dsn, "' not found in component '",
                component, "'"))
  }

  if(length(grep(paste0("shp", "$"), res)) > 0){
    res <- res[grep("shp$", res)]
    res <- sf::st_zm(
      st_read_custom(res, pretty = pretty, stringsAsFactors = FALSE,
                     wkt_filter = wkt_filter, ...))
    is_spatial <- TRUE
    list(res = res, is_spatial = is_spatial)
  }else{
    res <- lapply(res, foreign::read.dbf, as.is = TRUE)
    names(res) <- dsn
    is_spatial <- FALSE
    list(res = res[[dsn]], is_spatial = is_spatial)
  }
}

Try the nhdR package in your browser

Any scripts or data that you put into this service are public.

nhdR documentation built on July 17, 2021, 5:06 p.m.