Commit 2061d22f authored by David Watkins's avatar David Watkins
Browse files

multi-site good to go?

parent dc4a18c2
...@@ -91,7 +91,23 @@ importNGMWN_wml2 <- function(input, asDateTime=FALSE, tz=""){ ...@@ -91,7 +91,23 @@ importNGMWN_wml2 <- function(input, asDateTime=FALSE, tz=""){
} }
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"))
}else if(response == "ExceptionReport"){
}else if(response == "GetFeatureOfInterestResponse"){
site <- xml_text(xml_find_all(returnedDoc,".//gml:identifier"))
site <- substring(site, 8)
#bandaid to work with only single site calls
#TODO: need better solution when bbox is added
siteDesc <- xml_text(xml_find_all(returnedDoc, ".//gml:description"))
if(length(siteDesc) == 0){
siteDesc <- NA
}
siteLocs <- strsplit(xml_text(xml_find_all(returnedDoc, ".//gml:pos")), " ")
siteLocs <- data.frame(lat=siteLocs[[1]][1], lon=siteLocs[[1]][2], stringsAsFactors = FALSE)
mergedDF <- cbind.data.frame(site, description = siteDesc, siteLocs, stringsAsFactors = FALSE)
}
else if(response == "ExceptionReport"){
#TODO: what happens if exception? #TODO: what happens if exception?
} }
return(mergedDF) return(mergedDF)
......
...@@ -16,13 +16,17 @@ readNGWMNdata <- function(featureID, request = "observation", asDateTime = TRUE) ...@@ -16,13 +16,17 @@ readNGWMNdata <- function(featureID, request = "observation", asDateTime = TRUE)
if(request == "observation"){ if(request == "observation"){
allObs <- NULL allObs <- NULL
allAttrs <- NULL allAttrs <- 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")
for(f in featureID){ for(f in featureID){
obsFID <- retrieveObservation(f, asDateTime, attrs) obsFID <- retrieveObservation(f, asDateTime, attrs)
siteFID <- retrieveFeatureOfInterest(f)
if(is.null(allObs)){ if(is.null(allObs)){
allObs <- obsFID allObs <- obsFID
allSites <- siteFID
}else{ }else{
#TODO: can attaching attributes wait till the end?
obsFIDatt <- saveAttrs(attrs, obsFID) obsFIDatt <- saveAttrs(attrs, obsFID)
allAttrs <- saveAttrs(attrs, allObs) allAttrs <- saveAttrs(attrs, allObs)
allObs <- removeAttrs(attrs, allObs) allObs <- removeAttrs(attrs, allObs)
...@@ -30,16 +34,17 @@ readNGWMNdata <- function(featureID, request = "observation", asDateTime = TRUE) ...@@ -30,16 +34,17 @@ readNGWMNdata <- function(featureID, request = "observation", asDateTime = TRUE)
allAttrs <- bind_rows(allAttrs, obsFIDatt) allAttrs <- bind_rows(allAttrs, obsFIDatt)
allObs <- bind_rows(allObs, obsFID) allObs <- bind_rows(allObs, obsFID)
attributes(allObs) <- c(attributes(allObs),as.list(allAttrs)) attributes(allObs) <- c(attributes(allObs),as.list(allAttrs))
allSites <- bind_rows(allSites, siteFID)
} }
attr(allObs, "siteInfo") <- allSites
returnData <- allObs returnData <- allObs
} }
} } #TODO: add direct feature of interest request
return(returnData) return(returnData)
} }
retrieveObservation <- function(featureID, asDateTime, attrs){ retrieveObservation <- function(featureID, asDateTime, attrs){
#allow for multiple site calls, and aggregate here?
#will need to contruct this more piece by piece if other versions, properties are added #will need to contruct this more piece by piece if other versions, properties are added
baseURL <- "http://cida.usgs.gov/ngwmn_cache/sos?request=GetObservation&service=SOS&version=2.0.0&observedProperty=urn:ogc:def:property:OGC:GroundWaterLevel&responseFormat=text/xml&featureOfInterest=VW_GWDP_GEOSERVER." baseURL <- "http://cida.usgs.gov/ngwmn_cache/sos?request=GetObservation&service=SOS&version=2.0.0&observedProperty=urn:ogc:def:property:OGC:GroundWaterLevel&responseFormat=text/xml&featureOfInterest=VW_GWDP_GEOSERVER."
url <- paste0(baseURL, featureID) url <- paste0(baseURL, featureID)
...@@ -51,7 +56,6 @@ retrieveObservation <- function(featureID, asDateTime, attrs){ ...@@ -51,7 +56,6 @@ retrieveObservation <- function(featureID, asDateTime, attrs){
attr(returnData, "generationDate") <- NA attr(returnData, "generationDate") <- NA
} }
#mutate removes the attributes, need to save and append #mutate removes the attributes, need to save and append
attribs <- saveAttrs(attrs, returnData) attribs <- saveAttrs(attrs, returnData)
if(nrow(returnData) > 0){ if(nrow(returnData) > 0){
...@@ -61,13 +65,30 @@ retrieveObservation <- function(featureID, asDateTime, attrs){ ...@@ -61,13 +65,30 @@ retrieveObservation <- function(featureID, asDateTime, attrs){
returnData <- returnData[,c(7,1:6)] #move siteNum to the left returnData <- returnData[,c(7,1:6)] #move siteNum to the left
} }
attributes(returnData) <- c(attributes(returnData), as.list(attribs)) attributes(returnData) <- c(attributes(returnData), as.list(attribs))
return(returnData) return(returnData)
} }
#retrieve feature of interest
#don't expose until can support bbox
#note: import function can only do single sites right now
retrieveFeatureOfInterest <- function(featureID){
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."
url <- paste0(baseURL, featureID)
siteDF <- importNGMWN_wml2(url, asDateTime)
return(siteDF)
}
#save specified attributes from a data frame #save specified attributes from a data frame
saveAttrs <- function(attrs, df){ saveAttrs <- function(attrs, df){
attribs <- sapply(attrs, function(x) attr(df, x)) attribs <- sapply(attrs, function(x) attr(df, x))
return(as.data.frame(t(attribs), stringsAsFactors = FALSE)) if(is.vector(attribs)){
toReturn <- as.data.frame(t(attribs), stringsAsFactors = FALSE)
}else{ #don't need to transpose
toReturn <- as.data.frame(attribs, stringsAsFactors = FALSE)
}
return(toReturn)
} }
#strip specified attributes from a data frame #strip specified attributes from a data frame
......
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