[Rodbcext-commits] r37 - in pkg/geoclimate: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 16 03:15:46 CEST 2013
Author: jaunario
Date: 2013-04-16 03:15:42 +0200 (Tue, 16 Apr 2013)
New Revision: 37
Modified:
pkg/geoclimate/
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/fetch.R
pkg/geoclimate/R/fse.r
Log:
changed data column vaporp to vapr on write.fse
fixed bugs on geoclimate.fetch
Property changes on: pkg/geoclimate
___________________________________________________________________
Modified: svn:ignore
- temp
+ .settings
temp
Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2013-03-15 05:42:35 UTC (rev 36)
+++ pkg/geoclimate/DESCRIPTION 2013-04-16 01:15:42 UTC (rev 37)
@@ -1,10 +1,10 @@
Package: geoclimate
Type: Package
Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.12
+Version: 0.0.14
Date: 2009-2-24
-Depends: methods, genutils, weather
-Suggests: RODBC, RCurl, ncdf
+Depends: methods, genutils, weather, RODBC
+Suggests: RCurl, ncdf
Author: Jorrel Khalil S. Aunario
Maintainer: <jaunario at gmail.com>
Description: [description]
Modified: pkg/geoclimate/R/fetch.R
===================================================================
--- pkg/geoclimate/R/fetch.R 2013-03-15 05:42:35 UTC (rev 36)
+++ pkg/geoclimate/R/fetch.R 2013-04-16 01:15:42 UTC (rev 37)
@@ -3,31 +3,131 @@
# Version 0.0.1
# Licence GPL v3
-.fetch <- function(cell, con, wset, stdate, endate, vars=NULL, ...){
- if (is.null(vars)|is.na(vars)) vars <- "*" else vars <- paste(vars, collapse=", ")
- query <- paste("SELECT", vars, "FROM", wset, "WHERE (wdate BETWEEN", stdate, "AND", endate,") AND (cell IN (",paste(cell, collapse=", ") ,")")
+.fetch <- function(cells, con, wset, stdate=as.Date("2012-1-1"), endate=as.Date("2012-12-31"), 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)
+ preventivem <- try(sqlQuery(con, "flush tables"))
+ if (class(preventivem)=="try-error") {
+ con <- odbcReConnect(con)
+ }
+
+ # remove invalid (NAs) cells
+ cells <- cells[!is.na(cells)]
+
+ # 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)
+ } 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 <- 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")
+
data <- sqlQuery(con, query, ...)
+
return(data)
}
-setMethod("geoclimate.fetch", signature(x="integer"),
- function(x, ...){
- return (.fetch(cell=x,...))
- }
-)
+if ( !isGeneric("geoclimate.fetch") ) {
+ setGeneric("geoclimate.fetch", function(xy, srcvars, connection, ...)
+ standardGeneric("geoclimate.fetch"))
+}
-setMethod("geoclimate.fetch", signature(x="matrix"),
- function(x, ...){
-
- }
-)
-setMethod("geoclimate.fetch", signature(x="data.frame"),
- function(x, ...){
+setMethod("geoclimate.fetch", signature(xy="matrix", srcvars="list", connection="RODBC"),
+ function(xy, srcvars, connection, ...){
-})
+ # Connect to database
+ #connection <- odbcConnect(connection)
+
+ # Get dataset meta data for location matching
+ srcmeta <- sqlQuery(connection,paste("SELECT * FROM geowarehouse.climate_data WHERE table_name in (", paste(shQuote(unique(names(srcvars))),collapse=", "),")"), stringsAsFactors=FALSE)
+ maxres <- NA
+ for (i in 1:length(srcvars)){
+ srcm <- srcmeta[srcmeta$table_name==names(srcvars)[i],]
+ if (srcm$type=="grid"){
+ srcraster <- raster(xmn=srcm$xmin, xmx=srcm$xmax, ymn=srcm$ymin, ymx=srcm$ymax, nrow=srcm$nrow, ncol=srcm$ncol)
+ baseraster <- raster()
+ res(baseraster) <- res(srcraster)
-setMethod("geoclimate.fetch", signature(x="RasterLayer"),
- function(x, ...){
+ # determine psudo-station number (basegrid + basegridcell)
+ if (is.na(maxres)|maxres>res(srcraster)[1]){
+ maxres <- res(srcraster)[1]
+ }
+
+ cells <- cellFromXY(srcraster,xy)
+
+ stdcells <- cellFromXY(baseraster,xy)
+ 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
+
+ } 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)
+ }
-})
+
+ basegrid <- raster()
+ res(basegrid) <- maxres
+ cells <- cellFromXY(basegrid,xy)
+ 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="")
+
+ # Construct source string (srcstr) for remarks on weather object
+ srcstr <- vector()
+ for (i in 1:length(srcvars)){
+ srcstr <- c(srcstr, paste(names(srcvars)[i],": ", paste(srcvars[[i]], collapse=", "), sep=""))
+ }
+ srcstr <- paste(srcstr, collapse="; ")
+
+ #Disaggregate into sets by point
+ outlist <- list()
+ for (i in 1:nrow(xy)){
+ wth <- new ("weather")
+ wth at stn <- station[i]
+ wth at rmk <- srcstr
+ wth at lon <- xy[i,1]
+ wth at lat <- xy[i,2]
+ wth at alt <- -99
+ wth at w <- outdat[outdat$idx==i,-1]
+ outlist[[i]] <- wth
+ }
+ return(outlist)
+ }
+)
+
+#setMethod("geoclimate.fetch", signature(cell="numeric"),
+# function(cell, ...){
+# return(.fetch(cell=cell,...))
+# }
+#)
+#
+#setMethod("geoclimate.fetch", signature(cell="matrix"),
+# function(cell, ...){
+#
+# }
+#)
+#
+#setMethod("geoclimate.fetch", signature(cell="data.frame"),
+# function(cell, ...){
+#
+#})
+#
+#setMethod("geoclimate.fetch", signature(cell="RasterLayer"),
+# function(cell, ...){
+#
+#})
+#
Modified: pkg/geoclimate/R/fse.r
===================================================================
--- pkg/geoclimate/R/fse.r 2013-03-15 05:42:35 UTC (rev 36)
+++ pkg/geoclimate/R/fse.r 2013-04-16 01:15:42 UTC (rev 37)
@@ -4,7 +4,7 @@
# Licence GPL v3
# Read and Write FSE weather files
-read.FSE <- function(fsefile, datacols=c("station_id", "year", "doy", "srad", "tmin", "tmax", "vaporp","wind","prec")){
+read.FSE <- function(fsefile, datacols=c("station_id", "year", "doy", "srad", "tmin", "tmax", "vapr","wind","prec")){
fsewth <- new("weather")
is.sunshine <- FALSE
@@ -84,6 +84,92 @@
return(fsewth)
}
-write.fse <- function(wth, filename="",...){
-
-}
\ No newline at end of file
+
+.toFSEFile <- function(wthdat, country="WORLD", station="", author="Geoclimate (IRRI-GIS Climatic Data Warehouse)", format="csv", comments="", savepath=getwd()){
+ # standard checks
+ if (class(wthdat)!="weather"){
+ stop("Unsupported data format. Should of class \"weather\"")
+ }
+ vars <- c("srad", "tmin", "tmax", "vapr", "wind", "prec")
+ if(sum(vars %in% colnames(wthdat at w))<length(vars)){
+ stop("Incomplete data. ", paste(vars[!vars %in% colnames(wthdat at w)],collapse=", "), " not found.")
+ }
+
+ #Override Station
+ if (station!="") wthdat at stn <- station
+
+ hdrspec <- c( paste("* Author :", author, " -99.: nil value"),
+ paste("* Source :", wthdat at rmk),
+ "*",
+ paste("* Comments :", comments))
+
+ hdrvars <- c( "* Column Daily Value",
+ "* 1 Station number",
+ "* 2 Year",
+ "* 3 Day",
+ "* 4 irradiance KJ m-2 d-1",
+ "* 5 min temperature oC",
+ "* 6 max temperature oC",
+ "* 7 vapor pressure kPa",
+ "* 8 mean wind speed m s-1",
+ "* 9 precipitation mm d-1")
+
+ hdrstn <- c(paste("* Station Name: Geoclimate Pixel", wthdat at stn),
+ paste("* Longitude: ", sprintf("%.2f", wthdat at lon), " Latitude:", sprintf("%.2f", wthdat at lat), " Altitude: ", wthdat at alt ,"m"))
+
+ hdrbar <- paste("*", paste(rep("-",max(nchar(c(hdrspec,hdrvars, hdrstn)))), collapse=""),sep="")
+
+ locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00")
+
+ wthdat at w$year <- as.numeric(format(wthdat at w$wdate, "%Y"))
+ wthdat at w$doy <- as.numeric(format(wthdat at w$wdate, "%j"))
+
+
+
+ if (format=="csv"){
+ dat <- paste(wthdat at stn, wthdat at w$year, wthdat at w$doy, wthdat at w$srad, wthdat at w$tmin, wthdat at w$tmax, wthdat at w$vapr, wthdat at w$wind, wthdat at w$prec, sep=", ")
+ } else if (format=="fixed"){
+ dat <- paste(wthdat at stn, sprintf("%6.0d", wthdat at w$year), format(wthdat at w$wdate, " %j", width=6), sprintf("%10.0f", wthdat$srad[d]), sprintf("%8.1f", wthdat$tmin[d]), sprintf("%8.1f", wthdat$tmax[d]), sprintf("%8.1f", wthdat$vapr[d]), sprintf("%8.1f", wind), sprintf("%8.1f", wthdat$prec[d]))
+ }
+
+ dat <- gsub("NA", "-99.", dat)
+
+ years <- unique(wthdat at w$year)
+ wthstrs <- list()
+ files <- vector()
+ for (yy in years){
+ fname <- paste(savepath, "/", country, wthdat at stn, ".", substr(yy, 2,4),sep="")
+ files <- c(files,fname)
+ writeLines(c(hdrbar,hdrspec,hdrstn,hdrvars,hdrbar,locstr, dat[wthdat at w$year==yy]),fname)
+ }
+
+ return(files)
+
+}
+
+
+if ( !isGeneric("write.fse") ) {
+ setGeneric("write.fse", function(wth, writeto, ...)
+ standardGeneric("write.fse"))
+}
+
+
+setMethod("write.fse", signature(wth="weather", writeto="character"),
+ function(wth, writeto, ...){
+ return(.toFSEFile(wthdat=wth, savepath=writeto, ...))
+ }
+)
+
+setMethod("write.fse", signature(wth="list", writeto="character"),
+ function(wth, writeto, ...){
+ files <- vector()
+ for (i in 1:length(wth)){
+ if (class(wth[[i]])!="weather") {
+ warning("Class ", class(wth[[i]]), " cannot be written as FSE weather file. Skipped.")
+ } else {
+ files <- c(files,.toFSEFile(wthdat=wth[[i]], savepath=writeto, ...))
+ }
+ }
+ return(files)
+ }
+)
More information about the Rodbcext-commits
mailing list