[Rodbcext-commits] r38 - in pkg/geoclimate: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu May 23 10:20:34 CEST 2013
Author: jaunario
Date: 2013-05-23 10:20:33 +0200 (Thu, 23 May 2013)
New Revision: 38
Modified:
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/fetch.R
pkg/geoclimate/R/nasa.r
Log:
geoclimate.fetch allows multi-table retrieval of weather data based on xy coordinates.
get.nasa default variables now includes all available data variables on the NASA-POWER website.
Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2013-04-16 01:15:42 UTC (rev 37)
+++ pkg/geoclimate/DESCRIPTION 2013-05-23 08:20:33 UTC (rev 38)
@@ -1,7 +1,7 @@
Package: geoclimate
Type: Package
Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.14
+Version: 0.0.16
Date: 2009-2-24
Depends: methods, genutils, weather, RODBC
Suggests: RCurl, ncdf
Modified: pkg/geoclimate/R/fetch.R
===================================================================
--- pkg/geoclimate/R/fetch.R 2013-04-16 01:15:42 UTC (rev 37)
+++ pkg/geoclimate/R/fetch.R 2013-05-23 08:20:33 UTC (rev 38)
@@ -3,7 +3,7 @@
# Version 0.0.1
# Licence GPL v3
-.fetch <- function(cells, con, wset, stdate=as.Date("2012-1-1"), endate=as.Date("2012-12-31"), vars=NULL, ...){
+.fetch <- function(cells, con, wset, stdate=as.Date("1983-1-1"), endate=Sys.Date(), vars=NULL, ...){
#function(cells, con, wset, stdate=Sys.Date()-as.numeric(format(Sys.Date(),"%j"))+1, endate=Sys.Date(), vars=NULL, ...){
# Preventive measures for known MySQL-born issues (i.e cannot open table, disconnected RODBC object)
@@ -18,17 +18,17 @@
# parameter vars general checks and query component construction
if (length(vars)>1){
invalids <- which(is.na(vars))
- if (length(invalids)>0) stop ("Invalid vars specification detected.") else vars <- c("cell", "wdate", vars)
+ if (length(invalids)>0) stop ("Invalid vars specification detected.") else vars <- c("cell", "wdate AS date", vars)
} else if (length(vars)==0){
vars <- "*"
} else if ((length(vars)==1 & (is.na(vars) | tolower(vars)=="all" | vars=="*"))){
vars <- "*"
} else {
- vars <- c("cell", "wdate", vars)
+ vars <- c("cell", "wdate AS date", vars)
}
vars <- paste(vars, collapse=", ")
- query <- paste("SELECT", vars, "FROM", wset, "WHERE (wdate BETWEEN", shQuote(stdate), "AND", shQuote(endate),") AND (cell IN (",paste(cells, collapse=", ") ,")) ORDER BY cell, wdate")
+ query <- paste("SELECT", vars, "FROM", wset, "WHERE (wdate BETWEEN", shQuote(stdate), "AND", shQuote(endate),") AND (cell IN (",paste(cells, collapse=", ") ,")) ORDER BY cell, date")
data <- sqlQuery(con, query, ...)
@@ -68,21 +68,23 @@
tmp <- .fetch(cells=stdcells, con=connection, wset=paste(srcm$schema_name,srcm$table_name, sep=".") , vars=srcvars[[i]], ...)
#tmp <- fetch(cells=cells, con=connection, wset=paste(srcm$schema_name,srcm$table_name, sep=".") , vars=srcvars[[i]])
tmp$idx <- match(tmp$cell, stdcells)
- tmp <- tmp[,-1]
tmp[,srcvars[[i]]] <- tmp[,srcvars[[i]]]/srcm$zval
+ tmp <- tmp[,-grep("cell", colnames(tmp))]
} else {
warning("Non-grid type dataset not yet supported. Skipping.")
# TODO support point type
next
}
- if (!exists("outdat")) outdat <- tmp else outdat <- merge(outdat, tmp, by=c("idx","wdate"), all=TRUE)
+ if (!exists("outdat")) outdat <- tmp else outdat <- merge(outdat, tmp, by=c("idx","date"), all=TRUE)
}
basegrid <- raster()
res(basegrid) <- maxres
- cells <- cellFromXY(basegrid,xy)
+ cells <- cellFromXY(basegrid,xy)
+
+ #Generate Psudo-station ID based on maximumresolution. If resolution <.1 multiply by 3600 (seconds in 1 degree) else multiply by 60 (mins in 1 degree)
stn <- ifelse(length(gregexpr("0",unlist(strsplit(as.character(maxres),"\\."))[2])[[1]])>1,maxres*3600,maxres*60)
station <- paste(stn, sprintf(paste("%0",nchar(ncell(basegrid)),"d",sep=""),cells),sep="")
@@ -102,7 +104,7 @@
wth at lon <- xy[i,1]
wth at lat <- xy[i,2]
wth at alt <- -99
- wth at w <- outdat[outdat$idx==i,-1]
+ wth at w <- outdat[outdat$idx==i,-(grep("idx", colnames(outdat)))]
outlist[[i]] <- wth
}
return(outlist)
Modified: pkg/geoclimate/R/nasa.r
===================================================================
--- pkg/geoclimate/R/nasa.r 2013-04-16 01:15:42 UTC (rev 37)
+++ pkg/geoclimate/R/nasa.r 2013-05-23 08:20:33 UTC (rev 38)
@@ -3,7 +3,7 @@
# Version 0.0.1
# Licence GPL v3
-get.nasa <- function(x, y, stdate="1983-1-1", endate=Sys.Date(), savepath=getwd(), rm.existing=FALSE){
+get.nasa <- function(x, y, vars=c("toa_dwn","swv_dwn","lwv_dwn","T2M", "T2MN","T2MX", "RH2M", "DFP2M","RAIN", "WS10M"),stdate="1983-1-1", endate=Sys.Date(), savepath=getwd(), rm.existing=FALSE){
result <- new("weather")
src <- ""
if(length(x)!=1|length(y)!=1){
@@ -26,7 +26,8 @@
endate <- as.Date(endate)
fname <- paste(paste("nasa",cell,x,y,format(stdate,"%Y.%m.%d"),format(endate,"%Y.%m.%d"), sep="_"), ".txt",sep="")
- dlurl <- paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",format(stdate,"%m"),"&ds=",format(stdate,"%d"),"&ys=",format(stdate,"%Y"),"&me=",format(endate,"%m"),"&de=",format(endate,"%d"),"&ye=",format(endate,"%Y"),"&p=swv_dwn&p=T2M&p=T2MN&p=T2MX&p=RH2M&p=DFP2M&p=RAIN&p=WS10M&submit=Submit", sep="")
+ #dlurl <- paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",format(stdate,"%m"),"&ds=",format(stdate,"%d"),"&ys=",format(stdate,"%Y"),"&me=",format(endate,"%m"),"&de=",format(endate,"%d"),"&ye=",format(endate,"%Y"),"&p=swv_dwn&p=T2M&p=T2MN&p=T2MX&p=RH2M&p=DFP2M&p=RAIN&p=WS10M&submit=Submit", sep="")
+ dlurl <- paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",format(stdate,"%m"),"&ds=",format(stdate,"%d"),"&ys=",format(stdate,"%Y"),"&me=",format(endate,"%m"),"&de=",format(endate,"%d"),"&ye=",format(endate,"%Y"),"&p=", paste(vars,collapse="&p",sep=""),"&submit=Submit", sep="")
show.message("Reading ", appendLF=FALSE)
if (!file.exists(paste(savepath, fname, sep="/"))){
More information about the Rodbcext-commits
mailing list