[Rodbcext-commits] r51 - in pkg/geoclimate: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Mar 14 04:58:26 CET 2014
Author: jaunario
Date: 2014-03-14 04:58:23 +0100 (Fri, 14 Mar 2014)
New Revision: 51
Added:
pkg/geoclimate/R/classes-connection.r
pkg/geoclimate/R/classes-data.r
pkg/geoclimate/R/conversion.r
pkg/geoclimate/R/datasets.r
pkg/geoclimate/R/fetch.r
pkg/geoclimate/R/humidity.R
pkg/geoclimate/R/settings.r
pkg/geoclimate/R/source-ascutils.r
pkg/geoclimate/R/source-cccma.r
pkg/geoclimate/R/source-cru.r
pkg/geoclimate/R/source-fse.r
pkg/geoclimate/R/source-nasa.r
pkg/geoclimate/R/source-trmm.r
pkg/geoclimate/R/vaporpressure.r
Removed:
pkg/geoclimate/R/ascutils.R
pkg/geoclimate/R/cccma.r
pkg/geoclimate/R/datasets.R
pkg/geoclimate/R/fetch.R
pkg/geoclimate/R/fse.r
pkg/geoclimate/R/nasa.r
pkg/geoclimate/R/trmm.r
Modified:
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/upload.r
Log:
standardized filenames.
Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/DESCRIPTION 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,7 +1,7 @@
Package: geoclimate
Type: Package
Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.23
+Version: 0.1.2
Date: 2013-6-4
Depends: methods, genutils, oldweather, RODBC
Suggests: RCurl, ncdf
Deleted: pkg/geoclimate/R/ascutils.R
===================================================================
--- pkg/geoclimate/R/ascutils.R 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/ascutils.R 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,38 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 30 April 2010
-# Version 0.0.1
-# Licence GPL v3
-
-fillMissing <- function(ascii, xllcorner,yllcorner,ncols,nrows,cellsize){
- asclines <- readLines(ascii)
- cols <- as.numeric(trim(sub("ncols","",asclines[1])))
- rows <- as.numeric(trim(sub("nrows","",asclines[2])))
- xll <- as.numeric(trim(sub("xllcorner","",asclines[3])))
- yll <- as.numeric(trim(sub("yllcorner","",asclines[4])))
- res<- as.numeric(trim(sub("cellsize","",asclines[5])))
-
-}
-
-asciiDataFrame <- function(ascfile, nodata.na=TRUE, verbose=FALSE){
- asclines <- readLines(ascfile)
- cols <- as.numeric(trim(sub("ncols","",asclines[grep("ncols", asclines)[1]])))
- rows <- as.numeric(trim(sub("nrows","",asclines[grep("nrows", asclines)[1]])))
- xll <- as.numeric(trim(sub("xllcorner","",asclines[grep("xllcorner", asclines)[1]])))
- yll <- as.numeric(trim(sub("yllcorner","",asclines[grep("yllcorner", asclines)[1]])))
- res<- as.numeric(trim(sub("cellsize","",asclines[grep("cellsize", asclines)[1]])))
- nodata<- as.numeric(trim(sub("NODATA_value","",asclines[grep("NODATA_value", asclines)[1]])))
- cell <- 1:(cols*rows)-1
- nlayers <- length(asclines)/(rows+6)
- dat <- numeric(0)
- for (i in 1:nlayers){
- #cat(1:(rows+6)+((rows+6)*(i-1)), "\n")
- #flush.console()
- dat <- cbind(dat,as.numeric(unlist(strsplit(asclines[1:rows+6+((rows+6)*(i-1))]," "))))
- }
- if(nodata.na){
- dat[dat==nodata] <- NA
- }
- colnames(dat) <- 1:nlayers
- dat <- as.data.frame(cbind(cell,dat),stringsAsFactors=FALSE)
- return(dat)
-}
Deleted: pkg/geoclimate/R/cccma.r
===================================================================
--- pkg/geoclimate/R/cccma.r 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/cccma.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,40 +0,0 @@
-#library(RNetCDF)
-
-#library(raster)
-#library(RODBC)
-#library(weather)
-#library(genutils)
-
-cccma.files <- function(..., type="nc"){
- if (!require(ncdf)) stop("Package ncdf not found.")
- files <- list.files(...)
-# info <- matrix(unlist(strsplit(basename(files))),ncol=8)
-
-# cccmadir <- "D:/projects/Climate/Database/Source/CCCMA"
-# cccmafiles <- list.files(cccmadir, full.names=TRUE)
-# climvars <- vector()
-# for (cccfile in cccmafiles){
- #cccfile <- cccmafiles[1]
-# nc <- open.nc(cccfile)
-# climvar <- var.inq.nc(nc,file.inq.nc(nc)$nvars-1)$name
-# climvars <- c(climvars,climvar)
-# }
-# y <- 2001
-# d <- 0
-# for (i in 1:36500){
-# daydata <- vector()
-# if(d<365 | isLeapYear(y)){
-# d <- d + 1
-# } else {
-# y <- y+1
-# d <- 0
-# }
-# dt <- dateFromDoy(d,y)
-# for (i in 1:length(climvars)){
-# assign(climvar, raster(cccmafiles[i], varname=climvars[i], band=i))
-# }
-# colnames(daydata) <- climvars
-#
-# }
-
-}
Added: pkg/geoclimate/R/classes-connection.r
===================================================================
--- pkg/geoclimate/R/classes-connection.r (rev 0)
+++ pkg/geoclimate/R/classes-connection.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,34 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 18 February 2014
+# Version 0.0.1
+# Licence GPL v3
+
+setClass('geoclimate',
+ representation (
+ host = 'character',
+ user = 'character',
+ password = 'character',
+ warehouse = 'character',
+
+ # spectral info
+ specid = 'character',
+ specname = 'character',
+ speclow = 'numeric',
+ spechigh = 'numeric',
+ specmid = 'numeric',
+ speccol = 'character',
+ layer = 'integer',
+ band_filenames = 'character',
+
+ #acquisition info
+ acquisition_date = 'character',
+ acquisition_time = 'character',
+ sun_elevation = 'numeric',
+ sun_azimuth = 'numeric',
+
+ product_creation_date = 'character',
+ zone = 'character'
+
+ )
+)
+
Added: pkg/geoclimate/R/classes-data.r
===================================================================
--- pkg/geoclimate/R/classes-data.r (rev 0)
+++ pkg/geoclimate/R/classes-data.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,34 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 14 January 2014
+# Version 0.0.1
+# Licence GPL v3
+
+setClass('xx',
+ representation (
+ name = 'character',
+ spacecraft = 'character',
+ scene_id = 'character',
+ metafile = 'character',
+
+ # spectral info
+ specid = 'character',
+ specname = 'character',
+ speclow = 'numeric',
+ spechigh = 'numeric',
+ specmid = 'numeric',
+ speccol = 'character',
+ layer = 'integer',
+ band_filenames = 'character',
+
+ #acquisition info
+ acquisition_date = 'character',
+ acquisition_time = 'character',
+ sun_elevation = 'numeric',
+ sun_azimuth = 'numeric',
+
+ product_creation_date = 'character',
+ zone = 'character'
+
+ )
+)
+
Added: pkg/geoclimate/R/conversion.r
===================================================================
--- pkg/geoclimate/R/conversion.r (rev 0)
+++ pkg/geoclimate/R/conversion.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,10 @@
+# TODO: Add comment
+#
+# Author: jaunario
+###############################################################################
+
+jpdToWatt <- function(x){
+ return(x/86400)
+}
+
+
Deleted: pkg/geoclimate/R/datasets.R
===================================================================
--- pkg/geoclimate/R/datasets.R 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/datasets.R 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,10 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 15 March 2013
-# Version 0.0.1
-# Licence GPL v3
-
-datasets <- function(con){
- return(sqlQuery(con,"SELECT * FROM datasets"))
-}
-
-
Copied: pkg/geoclimate/R/datasets.r (from rev 47, pkg/geoclimate/R/datasets.R)
===================================================================
--- pkg/geoclimate/R/datasets.r (rev 0)
+++ pkg/geoclimate/R/datasets.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,10 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 15 March 2013
+# Version 0.0.1
+# Licence GPL v3
+
+datasets <- function(con){
+ return(sqlQuery(con,"SELECT * FROM datasets"))
+}
+
+
Deleted: pkg/geoclimate/R/fetch.R
===================================================================
--- pkg/geoclimate/R/fetch.R 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/fetch.R 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,135 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 14 March 2013
-# Version 0.0.1
-# Licence GPL v3
-
-.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)
- 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 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 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, date")
-
- data <- sqlQuery(con, query, ...)
-
- return(data)
-}
-
-if ( !isGeneric("geoclimate.fetch") ) {
- setGeneric("geoclimate.fetch", function(xy, srcvars, connection, ...)
- standardGeneric("geoclimate.fetch"))
-}
-
-
-setMethod("geoclimate.fetch", signature(xy="matrix", srcvars="list", connection="RODBC"),
- function(xy, srcvars, connection, warehouse="geowarehouse",...){
-
- # Connect to database
- #connection <- odbcConnect(connection)
-
- # Get dataset meta data for location matching
- srcmeta <- sqlQuery(connection,paste("SELECT * FROM ", warehouse,".climate_data WHERE table_name in (", paste(shQuote(unique(names(srcvars))),collapse=", "),")", sep=""), 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)
-
- # 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=stdcells, con=connection, wset=paste(srcm$schema_name,srcm$table_name, sep=".") , vars=srcvars[[i]])
- tmp$idx <- match(tmp$cell, stdcells)
- 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","date"), all=TRUE)
- }
-
-
- basegrid <- raster()
- res(basegrid) <- maxres
- 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="")
-
- # 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,-(grep("idx", colnames(outdat)))]
- 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, ...){
-#
-#})
-#
Copied: pkg/geoclimate/R/fetch.r (from rev 47, pkg/geoclimate/R/fetch.R)
===================================================================
--- pkg/geoclimate/R/fetch.r (rev 0)
+++ pkg/geoclimate/R/fetch.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,233 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 14 March 2013
+# Version 0.0.2
+# Licence GPL v3
+
+.fetch <- function(cells, con, wset, stdate=as.Date("1983-1-1"), endate=Sys.Date(), vars=NULL, timestep=TS.daily, ...){
+ #function(cells, con, wset, stdate=Sys.Date()-as.numeric(format(Sys.Date(),"%j"))+1, endate=Sys.Date(), vars=NULL, ...){
+
+ #INPUT CLEANUP
+ # 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 if (length(vars)==0){
+ vars <- "*"
+ } else if ((length(vars)==1 & (is.na(vars) | tolower(vars)=="all" | vars=="*"))){
+ vars <- "*"
+ }
+
+ # Date check
+ if(stdate>endate){
+ warning(format(stdate,"%x"), " > ",format(endate,"%x"))
+ dd <- stdate
+ stdate <- endate
+ endate <- dd
+ }
+
+ # 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)
+ }
+
+ # QUERY CONSTRUCTION
+ # Column list
+ if (length(vars)>1){
+ ts <- switch(timestep, "wdate as date", "wdate as date","yr as year, mo as month", "yr as year")
+ vars <- paste("cell", ts, paste(vars, collapse=", "), sep= ", ")
+ } else if ((length(vars)==1 & vars!="*")){
+ ts <- switch(timestep, "wdate as date", "wdate as date","yr as year, mo as month", "yr as year")
+ vars <- paste("cell", ts, paste(vars, collapse=", "), sep= ", ")
+ }
+
+ # time filter clause
+ timefilter <- switch(timestep, paste("wdate BETWEEN", shQuote(stdate), "AND", shQuote(endate)),
+ paste("wdate BETWEEN", shQuote(stdate), "AND", shQuote(endate)),
+ ifelse(yearFromDate(stdate)!=yearFromDate(endate),paste("(yr=",yearFromDate(stdate)," AND mo>=", monthFromDate(stdate),") OR (yr=",yearFromDate(endate)," AND mo<=", monthFromDate(endate),")",sep=""),paste("yr=", yearFromDate(stdate), " AND (mo BETWEEN ", monthFromDate(stdate), " AND ", monthFromDate(endate), ")",sep="")),
+ paste("yr BETWEEN ", yearFromDate(stdate), " AND ", yearFromDate(endate), sep=""))
+
+ # order clause
+ orderclause <- switch(timestep, "cell, wdate",
+ "cell, wdate",
+ "cell, yr, mo",
+ "cell, yr",)
+
+ query <- paste("SELECT ", vars, " FROM ", wset, " WHERE (", timefilter , ") AND (cell IN (",paste(cells, collapse=", ") ,")) ORDER BY ", orderclause, sep="")
+
+ # QUERY RUN
+ data <- sqlQuery(con, query, ...)
+
+ return(data)
+}
+
+if ( !isGeneric("geoclimate.fetch") ) {
+ setGeneric("geoclimate.fetch", function(xy, srcvars, connection, ...)
+ standardGeneric("geoclimate.fetch"))
+}
+
+
+
+#setMethod("geoclimate.fetch", signature(xy="matrix", srcvars="list", connection="RODBC"),
+fetch.monthly <- function(xy, srcvars, connection, warehouse="geowarehouse",...){
+
+ # Connect to database
+ #connection <- odbcConnect(connection)
+
+ # Get dataset meta data for location matching
+ srcmeta <- sqlQuery(connection,paste("SELECT * FROM ", warehouse,".climate_data WHERE timestep='daily' AND table_name in (", paste(shQuote(unique(names(srcvars))),collapse=", "),")", sep=""), 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)
+
+ # 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]], timestep=TS.monthly, ...)
+ #tmp <- fetch(cells=stdcells, con=connection, wset=paste(srcm$schema_name,srcm$table_name, sep=".") , vars=srcvars[[i]])
+ tmp$idx <- match(tmp$cell, stdcells)
+ 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","date"), all=TRUE)
+ }
+
+
+ basegrid <- raster()
+ res(basegrid) <- maxres
+ 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="")
+
+ # 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,-(grep("idx", colnames(outdat)))]
+ outlist[[i]] <- wth
+ }
+ return(outlist)
+ }
+#)
+
+fetch.daily <- function(xy, srcvars, connection, warehouse="geowarehouse",...){
+
+ # Connect to database
+ #connection <- odbcConnect(connection)
+
+ # Get dataset meta data for location matching
+ srcmeta <- sqlQuery(connection,paste("SELECT * FROM ", warehouse,".climate_data WHERE timestep='daily' AND table_name in (", paste(shQuote(unique(names(srcvars))),collapse=", "),")", sep=""), 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)
+
+ # 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]], timestep=TS.daily, ...)
+ #tmp <- fetch(cells=stdcells, con=connection, wset=paste(srcm$schema_name,srcm$table_name, sep=".") , vars=srcvars[[i]])
+ tmp$idx <- match(tmp$cell, stdcells)
+ 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","date"), all=TRUE)
+ }
+
+
+ basegrid <- raster()
+ res(basegrid) <- maxres
+ 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="")
+
+ # 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,-(grep("idx", colnames(outdat)))]
+ 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, ...){
+#
+#})
+#
Deleted: pkg/geoclimate/R/fse.r
===================================================================
--- pkg/geoclimate/R/fse.r 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/fse.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,190 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 7 May 2012
-# Version 0.0.1
-# Licence GPL v3
-# Read and Write FSE weather files
-
-read.fse <- function(fsefile, datacols=c("station_id", "year", "doy", "srad", "tmin", "tmax", "vapr","wind","prec"), delim=" ", skip.hdr=FALSE, std.vals=TRUE){
-
- fsewth <- new("weather")
- is.sunshine <- FALSE
- if (length(which(datacols %in% c("year", "doy")))!=2) stop("Required columns year and doy (day of year) not found.")
-
- if(file.exists(fsefile) & file.info(fsefile)$size!=0){
-
- dlines <- readLines(fsefile)
- dlines <- gsub("\t", delim, dlines)
-
- # get headers
- ihdr <- grep("\\*", dlines)
-
- if(!skip.hdr){
- hdr <- gsub("\\*", " ", dlines[min(ihdr):max(ihdr)])
- hdr <- trim(gsub("\\?", " ", hdr))
- hdr <- hdr[hdr!=""]
-
- icol <- grep("1[[:space:]]+Station", hdr, ignore.case=TRUE)
- if (length(icol)>1 & length(grep("--", hdr))>0){
- colinfo <- hdr[icol:(length(hdr)-1)]
- } else {
- colinfo <- hdr[icol:length(hdr)]
- }
- hdr <- hdr[1:(icol-1)]
-
- # get station name
- i <- grep("station", hdr, ignore.case=TRUE)
- if (length(i)==0) {
- i <- grep("location", hdr, ignore.case=TRUE)
- }
- fsewth at stn <- ifelse(!is.na(i[1]), trim(gsub("\\*", "", unlist(strsplit(hdr[i],":"))[2])),"Unknown")
-
- # get source
- i <- grep("source", hdr, ignore.case=TRUE)
- fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(hdr[i],":"))[2]),"")
-
- # get station name
- #i <- grep("source", hdr, ignore.case=TRUE)
- #fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(dlines[i],":"))[2]),"")
- }
-
-
- # get coordinates
- coords <- as.numeric(unlist(strsplit(trim(dlines[max(ihdr)+1]),delim)))
- coords <- coords[!is.na(coords)]
-
- rm(dlines)
- gc(verbose=FALSE)
-
- fsewth at lon <- coords[1]
- fsewth at lat <- coords[2]
- fsewth at alt <- coords[3]
-
- #dmatrix <- matrix(as.numeric(unlist(strsplit(trim(dlines[(max(ihdr)+2):length(dlines)]), "[[:space:]]+"))), ncol=length(colinfo), byrow=TRUE)
- #dmatrix[dmatrix==-9999] <- NA
- #dmatrix <- as.data.frame(dmatrix)
-
- if(delim==" " | delim==""){
- dmatrix <- read.table(fsefile, skip=max(ihdr)+1, stringsAsFactors=FALSE)
- } else {
- dmatrix <- read.table(fsefile, skip=max(ihdr)+1, stringsAsFactors=FALSE, sep=delim)
- }
-
- colnames(dmatrix) <- datacols
-
- if(!skip.hdr & std.vals){
- # CHECK RADIATION UNITS THEN CONVERT TO MEGAJOULE/SQM/DAY IF NECESSARY
-
- # Check if sunshine hours/duration
- rad_var <- grep("sunshine[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
- if (length(rad_var)!=0){
- dmatrix[,rad_var] <- round(sunhoursToSRad(dmatrix[,rad_var],dmatrix[,3],fsewth at lat, coords[4], coords[5]),2)
- show.message("Sunshine duration", appendLF=TRUE)
-
- } else {
- rad_var <- grep("[[:print:]]*rad[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
- if(length(rad_var)!=0 & grepl("kj", colinfo[rad_var],ignore.case=TRUE)) {
- dmatrix[,rad_var] <- round(dmatrix[,rad_var]/1000,2)
- }
-
- }
- }
-
- wdate <- dateFromDoy(dmatrix[,"doy"],dmatrix[,"year"])
- fsewth at w <- cbind(wdate,as.data.frame(dmatrix[,4:length(datacols)]))
- #fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(dlines[i],":"))[2]),"")
-
- } else {
- stop(fsefile, " not found.")
- }
- return(fsewth)
-}
-
-
-.toFSEFile <- function(wthdat, country="WORLD", station="", author="Geoclimate (IRRI-GIS Climate Data Package)", 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="")
-
- 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"){
- locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00", sep=", ")
- 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"){
- locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00")
- 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)
- }
-)
Added: pkg/geoclimate/R/humidity.R
===================================================================
--- pkg/geoclimate/R/humidity.R (rev 0)
+++ pkg/geoclimate/R/humidity.R 2014-03-14 03:58:23 UTC (rev 51)
@@ -0,0 +1,15 @@
+# TODO: Add comment
+#
+# Author: jaunario
+###############################################################################
+
+
+
+iRH <- function(temp,mvp){
+ es_Ta <- svp(temp) #saturated water vapor pressure at Ta (hPa)
+
+ # Instantaneous relative humidity, RHumi%)
+ RHum <- mvp / es_Ta * 100
+ if (RHum > 100) RHum <- 100
+ return(RHum)
+}
Deleted: pkg/geoclimate/R/nasa.r
===================================================================
--- pkg/geoclimate/R/nasa.r 2013-12-21 02:59:39 UTC (rev 50)
+++ pkg/geoclimate/R/nasa.r 2014-03-14 03:58:23 UTC (rev 51)
@@ -1,89 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 22 February 2011
-# Version 0.0.1
-# Licence GPL v3
-
-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){
- if(!require(RCurl)){
- stop("Package RCurl not found.")
- }
- result <- new("weather")
- src <- ""
- if(length(x)!=1|length(y)!=1){
- show.message("Warning: Either x or y has length > 1. Using first only.", appendLF=TRUE)
- x <- x[1]
- y <- y[1]
- }
- result at lon <- x
- result at lat <- y
-
- # check if downloaded file can be saved to disk
- savepath[is.na(savepath)] <- NULL
- proceedwrite <- ifelse(is.character(savepath),force.directories(savepath),FALSE)
-
- cell <- cellFromXY(raster(),t(c(x,y)))
- result at stn <- as.character(cell)
-
-
- stdate <- as.Date(stdate)
- 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://power.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",monthFromDate(stdate),"&ds=",dayFromDate(stdate),"&ys=",yearFromDate(stdate),"&me=",monthFromDate(endate),"&de=",dayFromDate(endate),"&ye=",yearFromDate(endate),"&p=", paste(vars,collapse="&p=",sep=""),"&submit=Submit", sep="")
-
- show.message("Reading ", appendLF=FALSE)
- if (!file.exists(paste(savepath, fname, sep="/"))){
- show.message(dlurl, appendLF=TRUE)
- dlines <- unlist(strsplit(getURL(url=dlurl), "\n"))
- if(!is.null(savepath)) writeLines(dlines, paste(savepath, fname, sep="/"))
- src <- dlurl
- } else if (rm.existing | file.info(paste(savepath, fname, sep="/"))$size==0){
- show.message(dlurl, appendLF=TRUE)
- file.remove(paste(savepath, fname, sep="/"))
- dlines <- unlist(strsplit(getURL(url=dlurl), "\n"))
- writeLines(dlines, paste(savepath, fname, sep="/"))
- src <- dlurl
- } else {
- show.message(paste(savepath, fname, sep="/"), appendLF=TRUE)
- dlines <- readLines(paste(savepath, fname, sep="/"))
- src <- paste(savepath, fname, sep="/")
- }
-
- if (class(dlines)=="try-error"){
- msg <- as.character(dlines)
- } else {
- # Check download integrity
- stline <- grep(paste(format(stdate,"%Y"),format(as.numeric(format(stdate,"%j")),width=3)), dlines)
- endline <- grep(paste(format(endate,"%Y"),format(as.numeric(format(endate,"%j")),width=3)), dlines)
-
- if (length(stline)!=1|length(endline)!=1){
- msg <- paste("Incomplete or No data found on file. If file", fname, "is on disk, remove the file then rerun this program.")
- } else if(length(unlist(strsplit(dlines[endline], "[[:space:]]+")))!=(length(vars)+2)){
- msg <- paste("Incomplete download detected. If file", fname, "is on disk, remove the file then rerun this program.")
- } else {
- msg <- paste("Read from", src)
- if (proceedwrite) writeLines(dlines, paste(savepath, fname, sep="/"))
- alt <- as.numeric(unlist(strsplit(dlines[grep("Elevation", dlines)],"="))[2])
- dlines <- dlines[stline:endline]
- dvector <- unlist(strsplit(dlines, "[[:space:]]+"))
- dvector[dvector=="-"] <- NA
- nasadata <- as.data.frame(matrix(as.numeric(dvector), ncol=(length(vars)+2), byrow=TRUE))
- colnames(nasadata) <- c("yr", "doy", vars)
-
- date <- format(as.Date(paste(nasadata$yr,nasadata$doy),"%Y %j"),"%Y-%m-%d")
- nasadata <- cbind(date, nasadata[,-(1:2)], stringsAsFactors=FALSE)
-
- result at alt <- alt
- result at w <- nasadata
- rm(dlines,dvector,nasadata)
- gc(verbose=FALSE)
- }
- }
- show.message(msg)
- result at rmk <- msg
- return(result)
-}
-
-#get.nasa(-179.5, 89.5)
-
Added: pkg/geoclimate/R/settings.r
===================================================================
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rodbcext -r 51
More information about the Rodbcext-commits
mailing list