[Rodbcext-commits] r14 - in pkg: . genutils genutils/R geoclimate geoclimate/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 14 07:11:17 CET 2012
Author: jaunario
Date: 2012-03-14 07:11:17 +0100 (Wed, 14 Mar 2012)
New Revision: 14
Added:
pkg/genutils/R/logutils.R
pkg/genutils/R/mathutils.r
pkg/genutils/R/stringutils.r
pkg/geoclimate/
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/cccma.r
pkg/geoclimate/R/gsod.r
pkg/geoclimate/R/nasa.r
pkg/geoclimate/R/setup.r
pkg/geoclimate/R/trmm.r
pkg/geoclimate/R/upload.r
Removed:
pkg/geoclimate/
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/dataframeutils.R
pkg/geoclimate/R/geoutils.r
pkg/geoclimate/R/nasa.r
pkg/geoclimate/R/sysutils.r
Modified:
pkg/genutils/
pkg/genutils/R/dataframeutils.R
pkg/genutils/R/geoutils.r
pkg/genutils/R/sysutils.r
Log:
standardized names, syntax of geoclimate functions
reorganized genutils functions
Property changes on: pkg/genutils
___________________________________________________________________
Added: svn:ignore
+ *.Rbuildignore
*.Rhistory
*.Rproj
*.user
Modified: pkg/genutils/R/dataframeutils.R
===================================================================
--- pkg/genutils/R/dataframeutils.R 2012-01-20 09:40:57 UTC (rev 13)
+++ pkg/genutils/R/dataframeutils.R 2012-03-14 06:11:17 UTC (rev 14)
@@ -3,7 +3,7 @@
# Version 0.0.1
# Licence GPL v3
-cleanDframe <- function(dat, cols=colnames(dat), addcols=TRUE, rmOtherCols=TRUE){
+clean.dataframe <- function(dat, cols=colnames(dat), addcols=TRUE, rmOtherCols=TRUE){
miss <- cols[!cols %in% colnames(dat)]
if (addcols & length(miss)>0){
for (m in miss){
@@ -33,7 +33,9 @@
recodeMissing <- function(dat, cols, old, new=NA){
for (i in 1:length(cols)){
- dat[dat[,cols[i]]==old,cols[i]] <- new
+ change <- which(dat[,cols[i]]==old)
+ if(length(change)>0) dat[change,cols[i]] <- new
}
return(dat)
}
+
Modified: pkg/genutils/R/geoutils.r
===================================================================
--- pkg/genutils/R/geoutils.r 2012-01-20 09:40:57 UTC (rev 13)
+++ pkg/genutils/R/geoutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -4,23 +4,19 @@
# 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")
- }
+ 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 <- "-99."
+ DMS <- paste(DMS, "W")
}
return(DMS)
}
Added: pkg/genutils/R/logutils.R
===================================================================
--- pkg/genutils/R/logutils.R (rev 0)
+++ pkg/genutils/R/logutils.R 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,22 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 21 February 2012
+# Version 0.0.1
+# Licence GPL v3
+
+show.message <- function(..., EL=FALSE, delay=0){
+ # Real-time console messages
+ if (EL){
+ message(rep(" ", options("width")),"\r", appendLF=FALSE)
+ }
+ message(...)
+ Sys.sleep(delay)
+ flush.console()
+}
+
+timer.message <- function(text, time){
+ if(is.numeric(time)){
+ for (i in time:1){
+ show.message(text, i,"\r", EL=TRUE, delay=1, appendLF=FALSE)
+ }
+ }
+}
Added: pkg/genutils/R/mathutils.r
===================================================================
--- pkg/genutils/R/mathutils.r (rev 0)
+++ pkg/genutils/R/mathutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,8 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 21 February 2012
+# Version 0.0.1
+# Licence GPL v3
+
+rescale <- function(x, oldmin, oldmax, newmin, newmax){
+ return((x-oldmin)*(newmax-newmin)/(oldmax-oldmin) + newmin)
+}
Added: pkg/genutils/R/stringutils.r
===================================================================
--- pkg/genutils/R/stringutils.r (rev 0)
+++ pkg/genutils/R/stringutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,14 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 21 February 2012
+# Version 0.0.1
+# Licence GPL v3
+
+strToChar <- function(str){
+ return(unlist(strsplit(str,"")))
+}
+
+serialn <- function(x, width=2){
+ # Just use sprintf
+ return(sprintf(paste("%0",width,"d",sep=""),x))
+}
+
Modified: pkg/genutils/R/sysutils.r
===================================================================
--- pkg/genutils/R/sysutils.r 2012-01-20 09:40:57 UTC (rev 13)
+++ pkg/genutils/R/sysutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -3,9 +3,22 @@
# Version 0.0.1
# Licence GPL v3
-serialn <- function(x, width=2){
- #TODO just use sprintf
- return(sprintf(paste("%0",width,"d",sep=""),x))
+withRetry <- function(expr, retries=5, delay=60, inc.delay=TRUE){
+ tries <- 0
+ success <- FALSE
+ while(success==FALSE & tries<retries){
+ items <- try(expr,silent=TRUE)
+ if (class(items)=="try-error"){
+ show.message(items,appendLF=FALSE)
+ tries <- tries+1
+ tdelay <- ifelse(inc.delay,delay*tries,delay)
+
+ } else {
+ success <- TRUE
+ }
+ }
+ if (!success) items <- vector()
+ return(items)
}
openURL <- function(urlstr, retries=1, verbose=FALSE){
@@ -45,42 +58,9 @@
return(lines)
}
-show.message <- function(..., eol="", sleeptime=0){
- cat(rep(" ", options("width")),"\r",sep="")
- cat(...,eol,sep="")
- flush.console()
- Sys.sleep(sleeptime)
-}
-
force.directories <- function(path,...){
-
if(!file.exists(path)){
success <- dir.create(path,...)
} else success <- TRUE
return(success)
}
-
-withRetry <- function(expr, retries=10, initpause=30, failtime=10){
- tries <- 0
- success <- FALSE
- while(success==FALSE & (tries<retries | failtime>(initpause*tries))){
- items <- try(expr,silent=TRUE)
- if (class(items)=="try-error"){
- tries <- tries+1
- show.message("Timeout? trying again in ", (initpause*tries) ," secs...", eol="\n")
- Sys.sleep(initpause*tries)
- } else {
- success <- TRUE
- }
- }
- if (!success) items <- vector()
- return(items)
-}
-
-strToChar <- function(str){
- return(unlist(strsplit(str,"")))
-}
-
-rescale <- function(x, oldmin, oldmax, newmin, newmax){
- return((x-oldmin)*(newmax-newmin)/(oldmax-oldmin) + newmin)
-}
Deleted: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2011-06-11 09:23:19 UTC (rev 11)
+++ pkg/geoclimate/DESCRIPTION 2012-03-14 06:11:17 UTC (rev 14)
@@ -1,11 +0,0 @@
-Package: geoclimate
-Type: Package
-Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.1
-Date: 2009-2-24
-Depends: methods, rodbcExt, weather
-Author: Jorrel Khalil S. Aunario
-Maintainer: <jaunario at gmail.com>
-Description: [description]
-License: GPL (>=2)
-LazyLoad: yes
Copied: pkg/geoclimate/DESCRIPTION (from rev 13, pkg/geoclimate/DESCRIPTION)
===================================================================
--- pkg/geoclimate/DESCRIPTION (rev 0)
+++ pkg/geoclimate/DESCRIPTION 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,12 @@
+Package: geoclimate
+Type: Package
+Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
+Version: 0.0.3
+Date: 2009-2-24
+Depends: methods, genutils, weather
+Suggests: RODBC, ncdf, RCurl
+Author: Jorrel Khalil S. Aunario
+Maintainer: <jaunario at gmail.com>
+Description: [description]
+License: GPL (>=2)
+LazyLoad: yes
Copied: pkg/geoclimate/R/cccma.r (from rev 13, pkg/geoclimate/R/cccma.r)
===================================================================
--- pkg/geoclimate/R/cccma.r (rev 0)
+++ pkg/geoclimate/R/cccma.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -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 2011-06-11 09:23:19 UTC (rev 11)
+++ pkg/geoclimate/R/dataframeutils.R 2012-03-14 06:11:17 UTC (rev 14)
@@ -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 2011-06-11 09:23:19 UTC (rev 11)
+++ pkg/geoclimate/R/geoutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -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)
-}
Copied: pkg/geoclimate/R/gsod.r (from rev 13, pkg/geoclimate/R/GSOD.r)
===================================================================
--- pkg/geoclimate/R/gsod.r (rev 0)
+++ pkg/geoclimate/R/gsod.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,89 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 20 January 2012
+# Version 0.0.1
+# Licence GPL v3
+
+# Current ftp site
+
+get.gsod <- function(year, station, savepath=getwd(), rm.existing=FALSE){
+ result <- vector()
+
+ GSOD.ftp <- "ftp://ftp.ncdc.noaa.gov/pub/data/gsod"
+ GSOD.varrefs <- read.csv(system.file("gsod_ref.csv", package="geoclimate"), stringsAsFactors=FALSE)
+
+ if(!force.directories(savepath, recursive=TRUE)){
+ show.message("Error: Can't create download path.", appendLF=TRUE)
+ } else if(!require(RCurl)){
+ show.message("Error: RCurl package not found.", appendLF=TRUE)
+ } else {
+ fname <- paste(station,"-",year,".op.gz", sep="")
+ ftpurl <- paste(GSOD.ftp, year, fname, sep="/")
+ available <- withRetry(getURL(paste(GSOD.ftp,"/",year,"/",sep="")))
+ if (!grepl(station, available)){
+ show.message("Data not available on ", station, " for year ", year,".", appendLF=TRUE)
+ } else {
+ dl.success <- withRetry(download.file(ftpurl, destfile=paste(savepath,fname, sep="/"), mode="wb"))
+
+ # Parse the gsod file if successfully downloaded
+ if (dl.success==0){
+ gz <- gzfile(paste(savepath,fname,sep="/"))
+ dlines <- readLines(gz)
+ close(gz)
+
+ #Parsing the GSOD file
+ for (i in 1:14){
+ assign(GSOD.varrefs$variable[i], trim(substr(dlines[-1], GSOD.varrefs$stpos[i], GSOD.varrefs$enpos[i])))
+ if(!is.na(GSOD.varrefs$missing[i])) {
+ tmp <- get(GSOD.varrefs$variable[i])
+ tmp[tmp==as.character(GSOD.varrefs$missing[i])] <- NA
+ assign(GSOD.varrefs$variable[i],tmp)
+ }
+ }
+
+ wdate <- as.Date(YEARMODA,"%Y%m%d")
+ gsod <- as.data.frame(wdate)
+
+ # CLEAN UP CLIMATE DATA
+ gsod$tavg <- round(FtoC(as.numeric(TEMP)),1)*10 # MEAN TEMP
+ gsod$slpressure <- as.numeric(SLP)*10 # SEA LEVEL PRESSURE
+ gsod$stpressure <- as.numeric(STP)*10 # STATION PRESSURE
+ gsod$tdew <- round(FtoC(as.numeric(DEWP)),1)*10 # MEAN DEW POINT
+ gsod$visibility <- round((as.numeric(VISIB) * 1.609344),1)*10 # VISIBILITY
+
+ ##############################################
+ # WINDSPEED NEEDED IN ORYZA2k
+ gsod$wind <- round(as.numeric(WDSP) * 0.514444444,1)*10 # WIND SPEED
+ gsod$maxwind <- round(as.numeric(MXSPD) * 0.514444444,1)*10 # MAX SUSTAINED SPEED
+ gsod$gust <- round(as.numeric(GUST) * 0.514444444,1)*10 # MAX GUST
+
+ ##############################################
+ # MAX T NEEDED IN ORYZA2k
+ gsod$tmax <- round(FtoC(as.numeric(MAX)),1)*10 # MAX T
+
+ ##############################################
+ # MIN 2 NEEDED IN ORYZA2k
+ gsod$tmin <- round(FtoC(as.numeric(MIN)),1)*10 # MIN T
+
+ ##############################################
+ # RAINFALL NEEDED IN ORYZA2k
+ gsod$prec <- round(as.numeric(PRCP)*100/25.4,1)*10 # RAINFALL
+
+ ##############################################
+ # SNOW DEPTH
+ gsod$snowdepth <- round(as.numeric(SNDP)*100/25.4,1)*10 # convert to mm
+
+ indicators <- matrix(as.numeric(unlist(strsplit(FRSHTT,""))),byrow=TRUE, ncol=6)
+ colnames(indicators) <- c("ifog","irain","isnow","ihail","ithunder","itornado")
+ gsod <- cbind(gsod, indicators, stringsAsFactors=FALSE)
+ result <- new('weather')
+ result at stn <- station
+ result at lon <- x
+ result at lat <- y
+ result at alt <- alt
+ result at w <- gsod
+ }
+ }
+
+ }
+ return(result)
+}
Deleted: pkg/geoclimate/R/nasa.r
===================================================================
--- pkg/geoclimate/R/nasa.r 2011-06-11 09:23:19 UTC (rev 11)
+++ pkg/geoclimate/R/nasa.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -1,81 +0,0 @@
-# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
-# Date : 22 February 2011
-# 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){
-
- 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="/"))
- } 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)
- }
-
- #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 (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=""))
- }
-
- hdr <- grep("YEAR DOY swv_dwn T2M T2MN T2MX RH2M DFP2M RAIN WS10M", dlines)
-
- if (length(hdr)==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!=""]
- 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")
-
- try1 <- 1
- repeat {
- uploaded <- try(sqlSave(con, forupload, setname,rownames=FALSE, append=TRUE, fast=FALSE), silent=!verbose)
- if (class(uploaded)!="try-error"){
- success <- TRUE
- break
- } else if (try1 < 2){
- con <- odbcReConnect(con)
- try1 <- try1+1
- } else {
- break
- }
- }
- rm(dlines,dvector,ddframe,forupload)
- gc(verbose=FALSE)
- }
- return(success)
-}
Copied: pkg/geoclimate/R/nasa.r (from rev 13, pkg/geoclimate/R/nasa.r)
===================================================================
--- pkg/geoclimate/R/nasa.r (rev 0)
+++ pkg/geoclimate/R/nasa.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,63 @@
+# 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, stdate="1983-1-1", endate=Sys.Date(), savepath=getwd(), rm.existing=FALSE){
+ result <- vector()
+ 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]
+ }
+ if(!force.directories(savepath)) {
+ show.message("Error: Cannot create ", savepath, appendLF=TRUE)
+ } else {
+ stdate <- as.Date(stdate)
+ endate <- as.Date(endate)
+
+ fname <- paste(savepath, paste(paste("nasa",x,y,format(stdate,"%Y.%m.%d"),format(endate,"%Y.%m.%d"), sep="_"), ".txt",sep=""), 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="")
+
+ show.message("Reading ", appendLF=FALSE)
+ if (!file.exists(fname)){
+ show.message(dlurl, appendLF=TRUE)
+ dlines <- withRetry(readLines(dlurl))
+ } else if (rm.existing | file.info(fname)$size==0){
+ file.remove(fname)
+ show.message(dlurl, appendLF=TRUE)
+ dlines <- withRetry(readLines(dlurl))
+ } else {
+ show.message(fname, appendLF=TRUE)
+ dlines <- readLines(fname)
+ }
+
+ if (length(dlines)==0){
+ stline <- endline <- vector()
+ } else {
+ 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)!=0 & length(endline)!=0) {
+ writeLines(dlines, fname)
+ alt <- as.numeric(unlist(strsplit(dlines[grep("Elevation", dlines)],"="))[2])
+ dlines <- dlines[stline:endline]
+ dvector <- unlist(strsplit(gsub("[[:space:]]+"," ",dlines), " "))
+ dvector[dvector=="-"] <- NA
+ 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")
+ wdate <- format(as.Date(paste(nasadata$yr,nasadata$doy),"%Y %j"),"%Y-%m-%d")
+ nasadata <- cbind(wdate, nasadata[,-(1:2)], stringsAsFactors=FALSE)
+ result <- new('weather')
+ result at stn <- as.character(cellFromXY(raster(),t(c(x,y))))
+ result at lon <- x
+ result at lat <- y
+ result at alt <- alt
+ result at w <- nasadata
+ rm(dlines,dvector,nasadata)
+ gc(verbose=FALSE)
+ }
+ }
+ return(result)
+}
Added: pkg/geoclimate/R/setup.r
===================================================================
--- pkg/geoclimate/R/setup.r (rev 0)
+++ pkg/geoclimate/R/setup.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,79 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 7 March 2012
+# Version 0.0.1
+# Licence GPL v3
+
+# Setup GSOD tables on Climate Schema
+setup.GSOD <- function(connectionstring, setname="gsod_xd", stationtable="stations"){
+ # 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),old="")
+ stations <- recodeMissing(stations,colnames(stations),old="??")
+
+ 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)
+ stations$nasa_pixel <- cellFromXY(raster(),stations[, c("LON","LAT")])
+
+ show.message("Connecting to geoclimate server.",eol="\n")
+ con <- odbcConnect(connectionstring)
+ show.message("Creating stations table.",eol="\n")
+ sqlQuery(con, paste("DROP TABLE IF EXISTS `",stationtable,"`",sep=""))
+ sqlQuery(con, paste(
+ "CREATE TABLE `",stationtable,"` (",
+ "`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,",
+ "`nasa_pixel` INT(5) DEFAULT NULL,",
+ "PRIMARY KEY (`station_id`)",
+ ") ENGINE=MyISAM"))
+ show.message("Sending station info to server.",eol="\n")
+ sqlSave(con, stations,tablename=stationtable, rownames=FALSE, append=TRUE)
+ show.message("Creating `",setname,"` datatable.",eol="\n")
+ sqlQuery(con, paste("DROP TABLE IF EXISTS `",setname,"`"))
+ sqlQuery(con, paste("CREATE TABLE `",setname,"` (",
+ "`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,",
+ "`maxwind` 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", sep=""))
+ con <- odbcClose(con)
+ show.message("Ready for GSOD scraping",eol="\n")
+}
Deleted: pkg/geoclimate/R/sysutils.r
===================================================================
--- pkg/geoclimate/R/sysutils.r 2011-06-11 09:23:19 UTC (rev 11)
+++ pkg/geoclimate/R/sysutils.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -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)
-}
Copied: pkg/geoclimate/R/trmm.r (from rev 13, pkg/geoclimate/R/trmm.r)
===================================================================
--- pkg/geoclimate/R/trmm.r (rev 0)
+++ pkg/geoclimate/R/trmm.r 2012-03-14 06:11:17 UTC (rev 14)
@@ -0,0 +1,82 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 20 February 2012
+# Version 0.0.2
+# Licence GPL v3
+
+
+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 (!force.directories(savepath, recursive=TRUE)){
+ show.message("Error: Cannot create ", savepath, ".", appendLF=TRUE)
+ } 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)
+ }
+ }
+ return(result)
+}
+
+trmm.monthly <- function(month=1,year=1998, savepath=getwd(), rm.old=FALSE){
+ if (!require(ncdf)) stop("Package ncdf not found.")
+
+ if (!force.directories(savepath)) stop("Can not create di")
+ doy <- doyFromDate(paste(year,month,1,sep="-"))
+ if (year<2007){
+ fname <- paste("3B43.",substr(year,3,4),sprintf("%02d",month),"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",sprintf("%03d",doy),"%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),sprintf("%02d",month),"01.6",sep=""),paste("3B43.",substr(year,3,4),sprintf("%02d",month),"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",sprintf("%03d",doy),"%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)
+ if (!file.exists(outfile)){
+ withRetry(download.file(src, outfile, method="internal", mode="wb"))
+ } else if (rm.old){
+ file.remove(outfile)
+ withRetry(download.file(src, outfile, method="internal", mode="wb"))
+ }
+
+ 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 <- try(raster(outfile, varname="pcp"),silent=TRUE)
+ if(class(traster)!="try-error"){
+ xy <- xyFromCell(traster,1:ncell(traster))
+ prec <- values(traster)
+ result <- cbind(xy,prec)
+ } else {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rodbcext -r 14
More information about the Rodbcext-commits
mailing list