Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#' Function to return data from the NWISWeb WaterML1.1 daily values service
#'
#' This function accepts a url parameter that already contains the desired
#' NWIS site, parameter code, statistic, startdate and enddate. It returns a
#' data frame containing "Date" and "Discharge"
#'
#' @param obs_url string containing the url for the retrieval
#' @return Daily a data frame containing columns 'Date' and 'Discharge'
#' @export
#' @examples
#' url <- "http://waterservices.usgs.gov/nwis/dv/?format=waterml,1.1&sites="
#' sites <- "02177000"
#' startDate <- "2012-09-01"
#' endDate <- "2012-10-01"
#' offering <- '00003'
#' property <- '00060'
#' obs_url <- constructNWISURL(sites,property,startDate,endDate,'dv')
#' data <- getWaterML1Data(obs_url)
#' urlMulti <- constructNWISURL("04085427",c("00060","00010"),startDate,endDate,'dv',statCd=c("00003","00001"))
#' multiData <- getWaterML1Data(urlMulti)
getWaterML1Data <- function(obs_url){
# This is more elegent, but requires yet another package dependency RCurl
# content <- getURLContent(obs_url,.opts=list(timeout.ms=500000))
# test <- capture.output(tryCatch(xmlTreeParse(content, getDTD=FALSE, useInternalNodes=TRUE),"XMLParserErrorList" = function(e) {cat("incomplete",e$message)}))
# while (length(grep("<?xml",test))==0) {
# content <- getURLContent(obs_url,.opts=list(timeout.ms=500000))
# test <- capture.output(tryCatch(xmlTreeParse(content, getDTD=FALSE, useInternalNodes=TRUE),"XMLParserErrorList" = function(e) {cat("incomplete",e$message)}))
# }
# doc <- htmlTreeParse(content, getDTD=TRUE, useInternalNodes=TRUE)
require(XML)
doc <- htmlParse(obs_url)
timeSeries <- getNodeSet(doc, "//timeseries")
for (i in 1:length(timeSeries)){
chunk <- xmlDoc(timeSeries[[i]])
chunk <- xmlRoot(chunk)
pCode <-as.character(xpathApply(chunk, "variable/variablecode", xmlValue))
statCd <- as.character(xpathApply(chunk, "variable/options/option/@optioncode"))
valuesIndex <- as.numeric(which("values" == names(chunk)))
for (j in valuesIndex){
subChunk <- xmlRoot(xmlDoc(chunk[[j]]))
methodID <- as.character(xpathSApply(subChunk, "method/@methodid"))
methodID <- padVariable(methodID,2)
value <- as.numeric(xpathSApply(subChunk, "value", xmlValue))
dateTime <- strptime(xpathSApply(subChunk, "value/@datetime"),"%Y-%m-%dT%H:%M:%S.000")
qualifier <- as.character(xpathSApply(subChunk, "value/@qualifiers"))
valueName <- paste(methodID,pCode,statCd,sep="_")
qualName <- paste(methodID,pCode,statCd,"cd",sep="_")
valueName <- paste("X",valueName,sep="")
qualName <- paste("X",qualName,sep="")
assign(valueName,value)
assign(qualName,qualifier)
df <- data.frame(dateTime,
get(valueName),
get(qualName)
)
names(df) <- c("dateTime",valueName,qualName)
if (1 == i & valuesIndex[1] == j){
mergedDF <- df
} else {
mergedDF <- merge(mergedDF, df,by="dateTime",all=TRUE)
}
}
}
agencyCd <- as.character(xpathSApply(timeSeries[[1]], "sourceinfo/sitecode/@agencycode"))
siteNo <- as.character(xpathSApply(timeSeries[[1]], "sourceinfo/sitecode", xmlValue))
mergedDF$agency <- rep(agencyCd, nrow(mergedDF))
mergedDF$site <- rep(siteNo, nrow(mergedDF))
reorder <- c(ncol(mergedDF)-1, ncol(mergedDF), 1:(ncol(mergedDF)-2))
mergedDF <- mergedDF[,reorder]
return (mergedDF)
}