Commit 7a1074f5 authored by Laura A DeCicco's avatar Laura A DeCicco
Browse files

Merge pull request #127 from ldecicco-USGS/master

WQP update.
parents 8858be58 83a80e85
Package: dataRetrieval
Type: Package
Title: Retrieval Functions for USGS and EPA Hydrologic and Water Quality Data
Version: 2.2.1
Date: 2015-04-22
Version: 2.2.2
Date: 2015-06-05
Authors@R: c( person("Robert", "Hirsch", role = c("aut"),
email = "rhirsch@usgs.gov"),
person("Laura", "DeCicco", role = c("aut","cre"),
......
......@@ -33,5 +33,6 @@ export(zeroPad)
import(RCurl)
import(XML)
import(lubridate)
import(reshape2)
importFrom(plyr,rbind.fill.matrix)
importFrom(reshape2,dcast)
importFrom(reshape2,melt)
......@@ -6,6 +6,7 @@
#' @param values named list with arguments to send to the Water Quality Portal
#' @return values named list with corrected arguments to send to the Water Quality Portal
#' @export
#' @keywords internal
#' @examples
#' values <- list(startDateLo="01-01-2002", characteristicName="Phosphorous",
#' endDate=as.Date("2014-01-01"))
......
......@@ -267,7 +267,7 @@ constructWQPURL <- function(siteNumber,parameterCd,startDate,endDate){
url <- paste0(url, "&startDateHi=",endDate)
}
url <- paste0(url,"&countrycode=US&mimeType=tsv")
url <- paste0(url,"&sorted=no&mimeType=tsv")
return(url)
}
......@@ -72,19 +72,15 @@ importWQP <- function(obs_url, zip=FALSE, tz=""){
if (!is.na(numToBeReturned) & numToBeReturned != 0){
suppressWarnings(namesData <- read.delim(if(zip) doc else textConnection(doc) , header = TRUE, quote="\"",
dec=".", sep='\t',
colClasses='character',
fill = TRUE,nrow=1))
suppressWarnings(namesData <- read.delim(if(zip) doc else textConnection(doc) , header = TRUE, quote="",
dec=".", sep='\t', colClasses='character',nrow=1))
classColumns <- setNames(rep('character',ncol(namesData)),names(namesData))
classColumns[grep("MeasureValue",names(classColumns))] <- NA
suppressWarnings(retval <- read.delim(if(zip) doc else textConnection(doc), header = TRUE, quote="\"",
dec=".", sep='\t',
colClasses=as.character(classColumns),
fill = TRUE))
suppressWarnings(retval <- read.delim(if(zip) doc else textConnection(doc), header = TRUE, quote="",
dec=".", sep='\t', colClasses=as.character(classColumns)))
actualNumReturned <- nrow(retval)
......@@ -142,6 +138,10 @@ importWQP <- function(obs_url, zip=FALSE, tz=""){
unlink(doc)
}
retval <- retval[order(retval$OrganizationIdentifier,
retval$MonitoringLocationIdentifier,
retval$ActivityStartDateTime, decreasing = FALSE),]
return(retval)
} else {
......
......@@ -40,7 +40,8 @@
#' @export
#' @import XML
#' @import RCurl
#' @import reshape2
#' @importFrom reshape2 melt
#' @importFrom reshape2 dcast
#' @examples
#' siteNumber <- "02177000"
#' startDate <- "2012-09-01"
......@@ -403,8 +404,11 @@ importWaterML1 <- function(obs_url,asDateTime=FALSE, tz=""){
qualColumns <- unique(qualColumns)
sortingColumns <- names(mergedDF)[!(names(mergedDF) %in% c(dataColumns,qualColumns))]
meltedmergedDF <- melt(mergedDF,id.vars=sortingColumns)
meltedmergedDF <- reshape2::melt(mergedDF, measure.vars = c(dataColumns,qualColumns),
variable.name = "variable", value.name = "value", na.rm = FALSE)
rownames(meltedmergedDF) <- NULL
# meltedmergedDF <- reshape2::melt(mergedDF,id.vars=sortingColumns)
meltedmergedDF <- meltedmergedDF[!is.na(meltedmergedDF$value),]
meltedmergedDF <- meltedmergedDF[!duplicated(meltedmergedDF),]
......@@ -416,7 +420,7 @@ importWaterML1 <- function(obs_url,asDateTime=FALSE, tz=""){
indexDups <- as.numeric(row.names(qualDups))
if(length(indexDups) > 0){
mergedDF2 <- dcast(meltedmergedDF[-indexDups,], castFormula, drop=FALSE, value.var = "value",)
mergedDF2 <- reshape2::dcast(meltedmergedDF[-indexDups,], castFormula, drop=FALSE, value.var = "value")
# Need to get value....
dupInfo <- meltedmergedDF[indexDups, sortingColumns]
......@@ -434,7 +438,7 @@ importWaterML1 <- function(obs_url,asDateTime=FALSE, tz=""){
dataColumns2 <- !(names(mergedDF2) %in% sortingColumns)
} else {
mergedDF2 <- dcast(meltedmergedDF, castFormula, drop=FALSE, value.var = "value")
mergedDF2 <- reshape2::dcast(meltedmergedDF, castFormula, drop=FALSE, value.var = "value")
dataColumns2 <- !(names(mergedDF2) %in% sortingColumns)
}
......
......@@ -71,7 +71,8 @@
#' variableInfo \tab data frame \tab A data frame containing information on the requested parameters \cr
#' }
#' @export
#' @import reshape2
#' @importFrom reshape2 melt
#' @importFrom reshape2 dcast
#' @seealso \code{\link{readWQPdata}}, \code{\link{whatWQPsites}},
#' \code{\link{readWQPqw}}, \code{\link{constructNWISURL}}
#' @examples
......@@ -139,18 +140,21 @@ readNWISqw <- function (siteNumbers,parameterCd,startDate="",endDate="",
"sample_end_dt","sample_end_tm","sample_start_time_datum_cd","tm_datum_rlbty_cd",
"parm_cd","startDateTime","endDateTime","coll_ent_cd", "medium_cd","project_cd",
"aqfr_cd","tu_id","body_part_id", "hyd_cond_cd", "samp_type_cd",
"hyd_event_cd","sample_lab_cm_tx")
columnsToMelt <- columnsToMelt[columnsToMelt %in% names(data)]
"hyd_event_cd","sample_lab_cm_tx","tz_cd","startDateTime","endDateTime")
measureCols <- names(data)[!(names(data) %in% columnsToMelt)]
columnsToMelt <- names(data)[(names(data) %in% columnsToMelt)]
dataWithPcodes <- data[data$parm_cd != "",]
if(sum(data$parm_cd == "") > 0){
warning("Some or all data returned without pCodes, those data will not be included in reshape")
}
longDF <- melt(dataWithPcodes, columnsToMelt)
wideDF <- dcast(longDF, ... ~ variable + parm_cd )
# longDF <- reshape2::melt(dataWithPcodes, measure.vars = columnsToMelt)
longDF <- reshape2::melt(dataWithPcodes, measure.vars = measureCols,
variable.name = "variable", value.name = "value", na.rm = FALSE)
wideDF <- reshape2::dcast(longDF, ... ~ variable + parm_cd )
wideDF[,grep("_va_",names(wideDF))] <- sapply(wideDF[,grep("_va_",names(wideDF))], function(x) as.numeric(x))
pCodesReturned <- unique(dataWithPcodes$parm_cd)
groupByPCode <- as.vector(sapply(pCodesReturned, function(x) grep(x, names(wideDF)) ))
data <- wideDF[,c(1:length(columnsToMelt)-1,groupByPCode)]
data <- wideDF[,c(1:length(columnsToMelt),groupByPCode)]
comment(data) <- originalHeader
} else {
warning("Reshape can only be used with expanded data. Reshape request will be ignored.")
......
......@@ -100,7 +100,7 @@ readWQPdata <- function(...){
matchReturn <- list(...)
values <- sapply(matchReturn, function(x) URLencode(as.character(paste(eval(x),collapse=";",sep=""))))
values <- sapply(matchReturn, function(x) as.character(paste(eval(x),collapse=";",sep="")))
if("bBox" %in% names(values)){
values['bBox'] <- gsub(pattern = ";", replacement = ",", x = values['bBox'])
......@@ -141,19 +141,15 @@ readWQPdata <- function(...){
} else {
tz <- ""
}
values <- gsub(",","%2C",values)
values <- gsub(";","%3B",values)
values <- gsub("%20","+",values)
values <- gsub(":","%3A",values)
urlCall <- paste(paste(names(values),values,sep="="),collapse="&")
baseURL <- "http://www.waterqualitydata.us/Result/search?"
urlCall <- paste0(baseURL,
urlCall,
"&mimeType=tsv")
"&sorted=no&mimeType=tsv")
retval <- importWQP(urlCall,FALSE, tz=tz)
......
......@@ -44,7 +44,7 @@ NULL
#'
#'@docType data
#'@export parameterCdFile
#'@keywords datasets
#'@keywords internal
#'@examples
#'head(parameterCdFile[,1:2])
NULL
......@@ -74,7 +74,7 @@ NULL
#' }
#' @docType data
#' @export pCodeToName
#' @keywords USGS parameterCd
#' @keywords internal
#' @examples
#' head(pCodeToName[,1:2])
NULL
......
......@@ -59,7 +59,7 @@ whatWQPsites <- function(...){
matchReturn <- list(...)
values <- sapply(matchReturn, function(x) URLencode(as.character(paste(eval(x),collapse=";",sep=""))))
values <- sapply(matchReturn, function(x) as.character(paste(eval(x),collapse=";",sep="")))
if("tz" %in% names(values)){
values <- values[!(names(values) %in% "tz")]
......@@ -79,11 +79,8 @@ whatWQPsites <- function(...){
}
names(values)[names(values) == "stateCd"] <- "statecode"
}
values <- gsub(",","%2C",values)
values <- gsub(";","%3B",values)
values <- gsub("%20","+",values)
values <- gsub(":","%3A",values)
if("bBox" %in% names(values)){
values['bBox'] <- gsub(pattern = ";", replacement = ",", x = values['bBox'])
......@@ -97,7 +94,7 @@ whatWQPsites <- function(...){
baseURL <- "http://www.waterqualitydata.us/Station/search?"
urlCall <- paste(baseURL,
urlCall,
"&mimeType=tsv",sep = "")
"&mimeType=tsv&sorted=no",sep = "")
doc <- getWebServiceData(urlCall)
headerInfo <- attr(doc, "headerInfo")
......
......@@ -21,4 +21,5 @@ values <- list(startDateLo="01-01-2002", characteristicName="Phosphorous",
endDate=as.Date("2014-01-01"))
values <- checkWQPdates(values)
}
\keyword{internal}
......@@ -30,6 +30,5 @@ Data pulled from Water Quality Portal on November 25, 2014. The data was pulled
\examples{
head(pCodeToName[,1:2])
}
\keyword{USGS}
\keyword{parameterCd}
\keyword{internal}
......@@ -25,5 +25,5 @@ format=rdb&show=parameter_group_nm&show=parameter_nm&show=casrn&show=srsname&sho
\examples{
head(parameterCdFile[,1:2])
}
\keyword{datasets}
\keyword{internal}
......@@ -32,17 +32,17 @@ test_that("General NWIS retrievals working", {
test_that("General WQP retrievals working", {
testthat::skip_on_cran()
# Bring back when WQP is back
# nameToUse <- "pH"
# pHData <- readWQPdata(siteid="USGS-04024315",characteristicName=nameToUse)
# expect_is(pHData$ActivityStartDateTime, 'POSIXct')
#
# pHDataExpanded2 <- readWQPdata(bBox=c(-90.10,42.67,-88.64,43.35),
# characteristicName=nameToUse)
# expect_is(pHDataExpanded2$ActivityStartDateTime, 'POSIXct')
#
# startDate <- as.Date("2013-01-01")
# nutrientDaneCounty <- readWQPdata(countycode="US:55:025",startDate=startDate,
# characteristicType="Nutrient")
# expect_is(nutrientDaneCounty$ActivityStartDateTime, 'POSIXct')
nameToUse <- "pH"
pHData <- readWQPdata(siteid="USGS-04024315",characteristicName=nameToUse)
expect_is(pHData$ActivityStartDateTime, 'POSIXct')
pHDataExpanded2 <- readWQPdata(bBox=c(-90.1,42.9,-89.9,43.1),
characteristicName=nameToUse)
expect_is(pHDataExpanded2$ActivityStartDateTime, 'POSIXct')
startDate <- as.Date("2013-01-01")
nutrientDaneCounty <- readWQPdata(countycode="US:55:025",startDate=startDate,
characteristicType="Nutrient")
expect_is(nutrientDaneCounty$ActivityStartDateTime, 'POSIXct')
expect_that(1==1, is_true())
})
......@@ -99,12 +99,12 @@ test_that("External importWaterML1 test", {
expect_is(unitData$dateTime, 'POSIXct')
# Two sites, two pcodes, one site has two data descriptors:
siteNumber <- c('01480015',"04085427")
# Two sites, two pcodes, one site has two data descriptors
siteNumber <- c('01480015',"04085427") #one site seems to have lost it's 2nd dd
obs_url <- constructNWISURL(siteNumber,c("00060","00010"),startDate,endDate,'dv')
data <- importWaterML1(obs_url)
expect_that(length(unique(data$site_no)) == 2, is_true())
expect_that(ncol(data) == 10, is_true()) # 3 data, 3 remark codes, and 4 (agency, site, dateTime, tz)
expect_that(ncol(data) == 8, is_true()) # 3 data, 3 remark codes, and 4 (agency, site, dateTime, tz)
inactiveSite <- "05212700"
inactiveSite <- constructNWISURL(inactiveSite, "00060", "2014-01-01", "2014-01-10",'dv')
......@@ -123,15 +123,15 @@ context("importWQP_noCRAN")
test_that("External WQP tests", {
testthat::skip_on_cran()
expect_that(1==1, is_true())
# rawSampleURL <- constructWQPURL('USGS-01594440','01075', '', '')
# rawSample <- importWQP(rawSampleURL)
# expect_is(rawSample$ActivityStartDateTime, 'POSIXct')
#
# url2 <- paste0(rawSampleURL,"&zip=yes")
# rawSample2 <- suppressWarnings(importWQP(url2, TRUE))
# expect_is(rawSample2$ActivityStartDateTime, 'POSIXct')
#
# STORETex <- constructWQPURL('WIDNR_WQX-10032762','Specific conductance', '', '')
# STORETdata <- importWQP(STORETex)
# expect_is(STORETdata$ActivityStartDateTime, 'POSIXct')
rawSampleURL <- constructWQPURL('USGS-01594440','01075', '', '')
rawSample <- importWQP(rawSampleURL)
expect_is(rawSample$ActivityStartDateTime, 'POSIXct')
url2 <- paste0(rawSampleURL,"&zip=yes")
rawSample2 <- suppressWarnings(importWQP(url2, TRUE))
expect_is(rawSample2$ActivityStartDateTime, 'POSIXct')
STORETex <- constructWQPURL('WIDNR_WQX-10032762','Specific conductance', '', '')
STORETdata <- importWQP(STORETex)
expect_is(STORETdata$ActivityStartDateTime, 'POSIXct')
})
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