Commit 44dd4da2 authored by David Watkins's avatar David Watkins
Browse files

bbox working from retrieveFeatureOfInterest

parent 169da10c
...@@ -14,6 +14,7 @@ export(importWaterML1) ...@@ -14,6 +14,7 @@ export(importWaterML1)
export(importWaterML2) export(importWaterML2)
export(pCodeToName) export(pCodeToName)
export(parameterCdFile) export(parameterCdFile)
export(readNGWMNdata)
export(readNGWMNlevels) export(readNGWMNlevels)
export(readNGWMNsites) export(readNGWMNsites)
export(readNWISdata) export(readNWISdata)
...@@ -31,6 +32,7 @@ export(readNWISuv) ...@@ -31,6 +32,7 @@ export(readNWISuv)
export(readWQPdata) export(readWQPdata)
export(readWQPqw) export(readWQPqw)
export(renameNWISColumns) export(renameNWISColumns)
export(retrieveFeatureOfInterest)
export(setAccess) export(setAccess)
export(stateCd) export(stateCd)
export(stateCdLookup) export(stateCdLookup)
...@@ -43,6 +45,7 @@ import(stats) ...@@ -43,6 +45,7 @@ import(stats)
import(utils) import(utils)
importFrom(curl,curl_version) importFrom(curl,curl_version)
importFrom(dplyr,arrange) importFrom(dplyr,arrange)
importFrom(dplyr,bind_cols)
importFrom(dplyr,bind_rows) importFrom(dplyr,bind_rows)
importFrom(dplyr,full_join) importFrom(dplyr,full_join)
importFrom(dplyr,left_join) importFrom(dplyr,left_join)
...@@ -75,6 +78,7 @@ importFrom(xml2,xml_attr) ...@@ -75,6 +78,7 @@ importFrom(xml2,xml_attr)
importFrom(xml2,xml_attrs) importFrom(xml2,xml_attrs)
importFrom(xml2,xml_children) importFrom(xml2,xml_children)
importFrom(xml2,xml_find_all) importFrom(xml2,xml_find_all)
importFrom(xml2,xml_find_first)
importFrom(xml2,xml_name) importFrom(xml2,xml_name)
importFrom(xml2,xml_root) importFrom(xml2,xml_root)
importFrom(xml2,xml_text) importFrom(xml2,xml_text)
...@@ -15,6 +15,7 @@ ...@@ -15,6 +15,7 @@
#' @importFrom xml2 xml_find_all #' @importFrom xml2 xml_find_all
#' @importFrom xml2 xml_text #' @importFrom xml2 xml_text
#' @importFrom xml2 xml_attr #' @importFrom xml2 xml_attr
#' @importFrom xml2 xml_find_first
#' @importFrom lubridate parse_date_time #' @importFrom lubridate parse_date_time
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
...@@ -120,23 +121,30 @@ importNGWMN_wml2 <- function(input, asDateTime=FALSE, tz=""){ ...@@ -120,23 +121,30 @@ importNGWMN_wml2 <- function(input, asDateTime=FALSE, tz=""){
mergedDF[nonDateCols][mergedDF[nonDateCols] == "" | mergedDF[nonDateCols]== -999999.0] <- NA mergedDF[nonDateCols][mergedDF[nonDateCols] == "" | mergedDF[nonDateCols]== -999999.0] <- NA
attr(mergedDF, "gml:identifier") <- xml_text(xml_find_all(returnedDoc, ".//gml:identifier")) attr(mergedDF, "gml:identifier") <- xml_text(xml_find_all(returnedDoc, ".//gml:identifier"))
attr(mergedDF, "generationDate") <- xml_text(xml_find_all(returnedDoc, ".//wml2:generationDate")) attr(mergedDF, "generationDate") <- xml_text(xml_find_all(returnedDoc, ".//wml2:generationDate"))
meta <- xml_find_all(returnedDoc, ".//gmd:contact")
attr(mergedDF, "contact") <- xml_attr(meta, "href")
attr(mergedDF, "responsibleParty") <- xml_text(xml_find_all(meta, ".//gco:CharacterString"))
}else if(response == "GetFeatureOfInterestResponse"){ }else if(response == "GetFeatureOfInterestResponse"){
site <- xml_text(xml_find_all(returnedDoc,".//gml:identifier")) featureMembers <- xml_find_all(returnedDoc, ".//sos:featureMember")
site <- xml_text(xml_find_all(featureMembers,".//gml:identifier"))
site <- substring(site, 8) site <- substring(site, 8)
#bandaid to work with only single site calls
#TODO: need better solution when bbox is added #TODO: need better solution when bbox is added
#use number of children of right parent node? ie like xmlSize in XML #some sites don't have a description
#and loop? siteDesc <- xml_text(xml_find_first(featureMembers, ".//gml:description"))
siteDesc <- xml_text(xml_find_all(returnedDoc, ".//gml:description")) #siteDesc <- xml_text(xml_find_all(returnedDoc, ".//gml:description"))
if(length(siteDesc) == 0){ # if(length(siteDesc) == 0){
siteDesc <- NA # siteDesc <- NA
} # }
siteLocs <- strsplit(xml_text(xml_find_all(returnedDoc, ".//gml:pos")), " ") siteLocs <- strsplit(xml_text(xml_find_all(featureMembers, ".//gml:pos")), " ")
siteLocs <- data.frame(dec_lat_va=as.numeric(siteLocs[[1]][1]), dec_lon_va=as.numeric(siteLocs[[1]][2]), stringsAsFactors = FALSE) #TODO: deal with multiple sites
siteLocs <- data.frame(matrix(unlist(siteLocs), nrow=length(siteLocs), byrow=TRUE), stringsAsFactors = FALSE)
names(siteLocs) <- c("dec_lat_va", "dec_lon_va")
siteLocs <- mutate(siteLocs, dec_lat_va=as.numeric(dec_lat_va), dec_lon_va=as.numeric(dec_lon_va))
#siteLocs <- data.frame(dec_lat_va=as.numeric(siteLocs[[1]][1]), dec_lon_va=as.numeric(siteLocs[[1]][2]), stringsAsFactors = FALSE)
mergedDF <- cbind.data.frame(site, description = siteDesc, siteLocs, stringsAsFactors = FALSE) mergedDF <- cbind.data.frame(site, description = siteDesc, siteLocs, stringsAsFactors = FALSE)
} }
else{ else{
......
...@@ -14,7 +14,8 @@ ...@@ -14,7 +14,8 @@
#' @import utils #' @import utils
#' @importFrom dplyr mutate #' @importFrom dplyr mutate
#' @importFrom dplyr bind_rows #' @importFrom dplyr bind_rows
#' #' @importFrom dplyr bind_cols
#' @export
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
#' #one site #' #one site
...@@ -35,48 +36,56 @@ ...@@ -35,48 +36,56 @@
#' } #' }
#' #'
readNGWMNdata <- function(featureID, service = "observation", asDateTime = TRUE, tz = ""){ readNGWMNdata <- function(..., service = "observation", asDateTime = TRUE, tz = ""){
message(" ******************************************************** message(" ********************************************************
DISCLAIMER: NGWMN retrieval functions are still in flux, DISCLAIMER: NGWMN retrieval functions are still in flux,
and no future behavior or output is guaranteed and no future behavior or output is guaranteed
*********************************************************") *********************************************************")
#TODO: add getCapabilities
match.arg(service, c("observation", "featureOfInterest")) match.arg(service, c("observation", "featureOfInterest"))
dots <- list(...)
if(service == "observation"){ if(service == "observation"){
allObs <- NULL allObs <- NULL
allAttrs <- NULL allAttrs <- NULL
allSites <- NULL allSites <- NULL
#these attributes are pulled out and saved when doing binds to be reattached #these attributes are pulled out and saved when doing binds to be reattached
attrs <- c("url","gml:identifier","generationDate") attrs <- c("url","gml:identifier","generationDate","responsibleParty", "contact")
for(f in featureID){ for(f in featureID){
obsFID <- retrieveObservation(f, asDateTime, attrs) obsFID <- retrieveObservation(f, asDateTime, attrs)
siteFID <- retrieveFeatureOfInterest(f, asDateTime) siteFID <- retrieveFeatureOfInterest(f, asDateTime)
if(is.null(allObs)){ if(is.null(allObs)){
allObs <- obsFID allObs <- obsFID
allSites <- siteFID
allAttrs <- saveAttrs(attrs, allObs) allAttrs <- saveAttrs(attrs, allObs)
allSites <- bind_cols(siteFID,allAttrs)
}else{ }else{
obsFIDatt <- saveAttrs(attrs, obsFID) obsFIDatt <- saveAttrs(attrs, obsFID)
obsFID <- removeAttrs(attrs, obsFID) obsFID <- removeAttrs(attrs, obsFID)
allAttrs <- bind_rows(allAttrs, obsFIDatt)
allObs <- bind_rows(allObs, obsFID) allObs <- bind_rows(allObs, obsFID)
allSites <- bind_rows(allSites, siteFID) obsSites <- bind_cols(siteFID, obsFIDatt)
allSites <- bind_rows(allSites, obsSites)
} }
attributes(allObs) <- c(attributes(allObs),as.list(allAttrs))
attr(allObs, "siteInfo") <- allSites attr(allObs, "siteInfo") <- allSites
returnData <- allObs returnData <- allObs
} }
}else if(service == "featureOfInterest"){ }else if(service == "featureOfInterest"){
allSites <- NULL allSites <- NULL
for(f in featureID){ if(exists("featureID")){
siteFID <- retrieveFeatureOfInterest(f, asDateTime) #TODO: can do multi site calls with encoded comma
if(is.null(allSites)){ for(f in featureID){
allSites <- siteFID siteFID <- retrieveFeatureOfInterest(f, asDateTime)
if(is.null(allSites)){
allSites <- siteFID
}else{ }else{
allSites <- bind_rows(allSites, siteFID) allSites <- bind_rows(allSites, siteFID)
}
} }
} }
if(exists("bbox")){
}
returnData <- allSites returnData <- allSites
}else{ }else{
stop("unrecognized service request") stop("unrecognized service request")
...@@ -178,12 +187,27 @@ retrieveObservation <- function(featureID, asDateTime, attrs){ ...@@ -178,12 +187,27 @@ retrieveObservation <- function(featureID, asDateTime, attrs){
return(returnData) return(returnData)
} }
#retrieve feature of interest #' retrieve feature of interest
#don't expose until can support bbox #'
#note: import function can only do single sites right now #' @export
retrieveFeatureOfInterest <- function(featureID, asDateTime){ #TODO: accomodate bbox
baseURL <- "http://cida.usgs.gov/ngwmn_cache/sos?request=GetFeatureOfInterest&service=SOS&version=2.0.0&observedProperty=urn:ogc:def:property:OGC:GroundWaterLevel&responseFormat=text/xml&featureOfInterest=VW_GWDP_GEOSERVER." #TODO: can do multisite calls
url <- paste0(baseURL, featureID) retrieveFeatureOfInterest <- function(..., asDateTime, srsName="urn:ogc:def:crs:EPSG::4269"){
baseURL <- "http://cida.usgs.gov/ngwmn_cache/sos?request=GetFeatureOfInterest&service=SOS&version=2.0.0"
dots <- list(...)
values <- convertDots(dots)
if("featureID" %in% names(values)){
foiURL <- "&featureOfInterest="
#paste on VW_GWDP.. to all foi
url <- paste0(baseURL, featureID)
}else if("bbox" %in% names(values)){
bbox <- paste(values[['bbox']], collapse=",")
url <- paste0(baseURL, "&bbox=", bbox, "&srsName=",srsName)
}else{
stop()
}
siteDF <- importNGWMN_wml2(url, asDateTime) siteDF <- importNGWMN_wml2(url, asDateTime)
return(siteDF) return(siteDF)
} }
......
...@@ -118,7 +118,7 @@ readNWISdata <- function(service="dv", ..., asDateTime=TRUE,convertType=TRUE){ ...@@ -118,7 +118,7 @@ readNWISdata <- function(service="dv", ..., asDateTime=TRUE,convertType=TRUE){
stop("Only one service call allowed.") stop("Only one service call allowed.")
} }
values <- sapply(matchReturn, function(x) as.character(paste(eval(x),collapse=",",sep=""))) values <- convertDots(matchReturn)
names(values)[names(values) == "startDate"] <- "startDT" names(values)[names(values) == "startDate"] <- "startDT"
names(values)[names(values) == "endDate"] <- "endDT" names(values)[names(values) == "endDate"] <- "endDT"
...@@ -323,5 +323,11 @@ countyCdLookup <- function(state, county, outputType = "id"){ ...@@ -323,5 +323,11 @@ countyCdLookup <- function(state, county, outputType = "id"){
fullEntry = countyCd[county,] fullEntry = countyCd[county,]
) )
return(retVal)
}
# convert variables in dots to usable format
convertDots <- function(matchReturn){
retVal <- sapply(matchReturn, function(x) as.character(paste(eval(x),collapse=",",sep="")))
return(retVal) return(retVal)
} }
\ No newline at end of file
...@@ -4,13 +4,9 @@ ...@@ -4,13 +4,9 @@
\alias{readNGWMNdata} \alias{readNGWMNdata}
\title{import data from the National Groundwater Monitoring Network \url{http://cida.usgs.gov/ngwmn/}.} \title{import data from the National Groundwater Monitoring Network \url{http://cida.usgs.gov/ngwmn/}.}
\usage{ \usage{
readNGWMNdata(featureID, service = "observation", asDateTime = TRUE, readNGWMNdata(..., service = "observation", asDateTime = TRUE, tz = "")
tz = "")
} }
\arguments{ \arguments{
\item{featureID}{character Vector of feature IDs in the formatted with agency code and site number
separated by a period, e.g. \code{USGS.404159100494601}.}
\item{service}{character Identifies which web service to access. Only \code{observation} is currently \item{service}{character Identifies which web service to access. Only \code{observation} is currently
supported, which retrieves all water level for each site.} supported, which retrieves all water level for each site.}
...@@ -21,6 +17,9 @@ supported, which retrieves all water level for each site.} ...@@ -21,6 +17,9 @@ supported, which retrieves all water level for each site.}
datetimes to UTC (properly accounting for daylight savings times based on the data's provided time zone offset). datetimes to UTC (properly accounting for daylight savings times based on the data's provided time zone offset).
Possible values to provide are "America/New_York","America/Chicago", "America/Denver","America/Los_Angeles", Possible values to provide are "America/New_York","America/Chicago", "America/Denver","America/Los_Angeles",
"America/Anchorage","America/Honolulu","America/Jamaica","America/Managua","America/Phoenix", and "America/Metlakatla"} "America/Anchorage","America/Honolulu","America/Jamaica","America/Managua","America/Phoenix", and "America/Metlakatla"}
\item{featureID}{character Vector of feature IDs in the formatted with agency code and site number
separated by a period, e.g. \code{USGS.404159100494601}.}
} }
\description{ \description{
Only water level data is currently available through the web service. Only water level data is currently available through the web service.
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment