From noreply at r-forge.r-project.org  Tue Apr 16 03:15:46 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 16 Apr 2013 03:15:46 +0200 (CEST)
Subject: [Rodbcext-commits] r37 - in pkg/geoclimate: . R
Message-ID: <20130416011546.7B9E3184BC2@r-forge.r-project.org>

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)
+	}
+)