[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