Merge branch 'main' of https://github.com/lynker-spatial/hfsubsetR

R/find_origin.R

@@ -0,0 +1,143 @@
+#' @keywords internal
+.makeOriginQueryClass <- function(data, cls) {
+  if (is.null(data)) {
+    return(NULL)
+  }
+
+  structure(data, class = c(cls, class(data)))
+}
+
+#' Find Origin From ID
+#' @param network a URI to a network-formatted Arrow dataset
+#' @inheritParams get_subset
+#' @return data.frame
+#' @export
+findOrigin <- function(
+  network,
+  id = NULL,
+  comid = NULL,
+  hl_uri = NULL,
+  poi_id = NULL,
+  nldi_feature = NULL,
+  xy = NULL
+) {
+  # Capture arguments
+  .args <- c(as.list(environment()))
+
+  # Pop `network` off arguments
+  .args <- .args[seq.int(2, length(.args), 1)]
+
+  # Get all non-NULL arguments
+  .args <- .args[!vapply(.args, is.null, logical(1))]
+
+  if (length(.args) == 0) {
+    stop("at least one argument other than `network` is required.")
+  }
+
+  if (length(.args) > 1) {
+    stop(paste(
+      "only one identifier type should be passed, but received",
+      paste0("`", names(.args), "`", collapse = "/")
+    ))
+  }
+
+  .query <- .makeOriginQueryClass(
+    .args[[1]],
+    ifelse(names(.args) == "id", "hf_id", names(.args))
+  )
+
+  origin <-
+    findOriginQuery(.query, network) |>
+    dplyr::select(id, vpuid, topo) |>
+    dplyr::distinct() |>
+    dplyr::collect()
+
+  if (nrow(origin) == 0) {
+    stop("No origin found")
+  } else if (nrow(origin) > 1) {
+    stop("Multiple origins found: ", dput(origin$id))
+  } else {
+    return(origin)
+  }
+}
+
+
+#' S3 method for dispatching on query type
+#' @return Arrow Table/Deferred connection
+#' @keywords internal
+findOriginQuery <- function(id, network, ...) {
+  if (!inherits(network, "character")) {
+    stop("`network` must be a path/URI")
+  }
+
+  UseMethod("findOriginQuery")
+}
+
+
+#' @method findOriginQuery default
+#' @keywords internal
+findOriginQuery.default <- function(id, network, ...) {
+  stop(paste(
+    "identifier of class",
+    paste0("`", class(id), "`", collapse = "/"),
+    "not supported"
+  ))
+}
+
+
+#' @method findOriginQuery hf_id
+#' @keywords internal
+findOriginQuery.hf_id <- function(id, network, ...) {
+  arrow::open_dataset(network) |>
+    dplyr::filter(id == !!id)
+}
+
+
+#' @method findOriginQuery comid
+#' @keywords internal
+findOriginQuery.comid <- function(comid, network, ...) {
+  arrow::open_dataset(network) |>
+    dplyr::filter(hf_id == !!comid)
+}
+
+
+#' @method findOriginQuery hl_uri
+#' @keywords internal
+findOriginQuery.hl_uri <- function(hl_uri, network, ...) {
+  arrow::open_dataset(network) |>
+    dplyr::filter(hl_uri == !!hl_uri)
+}
+
+
+#' @method findOriginQuery poi_id
+#' @keywords internal
+findOriginQuery.poi_id <- function(poi_id, network, ...) {
+  arrow::open_dataset(network) |>
+    dplyr::filter(poi_id == !!poi_id)
+}
+
+
+#' @method findOriginQuery nldi_feature
+#' @keywords internal
+findOriginQuery.nldi_feature <- function(nldi_feature, network, ...) {
+  .Class <- "comid"
+  nldi_feature <-
+    nhdplusTools::discover_nhdplus_id(nldi_feature = nldi_feature) |>
+    .makeOriginQueryClass("comid")
+
+  NextMethod()
+}
+
+
+#' @method findOriginQuery xy
+#' @keywords internal
+findOriginQuery.xy <- function(xy, network, ...) {
+  .Class <- "comid"
+  xy <-
+    sf::st_point(xy) |>
+    sf::st_sfc(crs = 4326) |>
+    nhdplusTools::discover_nhdplus_id(point = _) |>
+    .makeOriginQueryClass("comid")
+
+  NextMethod()
+}

R/get_subset.R

@@ -2,7 +2,7 @@ na.omit = function(x){ x[!is.na(x)] }
 
 #' Extract Data from Arrow Stores
 #' @inheritParams get_subset
-#' @param hook a local or s3 hydrofabric direc
+#' @param hook a local or s3 hydrofabric directory
 #' @return list or file path
 #' @export
 
@@ -45,64 +45,6 @@ extract_data = function(hook, vpu, ids, lyrs, outfile = NULL){
   }
 }
 
-#' Find Origin from ID
-#' @param network 
-#' @inheritParams get_subset
-#' @return data.frame
-#' @export
-
-findOrigin = function(network, 
-                      id = NULL, 
-                      comid = NULL,  
-                      hl_uri = NULL, 
-                      poi_id = NULL, 
-                      nldi_feature = NULL, 
-                      xy = NULL) {
-
-  if(!is.null(xy)) {
-    xy[1:2] <- as.numeric(xy[1:2])
-    comid   <- discover_nhdplus_id(point = st_sfc(st_point(c(xy[1], xy[2])), crs = 4326))
-  }
-
-  # nldi_feature = list(featureSource = "nwissite", featureID = "USGS-08279500")
-  if (!is.null(nldi_feature)) {
-    comid <- discover_nhdplus_id(nldi_feature = nldi_feature)
-  }
-
-  con = open_dataset(network)
-  #poi_id = 74719
-  if (!is.null(poi_id)) {
-    obj <- filter(con, poi_id == !!poi_id)
-  }
-
-  #hl_uri = 'WBIn-120049871'
-  if (!is.null(hl_uri)) {
-    obj <- filter(con, hl_uri == !!hl_uri) 
-  }
-
-  #comid = 101
-  if (!is.null(comid)) {
-    obj <- filter(con, hf_id == comid) 
-  }
-
-  if (!is.null(id)) {
-    obj <- filter(con, id == !!id)
-  }
-
-  origin = select(obj, id, vpuid, topo) %>%
-    distinct() %>% 
-    collect()
-
-  if (nrow(origin) == 0) {
-    stop("No origin found")
-  } else if (nrow(origin) > 1) {
-    print(origin)
-    stop("Multiple Origins Found")
-  } else {
-    return(origin)
-  }
-}
-
 #' @title Build a hydrofabric subset
 #' @param id hydrofabric id. datatype: string / vector of strings e.g., 'wb-10026' or c('wb-10026', 'wb-10355') 
 #' @param comid NHDPlusV2 COMID. datatype: int / vector of int e.g., 61297116 or c(61297116 , 6129261) 

R/zzz.R

@@ -0,0 +1,9 @@
+.onLoad <- function(...) {
+  .S3method("findOriginQuery", "default")
+  .S3method("findOriginQuery", "hf_id")
+  .S3method("findOriginQuery", "comid")
+  .S3method("findOriginQuery", "hl_uri")
+  .S3method("findOriginQuery", "poi_id")
+  .S3method("findOriginQuery", "nldi_feature")
+  .S3method("findOriginQuery", "xy")
+}