From noreply at r-forge.r-project.org Fri Mar 14 04:58:26 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 14 Mar 2014 04:58:26 +0100 (CET) Subject: [Rodbcext-commits] r51 - in pkg/geoclimate: . R Message-ID: <20140314035826.39742186B90@r-forge.r-project.org> 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)) 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 From noreply at r-forge.r-project.org Thu Mar 27 07:23:25 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 27 Mar 2014 07:23:25 +0100 (CET) Subject: [Rodbcext-commits] r52 - in pkg/genutils: . R Message-ID: <20140327062325.61C69187238@r-forge.r-project.org> Author: jaunario Date: 2014-03-27 07:23:25 +0100 (Thu, 27 Mar 2014) New Revision: 52 Added: pkg/genutils/R/worker.r Modified: pkg/genutils/ pkg/genutils/DESCRIPTION pkg/genutils/R/logutils.R Log: Added worker.r (function: get.jobs) Property changes on: pkg/genutils ___________________________________________________________________ Modified: svn:ignore - *.Rbuildignore *.Rhistory *.Rproj *.user + *.Rbuildignore *.Rhistory *.Rproj *.user .project Added: svn:global-ignores + .settings Modified: pkg/genutils/DESCRIPTION =================================================================== --- pkg/genutils/DESCRIPTION 2014-03-14 03:58:23 UTC (rev 51) +++ pkg/genutils/DESCRIPTION 2014-03-27 06:23:25 UTC (rev 52) @@ -1,7 +1,7 @@ Package: genutils Type: Package Title: IRRI Geography Lab - General Utilities -Version: 0.0.3 +Version: 0.0.4 Date: 2011-10-19 Depends: methods Author: Jorrel Khalil S. Aunario Modified: pkg/genutils/R/logutils.R =================================================================== --- pkg/genutils/R/logutils.R 2014-03-14 03:58:23 UTC (rev 51) +++ pkg/genutils/R/logutils.R 2014-03-27 06:23:25 UTC (rev 52) @@ -6,7 +6,7 @@ show.message <- function(..., EL=FALSE, delay=0){ # Real-time console messages if (EL){ - message(rep(" ", options("width")),"\r", appendLF=FALSE) + message(rep(" ", options("width")$width-1),"\r", appendLF=FALSE) } message(...) Sys.sleep(delay) Added: pkg/genutils/R/worker.r =================================================================== --- pkg/genutils/R/worker.r (rev 0) +++ pkg/genutils/R/worker.r 2014-03-27 06:23:25 UTC (rev 52) @@ -0,0 +1,44 @@ +# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com +# Date : 27 March 2014 +# Version 0.0.1 +# Licence GPL v3 + +get.jobs <- function(initjobs, jobfile="jobs.Rdata",workload=500,delay=10, maxtries=100){ + myjob <- vector() + worker.id <- Sys.getpid() + + if(!file.exists(jobfile)){ + jobs <- initjobs + save(jobs, file=jobfile) + + filelock <- data.frame(filename=character(0),worker=numeric(0)) + filelock[1,] <- NA + filelock$filename[1] <- jobfile + write.csv(filelock,"files.csv",row.names=FALSE) + + } + + tries <- 0 + repeat{ + filelock <- read.csv("files.csv",stringsAsFactors=FALSE) + if(is.na(filelock$worker[filelock$filename==jobfile])){ + filelock$worker[filelock$filename==jobfile] <- worker.id + write.csv(filelock,"files.csv",row.names=FALSE) + load(jobfile) + myjob <- jobs[1:min(workload,length(jobs))] + jobs <- jobs[!jobs %in% myjob] + save(jobs, file=jobfile) + filelock$worker[filelock$filename==jobfile] <- NA + write.csv(filelock,"files.csv",row.names=FALSE) + break + } else if (tries