[Rodbcext-commits] r42 - in pkg/geoclimate: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 26 07:08:59 CEST 2013
Author: jaunario
Date: 2013-08-26 07:08:58 +0200 (Mon, 26 Aug 2013)
New Revision: 42
Modified:
pkg/geoclimate/DESCRIPTION
pkg/geoclimate/R/fse.r
pkg/geoclimate/R/nasa.r
pkg/geoclimate/R/upload.r
Log:
Used RCurl to download nasa-power files. Standardized name for FSE functions (lowercase write.fse, read.fse)
Modified: pkg/geoclimate/DESCRIPTION
===================================================================
--- pkg/geoclimate/DESCRIPTION 2013-05-29 09:10:16 UTC (rev 41)
+++ pkg/geoclimate/DESCRIPTION 2013-08-26 05:08:58 UTC (rev 42)
@@ -1,8 +1,8 @@
Package: geoclimate
Type: Package
Title: Climate and Weather Data Processing at the IRRI GIS Laboratory
-Version: 0.0.18
-Date: 2009-2-24
+Version: 0.0.21
+Date: 2013-6-4
Depends: methods, genutils, oldweather, RODBC
Suggests: RCurl, ncdf
Author: Jorrel Khalil S. Aunario
Modified: pkg/geoclimate/R/fse.r
===================================================================
--- pkg/geoclimate/R/fse.r 2013-05-29 09:10:16 UTC (rev 41)
+++ pkg/geoclimate/R/fse.r 2013-08-26 05:08:58 UTC (rev 42)
@@ -4,7 +4,7 @@
# Licence GPL v3
# Read and Write FSE weather files
-read.FSE <- function(fsefile, datacols=c("station_id", "year", "doy", "srad", "tmin", "tmax", "vapr","wind","prec")){
+read.fse <- function(fsefile, datacols=c("station_id", "year", "doy", "srad", "tmin", "tmax", "vapr","wind","prec"), delim=" ", skip.hdr=FALSE){
fsewth <- new("weather")
is.sunshine <- FALSE
@@ -13,37 +13,43 @@
if(file.exists(fsefile) & file.info(fsefile)$size!=0){
dlines <- readLines(fsefile)
- dlines <- gsub("\t", " ", dlines)
+ dlines <- gsub("\t", delim, dlines)
+
# get headers
ihdr <- grep("\\*", dlines)
- hdr <- gsub("\\*", " ", dlines[min(ihdr):max(ihdr)])
- hdr <- trim(gsub("\\?", " ", hdr))
- hdr <- hdr[hdr!=""]
-
- icol <- grep("1[[:space:]]+Station", hdr, ignore.case=TRUE)
- if (length(grep("--", hdr))>0){
- colinfo <- hdr[icol:(length(hdr)-1)]
- } else{
- colinfo <- hdr[icol:length(hdr)]
+
+ if(!skip.hdr){
+ hdr <- gsub("\\*", " ", dlines[min(ihdr):max(ihdr)])
+ hdr <- trim(gsub("\\?", " ", hdr))
+ hdr <- hdr[hdr!=""]
+
+ icol <- grep("1[[:space:]]+Station", hdr, ignore.case=TRUE)
+ if (length(icol)>1 & length(grep("--", hdr))>0){
+ colinfo <- hdr[icol:(length(hdr)-1)]
+ } else {
+ colinfo <- hdr[icol:length(hdr)]
+ }
+ hdr <- hdr[1:(icol-1)]
+
+ # get station name
+ i <- grep("station", hdr, ignore.case=TRUE)
+ if (length(i)==0) {
+ i <- grep("location", hdr, ignore.case=TRUE)
+ }
+ fsewth at stn <- ifelse(!is.na(i[1]), trim(gsub("\\*", "", unlist(strsplit(hdr[i],":"))[2])),"Unknown")
+
+ # get source
+ i <- grep("source", hdr, ignore.case=TRUE)
+ fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(hdr[i],":"))[2]),"")
+
+ # get station name
+ #i <- grep("source", hdr, ignore.case=TRUE)
+ #fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(dlines[i],":"))[2]),"")
}
- hdr <- hdr[1:(icol-1)]
- # get station name
- i <- grep("station", hdr, ignore.case=TRUE)
- if (length(i)==0) {
- i <- grep("location", hdr, ignore.case=TRUE)
- }
- fsewth at stn <- ifelse(!is.na(i[1]), trim(gsub("\\*", "", unlist(strsplit(hdr[i],":"))[2])),"Unknown")
+
- # get source
- i <- grep("source", hdr, ignore.case=TRUE)
- fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(hdr[i],":"))[2]),"")
-
- # get station name
- #i <- grep("source", hdr, ignore.case=TRUE)
- #fsewth at rmk <- ifelse(length(i)==1, trim(unlist(strsplit(dlines[i],":"))[2]),"")
-
# get coordinates
- coords <- as.numeric(unlist(strsplit(trim(dlines[max(ihdr)+1]),"[[:space:]]+")))
+ coords <- as.numeric(unlist(strsplit(trim(dlines[max(ihdr)+1]),delim)))
rm(dlines)
gc(verbose=FALSE)
@@ -55,23 +61,25 @@
#dmatrix[dmatrix==-9999] <- NA
#dmatrix <- as.data.frame(dmatrix)
- dmatrix <- read.table(fsefile, skip=max(ihdr)+1, na.strings="-9999", stringsAsFactors=FALSE)
+ dmatrix <- read.table(fsefile, skip=max(ihdr)+1, stringsAsFactors=FALSE, sep=delim)
colnames(dmatrix) <- datacols
- # CHECK RADIATION UNITS THEN CONVERT TO MEGAJOULE/SQM/DAY IF NECESSARY
-
- # Check if sunshine hours/duration
- rad_var <- grep("sunshine[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
- if (length(rad_var)!=0){
- dmatrix[,rad_var] <- round(sunhoursToSRad(dmatrix[,rad_var],dmatrix[,3],fsewth at lat, coords[4], coords[5]),2)
- show.message("Sunshine duration", appendLF=TRUE)
+ if(!skip.hdr){
+ # CHECK RADIATION UNITS THEN CONVERT TO MEGAJOULE/SQM/DAY IF NECESSARY
- } else {
- rad_var <- grep("[[:print:]]*rad[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
- if(length(rad_var)!=0 & grepl("kj", colinfo[rad_var],ignore.case=TRUE)) {
- dmatrix[,rad_var] <- round(dmatrix[,rad_var]/1000,2)
- }
-
+ # Check if sunshine hours/duration
+ rad_var <- grep("sunshine[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
+ if (length(rad_var)!=0){
+ dmatrix[,rad_var] <- round(sunhoursToSRad(dmatrix[,rad_var],dmatrix[,3],fsewth at lat, coords[4], coords[5]),2)
+ show.message("Sunshine duration", appendLF=TRUE)
+
+ } else {
+ rad_var <- grep("[[:print:]]*rad[[:print:]]*", tolower(colinfo), ignore.case=TRUE)
+ if(length(rad_var)!=0 & grepl("kj", colinfo[rad_var],ignore.case=TRUE)) {
+ dmatrix[,rad_var] <- round(dmatrix[,rad_var]/1000,2)
+ }
+
+ }
}
wdate <- dateFromDoy(dmatrix[,"doy"],dmatrix[,"year"])
@@ -85,7 +93,7 @@
}
-.toFSEFile <- function(wthdat, country="WORLD", station="", author="Geoclimate (IRRI-GIS Climatic Data Warehouse)", format="csv", comments="", savepath=getwd()){
+.toFSEFile <- function(wthdat, country="WORLD", station="", author="Geoclimate (IRRI-GIS Climate Data Package)", format="csv", comments="", savepath=getwd()){
# standard checks
if (class(wthdat)!="weather"){
stop("Unsupported data format. Should of class \"weather\"")
@@ -119,16 +127,16 @@
hdrbar <- paste("*", paste(rep("-",max(nchar(c(hdrspec,hdrvars, hdrstn)))), collapse=""),sep="")
- locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00")
-
wthdat at w$year <- as.numeric(format(wthdat at w$wdate, "%Y"))
wthdat at w$doy <- as.numeric(format(wthdat at w$wdate, "%j"))
if (format=="csv"){
+ locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00", sep=", ")
dat <- paste(wthdat at stn, wthdat at w$year, wthdat at w$doy, wthdat at w$srad, wthdat at w$tmin, wthdat at w$tmax, wthdat at w$vapr, wthdat at w$wind, wthdat at w$prec, sep=", ")
} else if (format=="fixed"){
+ locstr <- paste(sprintf("%.2f", wthdat at lon), sprintf("%.2f", wthdat at lat),format(sprintf("%.1f", wthdat at alt), width=5), "0.00", "0.00")
dat <- paste(wthdat at stn, sprintf("%6.0d", wthdat at w$year), format(wthdat at w$wdate, " %j", width=6), sprintf("%10.0f", wthdat$srad[d]), sprintf("%8.1f", wthdat$tmin[d]), sprintf("%8.1f", wthdat$tmax[d]), sprintf("%8.1f", wthdat$vapr[d]), sprintf("%8.1f", wind), sprintf("%8.1f", wthdat$prec[d]))
}
Modified: pkg/geoclimate/R/nasa.r
===================================================================
--- pkg/geoclimate/R/nasa.r 2013-05-29 09:10:16 UTC (rev 41)
+++ pkg/geoclimate/R/nasa.r 2013-08-26 05:08:58 UTC (rev 42)
@@ -4,6 +4,9 @@
# Licence GPL v3
get.nasa <- function(x, y, vars=c("toa_dwn","swv_dwn","lwv_dwn","T2M", "T2MN","T2MX", "RH2M", "DFP2M","RAIN", "WS10M"),stdate="1983-1-1", endate=Sys.Date(), savepath=getwd(), rm.existing=FALSE){
+ if(!require(RCurl)){
+ stop("Package RCurl not found.")
+ }
result <- new("weather")
src <- ""
if(length(x)!=1|length(y)!=1){
@@ -27,17 +30,19 @@
fname <- paste(paste("nasa",cell,x,y,format(stdate,"%Y.%m.%d"),format(endate,"%Y.%m.%d"), sep="_"), ".txt",sep="")
#dlurl <- paste("http://earth-www.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",format(stdate,"%m"),"&ds=",format(stdate,"%d"),"&ys=",format(stdate,"%Y"),"&me=",format(endate,"%m"),"&de=",format(endate,"%d"),"&ye=",format(endate,"%Y"),"&p=swv_dwn&p=T2M&p=T2MN&p=T2MX&p=RH2M&p=DFP2M&p=RAIN&p=WS10M&submit=Submit", sep="")
- dlurl <- paste("http://power.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",format(stdate,"%m"),"&ds=",format(stdate,"%d"),"&ys=",format(stdate,"%Y"),"&me=",format(endate,"%m"),"&de=",format(endate,"%d"),"&ye=",format(endate,"%Y"),"&p=", paste(vars,collapse="&p=",sep=""),"&submit=Submit", sep="")
+ dlurl <- paste("http://power.larc.nasa.gov/cgi-bin/cgiwrap/solar/agro.cgi?email=agroclim%40larc.nasa.gov&step=1&lat=",y,"&lon=",x,"&ms=",monthFromDate(stdate),"&ds=",dayFromDate(stdate),"&ys=",yearFromDate(stdate),"&me=",monthFromDate(endate),"&de=",dayFromDate(endate),"&ye=",yearFromDate(endate),"&p=", paste(vars,collapse="&p=",sep=""),"&submit=Submit", sep="")
show.message("Reading ", appendLF=FALSE)
if (!file.exists(paste(savepath, fname, sep="/"))){
show.message(dlurl, appendLF=TRUE)
- dlines <- withRetry(readLines(dlurl))
+ dlines <- unlist(strsplit(getURL(url=dlurl), "\n"))
+ if(!is.null(savepath)) writeLines(dlines, paste(savepath, fname, sep="/"))
src <- dlurl
} else if (rm.existing | file.info(paste(savepath, fname, sep="/"))$size==0){
+ show.message(dlurl, appendLF=TRUE)
file.remove(paste(savepath, fname, sep="/"))
- show.message(dlurl, appendLF=TRUE)
- dlines <- withRetry(readLines(dlurl))
+ dlines <- unlist(strsplit(getURL(url=dlurl), "\n"))
+ writeLines(dlines, paste(savepath, fname, sep="/"))
src <- dlurl
} else {
show.message(paste(savepath, fname, sep="/"), appendLF=TRUE)
@@ -79,4 +84,6 @@
result at rmk <- msg
return(result)
}
-
\ No newline at end of file
+
+#get.nasa(-179.5, 89.5)
+
Modified: pkg/geoclimate/R/upload.r
===================================================================
--- pkg/geoclimate/R/upload.r 2013-05-29 09:10:16 UTC (rev 41)
+++ pkg/geoclimate/R/upload.r 2013-08-26 05:08:58 UTC (rev 42)
@@ -22,8 +22,8 @@
}
upload.weather <- function(con, wth, setname,...){
- # TODO: support transaction
- success <- FALSE
+
+ success <- FALSE
if (class(wth)!="weather"){
stop("Invalid wth input. Should be class 'weather'")
@@ -34,9 +34,9 @@
}
upload.nasa <- function(dbasecon, nasa, cols=c("wdate","toa_dwn", "srad", "lwv_dwn", "tavg", "tmin", "tmax", "rh2m", "tdew", "prec", "wind"), setname='nasa_1d'){
- # TODO: support transaction
- success <- FALSE
+ success <- FALSE
+
if (class(nasa)!="weather"){
stop("Invalid nasa input. Should be class 'weather'")
}
@@ -54,8 +54,8 @@
}
upload.gsod <- function(dbasecon, gsod, setname="gsod_xd"){
- # TODO: support transaction
- success <- FALSE
+
+ success <- FALSE
if (class(gsod)!="weather"){
stop("Invalid gsod input. Should be class 'weather'")
@@ -69,8 +69,8 @@
}
upload.trmm <- function(dbasecon, trmm, setname="trmm_15m"){
- # TODO: support transaction
- success <- FALSE
+
+ success <- FALSE
if (class(trmm)!="weather"){
stop("Invalid gsod input. Should be class 'weather'")
@@ -84,7 +84,7 @@
}
-upload.FSE <- function(dbasecon, clim, setname, stations=NA, has.AIid=FALSE){
+upload.fse <- function(dbasecon, clim, setname, stations=NA, has.AIid=FALSE){
add <- success <- FALSE
More information about the Rodbcext-commits
mailing list