[Rodbcext-commits] r13 - in pkg/geoclimate: . R

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Fri Jan 20 10:40:57 CET 2012


Author: jaunario
Date: 2012-01-20 10:40:57 +0100 (Fri, 20 Jan 2012)
New Revision: 13

Added:
   pkg/geoclimate/R/GSOD.r
   pkg/geoclimate/R/cccma.r
   pkg/geoclimate/R/trmm.r
Removed:
   pkg/geoclimate/R/dataframeutils.R
   pkg/geoclimate/R/geoutils.r
   pkg/geoclimate/R/sysutils.r
Modified:
   pkg/geoclimate/DESCRIPTION
   pkg/geoclimate/R/nasa.r
Log:
removed utils, added cccma, gsod and trmm

Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION	2012-01-20 09:39:37 UTC (rev 12)
+++ pkg/geoclimate/DESCRIPTION	2012-01-20 09:40:57 UTC (rev 13)
@@ -3,7 +3,7 @@
 Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
 Version: 0.0.1
 Date: 2009-2-24
-Depends: methods, rodbcExt, weather
+Depends: methods, rodbcExt, weather, genutils, ncdf
 Author: Jorrel Khalil S. Aunario
 Maintainer: <jaunario at gmail.com>
 Description: [description]

Added: pkg/geoclimate/R/GSOD.r
===================================================================
--- pkg/geoclimate/R/GSOD.r	                        (rev 0)
+++ pkg/geoclimate/R/GSOD.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -0,0 +1,176 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date :  20 January 2012
+# Version 0.0.1
+# Licence GPL v3
+
+# Current ftp site
+GSOD.ftp <- "ftp://ftp.ncdc.noaa.gov/pub/data/gsod/"
+
+# Setup GSOD tables on Climate Schema
+GSOD.setup <- function(connectionstring){
+    # read station inventory
+    show.message("Reading station information from GSOD.",eol="\n")
+    stations <-  read.csv(paste(GSOD.ftp,"ish-history.csv",sep=""), stringsAsFactors=FALSE)
+    show.message("Parsing information.",eol="\n")
+    stations <- recodeMissing(stations,colnames(stations),"")
+    stations <- recodeMissing(stations,colnames(stations),"??")
+    
+    station_id <- 1:nrow(stations)
+    station_code <- paste(sprintf("%06d",stations$USAF),sprintf("%05d",stations$WBAN),sep="-")
+    
+    stations$LAT <- ifelse(stations$LAT > 90.0*1000|stations$LAT < -90.0*1000, NA, stations$LAT/1000)
+    stations$LON <- ifelse(stations$LON > 180*1000|stations$LON < -180*1000, NA, stations$LON/1000)
+    stations$ELEV..1M. <- ifelse(stations$ELEV..1M.==-99999|stations$ELEV..1M.==-999.999, NA, stations$ELEV..1M./10)
+    #stations$BEGIN[!is.na(stations$BEGIN)] <- paste(substr(stations$BEGIN[!is.na(stations$BEGIN)],1,4),substr(stations$BEGIN[!is.na(stations$BEGIN)],5,6),substr(stations$BEGIN[!is.na(stations$BEGIN)],7,8),sep="-")
+    #stations$BEGIN <- as.Date(stations$BEGIN)
+    stations$BEGIN <- NA
+    #stations$END[!is.na(stations$END)] <- paste(substr(stations$END[!is.na(stations$END)],1,4),substr(stations$END[!is.na(stations$END)],5,6),substr(stations$END[!is.na(stations$END)],7,8),sep="-")
+    #stations$END <- as.Date(stations$END)
+    stations$END  <- NA
+    stations <- cbind(station_id, station_code, stations[,-which(colnames(stations) %in% c("USAF","WBAN"))],stringsAsFactors=FALSE)
+    show.message("Connecting to geoclimate server.",eol="\n")
+    con <- odbcConnect(connectionstring)
+    show.message("Creating stations table.",eol="\n")
+    sqlQuery(con, "DROP TABLE IF EXISTS `stations`")
+    sqlQuery(con, paste(
+        "CREATE TABLE `stations` (",
+          "`station_id` int(11) NOT NULL,",
+          "`station_code` char(12) NOT NULL COMMENT 'USAF-WBAN',",          
+          "`stationname` varchar(50) DEFAULT NULL,",
+          "`ctry` char(2) DEFAULT NULL,",
+          "`fips` char(2) DEFAULT NULL,",
+          "`state` char(2) DEFAULT NULL,",
+          "`call` varchar(15) DEFAULT NULL,",
+          "`lat` DECIMAL(6,3) DEFAULT NULL,",
+          "`lon` DECIMAL(6,3) DEFAULT NULL,",
+          "`elev1m` DECIMAL(10,3) DEFAULT NULL,",
+          "`begin` DATE DEFAULT NULL,",
+          "`end` DATE DEFAULT NULL,",
+          "PRIMARY KEY (`station_id`)",
+        ") ENGINE=MyISAM"))
+    show.message("Sending station info to server.",eol="\n")
+    sqlSave(con, stations, rownames=FALSE, append=TRUE)
+    show.message("Creating gsod_xd datatable.",eol="\n")
+    sqlQuery(con, "DROP TABLE IF EXISTS `gsod_xd`")
+    sqlQuery(con, paste("CREATE TABLE `gsod_xd` (",
+          "`station_id` INT(11) NOT NULL,",
+          "`wdate` DATE NOT NULL,",
+          "`tavg` INT DEFAULT NULL,",
+          "`slpressure` INT DEFAULT NULL,",
+          "`stpressure` INT DEFAULT NULL,",
+          "`tdew` INT DEFAULT NULL,",
+          "`visibility` INT DEFAULT NULL,",
+          "`wind` INT DEFAULT NULL,",
+          "`maxswind` INT DEFAULT NULL,",
+          "`gust` INT DEFAULT NULL,",
+          "`tmax` INT DEFAULT NULL,",
+          "`tmin` INT DEFAULT NULL,",
+          "`prec` INT DEFAULT NULL,",
+          "`snowdepth` INT DEFAULT NULL,",
+          "`ifog` BOOLEAN DEFAULT NULL,",
+          "`irain` BOOLEAN DEFAULT NULL,",
+          "`isnow` BOOLEAN DEFAULT NULL,",
+          "`ihail` BOOLEAN DEFAULT NULL,",
+          "`ithunder` BOOLEAN DEFAULT NULL,",
+          "`itornado` BOOLEAN DEFAULT NULL",
+        ") ENGINE=MyIsam DEFAULT CHARSET=latin1"))
+    con <- odbcClose(con)
+    show.message("Ready for GSOD scraping",eol="\n")
+}
+
+GSOD.upload <- function(connectionstring, year, dldir=getwd()){
+    force.directories(dldir, recursive=TRUE)
+    
+    con <- odbcConnect(connectionstring)
+    stations <- sqlFetch(con, "stations", stringsAsFactors=FALSE)
+
+    tarfile <- paste(dldir, "/gsod_", year, ".tar", sep="")
+    dlstart <- Sys.time()
+    if(!file.exists(tarfile)) {
+        show.message("Downloading ", tarfile,eol="\n")
+        withRetry(download.file(paste(GSOD.ftp, year, "/gsod_", year, ".tar", sep=""), destfile=tarfile, mode='wb'))
+    }
+    dlend <- Sys.time()
+    gzdir <- paste(dldir, year, sep="/")
+    force.directories(gzdir, recursive=TRUE)
+    show.message("Decompressing gsod tar file",eol="\n")
+    untar(tarfile,verbose=FALSE, exdir=gzdir, extras="--no-same-owner")
+    gzfiles <- list.files(gzdir,pattern="*.*.gz")
+    #gfile <- gzfiles[1]
+    failed <- vector()
+    procstart <- Sys.time()
+    for (gfile  in gzfiles){
+        
+        show.message("Reading ", gfile,eol="\r")
+        
+        station_id <- stations$station_id[match(substr(gfile,1,12), stations$station_code)]
+        if(is.na(station_id)) {
+            failed <- c(failed, gfile)
+            next    
+        }
+        
+        gz <- gzfile(paste(gzdir,gfile,sep="/"))
+        dlines <- readLines(gz)
+        close(gz)
+        dlines <- gsub("\\*", "", dlines)
+        dlines[-1] <- gsub("[[:alpha:]]", "", dlines[-1])
+        dhdr <- unlist(strsplit(dlines[1], split="[[:space:]]+"))
+        ddata <- matrix(unlist(strsplit(dlines[-1], split="[[:space:]]+")),byrow=TRUE,ncol=22)
+        ddata <- ddata[,-c(5,7,9,11,13,15)]
+        if(is.null(nrow(ddata))) ddata <- t(ddata)
+        colnames(ddata) <- dhdr
+        
+        wdate <- as.Date(ddata[,"YEARMODA"],"%Y%m%d")                            
+        
+        gsod_xd <- as.data.frame(wdate)
+        
+        # CLEAN UP CLIMATE DATA
+        gsod_xd$tavg  <- ifelse(ddata[, "TEMP"]=="9999.9", NA, round((as.numeric(ddata[, "TEMP"])-32)*5/9,1)*10)  # MEAN TEMP
+        gsod_xd$slpressure   <- ifelse(ddata[,"SLP"]=="9999.9",  NA, as.numeric(ddata[, "SLP"])*10)  # SEA LEVEL PRESSURE
+        gsod_xd$stpressure   <- ifelse(ddata[,"STP"]=="9999.9",  NA, as.numeric(ddata[, "STP"])*10)  # STATION PRESSURE
+        gsod_xd$tdew  <- ifelse(ddata[,"DEWP"]=="9999.9", NA, round((as.numeric(ddata[, "DEWP"])-32)*5/9,1)*10)  # MEAN DEW POINT
+        gsod_xd$visibility <- ifelse(ddata[, "VISIB"]==999.9, NA, round((as.numeric(ddata[, "VISIB"]) * 1.609344),1)*10) # VISIBILITY
+        
+        ##############################################
+        # WINDSPEED NEEDED IN ORYZA2k
+        gsod_xd$wind  <- ifelse(ddata[, "WDSP"]=="999.9",  NA, round(as.numeric(ddata[, "WDSP"]) * 0.514444444,1)*10)  # WIND SPEED
+        gsod_xd$maxswind <- ifelse(ddata[, "MXSPD"]=="999.9", NA, round(as.numeric(ddata[, "MXSPD"]) * 0.514444444,1)*10)  # MAX SUSTAINED SPEED
+        gsod_xd$gust  <- ifelse(ddata[, "GUST"]=="999.9",  NA, round(as.numeric(ddata[, "GUST"]) * 0.514444444,1)*10)  # MAX GUST
+      
+        ##############################################
+        # MAX T NEEDED IN ORYZA2k
+        gsod_xd$tmax   <- ifelse(ddata[, "MAX"]=="9999",  NA, round((as.numeric(ddata[, "MAX"])-32)*5/9,1)*10)  # MAX T
+      
+        ##############################################
+        # MIN 2 NEEDED IN ORYZA2k
+        gsod_xd$tmin   <- ifelse(ddata[, "MIN"]=="9999",  NA, round((as.numeric(ddata[, "MIN"])-32)*5/9,1)*10)  # MIN T
+    
+        ##############################################
+        # RAINFALL NEEDED IN ORYZA2k
+        gsod_xd$prec   <- ifelse(ddata[, "PRCP"]=="99.9", NA, round(as.numeric(ddata[, "PRCP"])*100/25.4,1)*10)  # RAINFALL
+        
+        ##############################################
+        # SNOW DEPTH
+        gsod_xd$snowdepth   <- ifelse(ddata[, "SNDP"]=="999.9", NA, round(as.numeric(ddata[, "SNDP"])*100/25.4,1)*10)  # convert to mm
+        
+        indicators <- matrix(as.numeric(unlist(strsplit(ddata[, "FRSHTT"],""))),byrow=TRUE, ncol=6)
+        colnames(indicators) <- c("ifog","irain","isnow","ihail","ithunder","itornado") 
+        gsod_xd <- cbind(station_id, gsod_xd,indicators)
+        show.message("Uploading parsed data from ", stations$station_code[stations$station_id==station_id],eol="\r")
+        sqlSave(con,gsod_xd,rownames=FALSE, append=TRUE)
+        stations$begin[stations$station_id==station_id] <- min(stations$begin[stations$station_id==station_id],min(wdate),na.rm=TRUE)
+        stations$end[stations$station_id==station_id] <- max(stations$end[stations$station_id==station_id],max(wdate),na.rm=TRUE)
+        show.message("Updating station information",eol="\r")
+        sqlUpdate(con,stations[stations$station_id==station_id,],"stations")
+        show.message("Upload for station ", stations$station_code[stations$station_id==station_id], " done! (",as.character(min(wdate))," to ",as.character(max(wdate)),")",eol="\n")
+    }
+    procend <- Sys.time()    
+    gsodlog <- c(paste("Download Start:", dlstart),paste("Download End:",dlend),paste("Download time:", round(difftime(dlend,dlstart, unit="mins"),2),"mins.\n"),
+    paste("Process Start:", procstart),paste("Process End:",procend),paste("Process time:", round(difftime(procend,procstart, unit="mins"),2),"mins.\n"),
+    paste("Files in archive:", length(gzfiles)), paste("Files with no station info:", length(failed)),failed)
+    writeLines(gsodlog, paste(dldir,paste("gsod_log_",year,".txt",sep=""),sep="/"))
+    unlink(tarfile)                                                                                                
+    unlink(gzdir,recursive=TRUE)
+    # STATION UPDATE
+    con <- odbcClose(con)
+}   

Added: pkg/geoclimate/R/cccma.r
===================================================================
--- pkg/geoclimate/R/cccma.r	                        (rev 0)
+++ pkg/geoclimate/R/cccma.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -0,0 +1,40 @@
+#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
+#               
+#    }
+
+}

Deleted: pkg/geoclimate/R/dataframeutils.R
===================================================================
--- pkg/geoclimate/R/dataframeutils.R	2012-01-20 09:39:37 UTC (rev 12)
+++ pkg/geoclimate/R/dataframeutils.R	2012-01-20 09:40:57 UTC (rev 13)
@@ -1,39 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date :  30 April 2010
-# Version 0.0.1
-# Licence GPL v3
-
-cleanDframe <- function(dat, cols=colnames(dat), addcols=TRUE, rmOtherCols=TRUE){
-    miss <- cols[!cols %in% colnames(dat)]
-    if (addcols & length(miss)>0){
-        for (m in miss){
-            dat[,m] <- NA
-        }
-    } else if(!addcols & length(miss)>0){
-        return(FALSE)
-        stop("Missing Columns")
-    } 
-    dchk <- is.na(dat[,cols])
-    
-    if (nrow(dat)>0){
-        
-        if (length(cols)>1){
-            if(rmOtherCols){
-                dat <- dat[!rowSums(dchk)==length(cols),cols]
-            }else dat <- dat[!rowSums(dchk)==length(cols),]    
-        } else {
-            if(rmOtherCols){
-                dat <- dat[!dchk,cols]
-            }else dat <- dat[!dchk,]
-        }
-                
-    }    
-    return(dat)        
-}
-
-recodeMissing <- function(dat, cols, old, new=NA){
-    for (i in 1:length(cols)){
-        dat[dat[,cols[i]]==old,cols[i]] <- new
-    }
-    return(dat)
-}

Deleted: pkg/geoclimate/R/geoutils.r
===================================================================
--- pkg/geoclimate/R/geoutils.r	2012-01-20 09:39:37 UTC (rev 12)
+++ pkg/geoclimate/R/geoutils.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -1,78 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date :  22 September 2010
-# Version 0.0.1
-# Licence GPL v3
-
-dd2DMS <- function(dd, lat=T){
-    if (dd!=-99){
-        aDD <- abs(dd)
-        deg <- trunc(aDD)
-        dec <- aDD - deg
-        mn <- round(dec*60)
-        DMS <- paste(deg, mn)
-        if (lat & dd>0){                                
-            DMS <- paste(DMS, "N")
-        } else if (lat & dd<0){
-            DMS <- paste(DMS, "S")
-        } else if (!lat & dd>0){
-            DMS <- paste(DMS, "E")
-        } else {
-            DMS <- paste(DMS, "W")
-        }
-    } else {
-        DMS <- "-99."
-    }
-    return(DMS)
-}
-
-dms2DD <- function(dms, deg="d",minute="'", sec='"'){
-    dms <- trim(dms)
-    directions <- substr(dms, nchar(dms), nchar(dms))
-    #d <- try(substr(dms,1,regexpr(deg,dms)-1),...) 
-    d <- try(as.numeric(trim(substr(dms,1,regexpr(deg,dms)-1))))
-    d[which(is.na(d))] <- as.numeric(trim(substr(dms[which(is.na(d))],1,nchar(dms[which(is.na(d))])-1)))
-    m <- try(as.numeric(trim(substr(dms,regexpr(deg,dms)+1,regexpr(minute,dms)-1))))
-    m[is.na(m)] <- 0 
-    s <- try(as.numeric(trim(substr(dms,regexpr(minute,dms)+1,regexpr(sec,dms)-1))))
-    s[is.na(s)] <- 0
-    md <- s/60
-    dd <- d+((m+md)/60)
-    dd[!directions %in% c("N","E")] <- -dd[!directions %in% c("N","E")]
-    #if (!directions %in% c("N","E")) dd <- -dd  
-    return(dd)
-}
-
-#dd2UTM <- function(lat,lon){
-#    
-#}
-
-getISO2 <- function(lat, lon,retries=5){
-    cnt <- 0
-    iso2fetch <- FALSE
-    svcurl <- paste("http://ws.geonames.org/countryCode?lat=",lat,"&lng=",lon,"&username=demo&style=full",sep="")
-    #if (is.na(countries1[i])) next
-    #if (countries1[i] != i2[167]) next
-    while((class(iso2fetch)=="try-error" | class(iso2fetch)=="logical") & cnt<retries){
-        cat(svcurl,"\n")
-        flush.console()
-        iso2fetch <- try(scan(svcurl, what='character', quiet=TRUE),silent=TRUE)
-        if (class(iso2fetch)=="try-error"){
-            cnt <- cnt+1
-            cat("Webservice failure on ",svcurl ,".\n Retries ", cnt,". (Will skip after 5th try) \n", sep="")
-            flush.console();
-        } else if (class(iso2fetch)=="character"){
-            if(length(iso2fetch)>1){
-                iso2fetch <- ""
-            } else {
-                if (nchar(iso2fetch)>1){
-                    cnt <- cnt+1
-                    cat("Webservice failure on ",svcurl ,".\n Retries ", cnt,". (Will skip after 5th try) \n", sep="")
-                    flush.console();
-                    iso2fetch <- FALSE
-                }
-            }
-        }   
-    }
-    if (cnt>=retries) iso2fetch <- NA
-    return(iso2fetch)         
-}

Modified: pkg/geoclimate/R/nasa.r
===================================================================
--- pkg/geoclimate/R/nasa.r	2012-01-20 09:39:37 UTC (rev 12)
+++ pkg/geoclimate/R/nasa.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -3,67 +3,76 @@
 # Version 0.0.1
 # Licence GPL v3
 
-uploadNASA <- function(con, setname, cell, stdate="1983-1-1", enddate=Sys.Date(), update=TRUE, reupload=FALSE, savefile=FALSE, savedir=".", verbose=TRUE){
+getNASA <- function(cell, stdate="1983-1-1", enddate=Sys.Date(), savefile=TRUE, savedir=".", redownload=FALSE){
+    fname <- paste("nasa_",cell,".txt", sep="")
     
-    success <- FALSE
-    
     stdate <- as.Date(stdate)
     enddate <- as.Date(enddate)
-    
-    fname <- paste("nasa_",cell,".txt", sep="")
-    
-    if (!update){
-        sqlQuery(con, paste("DELETE FROM",setname, "WHERE cell =",cell))
-        stdate <- as.Date("1983-1-1") 
-        reupload <- FALSE
-    } 
-            
-    if (fname %in% list.files(savedir,pattern="nasa.*.txt") & !reupload){
-        show.message(paste(cell, "done"), eol="\n")
-        success <- TRUE
-        return(success)
-    } else if(fname %in% list.files(savedir,pattern="nasa.*.txt") & reupload){
-        show.message(paste("Reading ", fname, sep=""), eol="\n")
-        dlines <- readLines(paste(savedir,fname,sep="/"))                
+
+    #if (fname %in% list.files(savedir,pattern="nasa.*.txt") & !reupload){
+    #    show.message(paste(cell, "done"), eol="\n")
+    #    success <- TRUE
+    #    return(success)
+    #} else if(fname %in% list.files(savedir,pattern="nasa.*.txt") & reupload){
+    #    show.message(paste("Reading ", fname, sep=""), eol="\n")
+    #                   
+    #} else {        
+    #    if (verbose) show.message(paste("Downloading: Cell# ", cell," (",xy[1,"y"],",",xy[1,"x"], ")", sep=""), eol="\n")
+    #    dlines <- readURL(paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",xy[1,"y"],"&lon=",xy[1,"x"],"&ms=",monthFromDate(stdate),"&ds=",dayFromDate(stdate),"&ys=",yearFromDate(stdate),"&me=",monthFromDate(enddate),"&de=",dayFromDate(enddate),"&ye=",yearFromDate(enddate),"&p=swv_dwn&p=T2M&p=T2MN&p=T2MX&p=RH2M&p=DFP2M&p=RAIN&p=WS10M&submit=Submit", sep=""), verbose=TRUE)
+    #}
+
+    if(file.exists(paste(savedir,fname,sep="/")) & !redownload) {
+        dlines <- readLines(paste(savedir,fname,sep="/"))
     } else {
         xy <- xyFromCell(raster(),cell)
-        if (verbose) show.message(paste("Downloading: Cell# ", cell," (",xy[1,"y"],",",xy[1,"x"], ")", sep=""), eol="\n")
         dlines <- readURL(paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",xy[1,"y"],"&lon=",xy[1,"x"],"&ms=",monthFromDate(stdate),"&ds=",dayFromDate(stdate),"&ys=",yearFromDate(stdate),"&me=",monthFromDate(enddate),"&de=",dayFromDate(enddate),"&ye=",yearFromDate(enddate),"&p=swv_dwn&p=T2M&p=T2MN&p=T2MX&p=RH2M&p=DFP2M&p=RAIN&p=WS10M&submit=Submit", sep=""), verbose=TRUE)
+    }  
+    
+    if (savefile){
+        force.directories(savedir, recursive=TRUE)
+        writeLines(dlines, paste(savedir,"/nasa_",cell,".txt",sep=""))  
     }
-    
-    #Check completeness of data
+
     endline <- grep(paste(yearFromDate(enddate),format(doyFromDate(enddate),width=3)), dlines)
     if(length(dlines)==0 | length(endline)==0){
-        if (verbose) show.message("Empty or Incomplete data.", eol="\n")
+        if (verbose) warning("Empty or Incomplete data.")
         if (file.exists(paste(savedir,"/nasa_",cell,".txt",sep=""))) file.remove(paste(savedir,"/nasa_",cell,".txt",sep=""))        
     } else {
-        if (savefile){
-            force.directories(savedir, recursive=TRUE)
-            writeLines(dlines, paste(savedir,"/nasa_",cell,".txt",sep=""))  
-        } 
+        ehdr <- grep("-END HEADER-", dlines)
+        #hdr <- grep("YEAR DOY swv_dwn     T2M    T2MN    T2MX    RH2M   DFP2M    RAIN   WS10M", dlines)    
 
-        hdr <- grep("YEAR DOY swv_dwn     T2M    T2MN    T2MX    RH2M   DFP2M    RAIN   WS10M", dlines)    
-
-        if (length(hdr)==0){
+        if (length(ehdr)==0){
             if (verbose) show.message("Unrecognized format.", eol="\n")
             if (file.exists(paste(savedir,"/nasa_",cell,".txt",sep=""))) file.remove(paste(savedir,"/nasa_",cell,".txt",sep=""))
         }
 
-        dlines <- dlines[(hdr+1):endline]
-        dvector <- unlist(strsplit(dlines, " "))
-        dvector <- dvector[dvector!=""]
+        dlines <- dlines[(ehdr+1):endline]
+        dvector <- unlist(strsplit(gsub("[[:space:]]+"," ",dlines), " "))
         dvector[dvector=="-"] <- NA
-        ddframe <- as.data.frame(matrix(as.numeric(dvector), ncol=10, byrow=TRUE))
-        colnames(ddframe) <- c("yr", "doy", "srad", "tavg", "tmin", "tmax", "rh2m", "tdew", "prec", "wind")
-        ddframe <- cleanDframe(ddframe, cols=colnames(ddframe)[-(1:2)], rmOtherCols=FALSE)
-        wdate <- as.character(dateFromDoy(ddframe$doy, ddframe$yr))
-        id <- 0
-        forupload <- cbind(id, cell, wdate, ddframe[,-(1:2)], stringsAsFactors=FALSE)
-        if (verbose) show.message(paste("Uploading Records #", nrow(forupload), sep=""), eol="\n")
+        nasadata <- as.data.frame(matrix(as.numeric(dvector), ncol=10, byrow=TRUE))
+        colnames(nasadata) <- c("yr", "doy", "srad", "tavg", "tmin", "tmax", "rh2m", "tdew", "prec", "wind")
+        nasadata <- cleanDframe(nasadata, cols=colnames(nasadata)[-(1:2)], rmOtherCols=FALSE)
+        wdate <- as.character(dateFromDoy(nasadata$doy, nasadata$yr))
+        nasadata <- cbind(cell, wdate, nasadata[,-(1:2)], stringsAsFactors=FALSE)
+        rm(dlines,dvector)
+        gc(verbose=FALSE)
+    }           
+    return(nasadata) 
+}
 
-        try1 <- 1
+uploadNASA <- function(con, setname, update=TRUE, verbose=TRUE, ...){
+    
+    success <- FALSE
+    #forupload <- cbind(0,getNASA(...))
+    if (!update){
+        sqlQuery(con, paste("DELETE FROM",setname, "WHERE cell =",cell))
+    } 
+    id <- 0                
+    forupload <- cbind(id,getNASA(...))
+    if (verbose) show.message(paste("Uploading Records #", nrow(forupload), sep=""), eol="\n")
+    try1 <- 1
         repeat {
-            uploaded <- try(sqlSave(con, forupload, setname,rownames=FALSE, append=TRUE, fast=FALSE), silent=!verbose)
+            uploaded <- try(sqlSave(con, forupload, setname,rownames=FALSE, append=TRUE, fast=TRUE), silent=!verbose)
             if (class(uploaded)!="try-error"){
                 success <- TRUE
                 break
@@ -74,8 +83,7 @@
                 break
             }
         }
-        rm(dlines,dvector,ddframe,forupload)
-        gc(verbose=FALSE)
-    }           
+    #Check completeness of data
     return(success)    
 }
+

Deleted: pkg/geoclimate/R/sysutils.r
===================================================================
--- pkg/geoclimate/R/sysutils.r	2012-01-20 09:39:37 UTC (rev 12)
+++ pkg/geoclimate/R/sysutils.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -1,54 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date :  22 February 2011
-# Version 0.0.1
-# Licence GPL v3
-
-show.message <- function(..., eol=NULL){
-    cat(...,eol,sep="")
-    flush.console()
-}
-
-openURL <- function(urlstr, retries=1, verbose=FALSE){
-    myurl <- url(urlstr)
-    tries <- 1
-    repeat{
-        if (verbose){
-            show.message(paste("Connecting to \n",urlstr, "(", retries, ")",sep=""), eol="\n")
-        }
-        try(open(myurl), silent=!verbose)
-        if (isOpen(myurl)){
-            break
-        } else if (tries>retries){
-            if(verbose) show.message("Connection Failed") 
-            break   
-        } else {
-            tries <- tries + 1
-        }    
-    }
-    return(myurl)
-}
-
-readURL <- function(urlstr, retries=1, verbose=FALSE){
-    lines <- character(0)
-    tries <- 1
-    repeat{
-        if (verbose){
-            show.message(paste("Connecting to \n",urlstr, "(", retries, ")",sep=""), eol="\n")
-        }
-        lines <- try(readLines(urlstr), silent=!verbose)
-        if (class(lines)=="try-error"){
-            tries <- tries + 1
-        } else {
-            break
-        }    
-    }
-    return(lines)    
-}
-
-force.directories <- function(path,...){
-    
-    if(!file.exists(path)){
-        success <- dir.create(path,...)  
-    } else success <- TRUE
-    return(success)
-}

Added: pkg/geoclimate/R/trmm.r
===================================================================
--- pkg/geoclimate/R/trmm.r	                        (rev 0)
+++ pkg/geoclimate/R/trmm.r	2012-01-20 09:40:57 UTC (rev 13)
@@ -0,0 +1,108 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date :  20 January 2012
+# Version 0.0.1
+# Licence GPL v3
+
+#reading hdf
+
+downloadTRMM.monthly <- function(month=1,year=1998, outfile="", var="pcp"){
+    if (!require(ncdf)) stop("Package ncdf not found.")
+    doy <- doyFromDate(paste(year,month,1,sep="-"))
+    if (year<2007){
+        fname <- paste("3B43.",substr(year,3,4),serialn(month,width=2),"01.6",sep="")
+        src <- paste("http://disc2.nascom.nasa.gov/daac-bin/OTF/HTTP_services.cgi?FILENAME=%2Fdata%2Fs4pa%2FTRMM_L3%2FTRMM_3B43%2F", year,"%2F",serialn(doy, width=3),"%2F",fname,".HDF&LABEL=",fname,".nc&SHORTNAME=TRMM_3B43&SERVICE=HDF_TO_NetCDF&VERSION=1.02", sep="")    
+    } else {
+        fname <- ifelse(year==2007, paste("3B43.",substr(year,3,4),serialn(month,width=2),"01.6",sep=""),paste("3B43.",substr(year,3,4),serialn(month,width=2),"01.6A",sep="")) 
+        src <- paste("http://disc2.nascom.nasa.gov/daac-bin/OTF/HTTP_services.cgi?FILENAME=%2Fftp%2Fdata%2Fs4pa%2FTRMM_L3%2FTRMM_3B43%2F", year,"%2F",serialn(doy, width=3),"%2F",fname,".HDF&LABEL=",fname,".nc&SHORTNAME=TRMM_3B43&SERVICE=HDF_TO_NetCDF&VERSION=1.02", sep="")        
+    }
+    outfile <- ifelse(outfile=="",paste(fname,".nc",sep=""), outfile)
+    
+    download.file(src, outfile, method="internal", mode="wb")
+    traster <- raster(outfile, varname=var)
+    if (month %in% c(1,3,5,7,8,10,12)){
+        multiplier <- 24*31
+    } else if (month==2){
+        multiplier <- ifelse(isLeapYear(year),24*29,24*28)
+    } else {
+        multiplier <- 24*30
+    }
+    traster <- traster*multiplier
+    return(traster)
+}
+
+downloadTRMM.daily <- function(wdate, outfile=""){
+    if (!require(ncdf)) stop("Package ncdf not found.")
+    wdate <- as.Date(wdate)
+    prevday <- wdate-1
+    doy <- doyFromDate(prevday)
+    fname <- paste("3B42_daily.",format.Date(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",yearFromDate(prevday),"%2F",serialn(doy, width=3),"%2F3B42_daily.",format.Date(wdate, "%Y.%m.%d"),".6.bin&LABEL=3B42_daily.",format.Date(wdate, "%Y.%m.%d"),".6.nc&SHORTNAME=TRMM_3B42_daily&SERVICE=HDF_TO_NetCDF&VERSION=1.02",sep="")
+    outfile <- ifelse(outfile=="", fname, outfile)
+    if (!file.exists(outfile)){
+        download.file(src, outfile, method="internal", mode="wb")    
+    }
+    return(raster(outfile))
+}
+
+#yrs <- 1998:2010
+#mos <- 1:12
+#for (yr in yrs){
+#    for (mo in mos){
+#        prec <- downloadTRMM.monthly(month=mo,year=yr)        
+#    }
+#} 
+
+
+outdir <- "D:/projects/Climate/Database/Source/TRMM"
+
+years <- 1998:2011
+failed <- vector()
+msql <- odbcConnect("geoclimadmin")
+sqlClear(msql, "trmm_15m")
+sqlQuery(msql, "ALTER TABLE trmm_15m DISABLE KEYS")
+base15m <- disaggregate(raster(),fact=4)
+for (yr in years){
+    if(yr==2011){
+        dates <- seq.Date(from=as.Date(paste(yr,"-1-1", sep="")), to=as.Date(paste(yr,"-6-30", sep="")), by="day")
+    } else {
+        dates <- seq.Date(from=as.Date(paste(yr,"-1-1", sep="")), to=as.Date(paste(yr,"-12-31", sep="")), by="day")    
+    }
+    
+    for (i in 1:length(dates)){
+        dt <- dates[i]
+        show.message("Processing TRMM data for ",as.character(dt), eol="\n")
+        fname <- paste(outdir,paste("3B42_daily.",format.Date(as.Date(dt), "%Y.%m.%d"),".6.nc", sep=""),sep="/")
+        if (file.exists(fname)) {
+            show.message("Reading ",basename(fname), eol="\n")
+            rain <- raster(fname)
+        } else {
+            rain <- try(downloadTRMM.daily(dt, outfile=fname))    
+        }
+        
+        if (class(rain)=="try-error"){
+            next
+        } else {
+            #rain100 <- aggregate(rain25, fact=4)
+            trmm <- as.data.frame(rep("default", ncell(rain)),stringsAsFactors=FALSE)
+            colnames(trmm) <- "id"
+            xy <- xyFromCell(rain, 1:ncell(rain))
+            xy[xy[,"x"]>180,"x"] <- xy[xy[,"x"]>180,"x"]-360 
+            trmm$cell <- cellFromXY(base15m,xy)
+            trmm$wdate <- as.character(dt)
+            show.message("Retrieving values from ", basename(fname), eol="\n")
+            trmm$prec <- round(values(rain),2)
+            show.message("Uploading ", nrow(trmm), " records to trmm_15m.", eol="\n")
+            if(class(try(sqlSave(msql,trmm,"trmm_15m",append=TRUE, rownames=FALSE)))=="try-error"){
+              show.message("Uploaded ", basename(fname), eol="\n")
+              failed <- c(failed,dt)
+              next  
+            }  
+            show.message("Uploaded ", basename(fname), eol="\n")            
+        }
+    }
+}
+sqlQuery(msql, "ALTER TABLE trmm_15m ENABLE KEYS")
+odbcCloseAll()
+
+
+



More information about the Rodbcext-commits mailing list