[Rodbcext-commits] r24 - in pkg/geoclimate: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 13 07:41:35 CEST 2012
Author: jaunario
Date: 2012-07-13 07:41:35 +0200 (Fri, 13 Jul 2012)
New Revision: 24
Modified:
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/fse.r
pkg/geoclimate/R/trmm.r
pkg/geoclimate/R/upload.r
Log:
get.fse reads FSE formatted weather text files into R weather class objects
get.trmm downloads 3B42 daily rainfall products.
upload.trmm sends trmm weather objects to a database table
Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2012-07-13 05:29:00 UTC (rev 23)
+++ pkg/geoclimate/DESCRIPTION 2012-07-13 05:41:35 UTC (rev 24)
@@ -1,10 +1,10 @@
Package: geoclimate
Type: Package
Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.7
+Version: 0.0.10
Date: 2009-2-24
Depends: methods, genutils, weather
-Suggests: RODBC, ncdf, RCurl
+Suggests: RODBC, RCurl
Author: Jorrel Khalil S. Aunario
Maintainer: <jaunario at gmail.com>
Description: [description]
Modified: pkg/geoclimate/R/fse.r
===================================================================
--- pkg/geoclimate/R/fse.r 2012-07-13 05:29:00 UTC (rev 23)
+++ pkg/geoclimate/R/fse.r 2012-07-13 05:41:35 UTC (rev 24)
@@ -83,3 +83,7 @@
}
return(fsewth)
}
+
+write.fse <- function(wth, filename="",...){
+
+}
\ No newline at end of file
Modified: pkg/geoclimate/R/trmm.r
===================================================================
--- pkg/geoclimate/R/trmm.r 2012-07-13 05:29:00 UTC (rev 23)
+++ pkg/geoclimate/R/trmm.r 2012-07-13 05:41:35 UTC (rev 24)
@@ -2,41 +2,73 @@
# Date : 20 February 2012
# Version 0.0.2
# Licence GPL v3
+TRMM.ftp <- "ftp://disc2.nascom.nasa.gov/data/TRMM/Gridded/Derived_Products"
+get.trmm <- function(ver="v7", wdate="1998-1-1", savepath=getwd(), rm.existing=FALSE,...){
+ if(!require(RCurl)) stop("package RCurl not found.")
+
+ if (!is.na(savepath)) force.directories(savepath, recursive=TRUE)
+ versions <- c("3B42_V6", "3B42_V7", "3B42RT")
+
+ ip <- grep(ver, versions, ignore.case=TRUE)
+ if (is.na(ip) | length(ip)>1){
+ stop("Invalid version. Should be v6, v7 or rt.")
+ } else {
+ product <- ifelse(toupper(ver) %in% c("V6", "V7"), paste("3B42_",toupper(ver), sep=""),paste("3B42", toupper(ver), sep=""))
+ }
-get.trmm <- function(wdate="1998-1-1", savepath=getwd(), rm.existing=FALSE){
- if (!require(ncdf)) stop("Package ncdf not found.")
- result <- vector()
wdate <- as.Date(wdate)
- if(wdate < as.Date("1998-1-1")){
- show.message("Date ", wdate," is earlier than start of TRMM data. Using 1998-1-1 instead.", appendLF=TRUE)
- wdate <- as.Date("1998-1-1")
+ if ((ip==3) & (wdate < as.Date("2008-10-1"))){
+ stop("Date ", wdate," is earlier than start of specified version. ", versions[ip], " started 2008-10-1.")
+ #wdate <- as.Date("1998-1-1")
+ } else if (wdate < as.Date("1998-1-1")){
+ show.message("Date ", wdate," is earlier than start of specified version. ", versions[ip], " started 1998-1-1.")
+ #wdate <- as.Date("1998-1-1")
}
- if (!force.directories(savepath, recursive=TRUE)){
- show.message("Error: Cannot create ", savepath, ".", appendLF=TRUE)
+ switch(ip,
+ { fname <- paste("3B42_daily.", format(wdate, "%Y.%m.%d"),".6.bin",sep="" )
+ prod.ftp <- paste(TRMM.ftp, product, "Daily", yearFromDate(wdate), fname,sep="/")
+ },
+ { fname <- paste("3B42_daily.", format(wdate, "%Y.%m.%d"),".7.bin",sep="" )
+ prod.ftp <- paste(TRMM.ftp, product, "Daily", yearFromDate(wdate), fname,sep="/")
+ },
+ { fname <- paste("3B42RT_daily.", format(wdate, "%Y.%m.%d"),".bin",sep="" )
+ prod.ftp <- paste(TRMM.ftp, product, "Daily", yearFromDate(wdate), fname,sep="/")
+ }
+ )
+
+ if (file.exists(paste(savepath,fname,sep="/")) & rm.existing){
+ file.remove(paste(savepath,fname,sep="/"))
+ rawtrmm <- withRetry(getBinaryURL(prod.ftp),...)
+ } else if (file.exists(paste(savepath,fname,sep="/"))){
+ rawtrmm <- getBinaryURL(paste("file://localhost", normalizePath(savepath, winslash="/"), fname, sep="/"))
} else {
- prevday <- wdate-1
- fname <- paste("3B42_daily.",format(wdate, "%Y.%m.%d"),".6.nc", sep="")
- src <- paste("http://disc3.nascom.nasa.gov/daac-bin/OTF/HTTP_services.cgi?FILENAME=%2Fftp%2Fdata%2Fs4pa%2FTRMM_L3%2FTRMM_3B42_daily%2F",format(prevday, "%Y"),"%2F",format(prevday,"%j"),"%2F3B42_daily.",format(wdate, "%Y.%m.%d"),".6.bin&LABEL=3B42_daily.",format(wdate, "%Y.%m.%d"),".6.nc&SHORTNAME=TRMM_3B42_daily&SERVICE=HDF_TO_NetCDF&VERSION=1.02",sep="")
- outfile <- paste(savepath, fname, sep="/")
- if (!file.exists(outfile)){
- withRetry(download.file(src, outfile, method="internal", mode="wb"))
- } else if (rm.existing | file.info(outfile)$size<2321368){
- file.remove(outfile)
- withRetry(download.file(src, outfile, method="internal", mode="wb"))
- }
-
- traster <- try(raster(outfile),silent=TRUE)
- if(class(traster)!="try-error"){
- xy <- xyFromCell(traster,1:ncell(traster))
- prec <- values(traster)
- result <- cbind(xy,prec)
- } else {
- show.message(traster, appendLF=TRUE)
- }
+ rawtrmm <- withRetry(getBinaryURL(prod.ftp),...)
}
- return(result)
+ if (class(rawtrmm)!="try-error") stop(rawtrmm)
+
+ if (class(savepath)=="character") writeBin(rawtrmm, paste(savepath,fname,sep="/"))
+
+ baseraster <- raster(extent(-180,180,-50,50))
+ res(baseraster) <- 0.25
+
+ prec <- matrix(readBin(rawtrmm, double(), endian="big", size=4, n=ncell(baseraster)), ncol=ncol(baseraster), nrow=nrow(baseraster), byrow=TRUE)
+ prec[prec==min(prec)] <- NA
+ prec <- prec[nrow(prec):1,]
+
+ baseraster[] <- prec
+ prec <- values(baseraster)
+ cell <- 1:ncell(baseraster)
+ wth <- new("weather")
+ wth at stn <- "Tropical Rainfall Measuring Mission"
+ wth at rmk <- prod.ftp
+ wth at lon <- c(-180,180)
+ wth at lat <- c(-50,50)
+ wth at w <- as.data.frame(prec)
+ wth at w <- cbind(cell,wdate,wth at w)
+
+ return(wth)
}
trmm.monthly <- function(month=1,year=1998, savepath=getwd(), rm.old=FALSE){
Modified: pkg/geoclimate/R/upload.r
===================================================================
--- pkg/geoclimate/R/upload.r 2012-07-13 05:29:00 UTC (rev 23)
+++ pkg/geoclimate/R/upload.r 2012-07-13 05:41:35 UTC (rev 24)
@@ -49,8 +49,24 @@
success <- .upload(dbasecon, igsod, tablename=setname)
return(success)
-}
+}
+upload.trmm <- function(dbasecon, trmm, setname="trmm_15m"){
+ # TODO: support transaction
+ success <- FALSE
+
+ if (class(trmm)!="weather"){
+ stop("Invalid gsod input. Should be class 'weather'")
+ }
+
+ #igsod <- cbind(as.numeric(gsod at stn), gsod at w)
+ #colnames(igsod) <- c('station_id', colnames(gsod at w))
+ success <- .upload(dbasecon, trmm at w, tablename=setname)
+
+ return(success)
+
+}
+
upload.FSE <- function(dbasecon, clim, setname, stations=NA, has.AIid=FALSE){
add <- success <- FALSE
More information about the Rodbcext-commits
mailing list