From 421f80d858c78b517347b12d6133800911d911f2 Mon Sep 17 00:00:00 2001 From: program-- Date: Sun, 26 May 2024 13:13:54 -0700 Subject: [PATCH] refactor: separate findOrigin into S3 methods --- R/find_origin.R | 143 +++++++++++++++++++++++++++++++++++++++++ R/get_subset.R | 60 +---------------- R/zzz.R | 9 +++ man/findOrigin.Rd | 8 +-- man/findOriginQuery.Rd | 15 +++++ 5 files changed, 172 insertions(+), 63 deletions(-) create mode 100644 R/find_origin.R create mode 100644 R/zzz.R create mode 100644 man/findOriginQuery.Rd diff --git a/R/find_origin.R b/R/find_origin.R new file mode 100644 index 0000000..75392b7 --- /dev/null +++ b/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() +} diff --git a/R/get_subset.R b/R/get_subset.R index d5ca73d..78e2dd2 100644 --- a/R/get_subset.R +++ b/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 extract_data = function(hook, vpu, ids, lyrs, outfile = NULL){ @@ -44,64 +44,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) diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 0000000..fb24a5f --- /dev/null +++ b/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") +} diff --git a/man/findOrigin.Rd b/man/findOrigin.Rd index 92dd40b..95af879 100644 --- a/man/findOrigin.Rd +++ b/man/findOrigin.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_subset.R +% Please edit documentation in R/find_origin.R \name{findOrigin} \alias{findOrigin} -\title{Find Origin from ID} +\title{Find Origin From ID} \usage{ findOrigin( network, @@ -15,7 +15,7 @@ findOrigin( ) } \arguments{ -\item{network}{} +\item{network}{a URI to a network-formatted Arrow dataset} \item{id}{hydrofabric id. datatype: string / vector of strings e.g., 'wb-10026' or c('wb-10026', 'wb-10355')} @@ -33,5 +33,5 @@ findOrigin( data.frame } \description{ -Find Origin from ID +Find Origin From ID } diff --git a/man/findOriginQuery.Rd b/man/findOriginQuery.Rd new file mode 100644 index 0000000..02c2fd3 --- /dev/null +++ b/man/findOriginQuery.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/find_origin.R +\name{findOriginQuery} +\alias{findOriginQuery} +\title{S3 method for dispatching on query type} +\usage{ +findOriginQuery(id, network, ...) +} +\value{ +Arrow Table/Deferred connection +} +\description{ +S3 method for dispatching on query type +} +\keyword{internal}