From noreply at r-forge.r-project.org Mon Aug 26 07:08:59 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 26 Aug 2013 07:08:59 +0200 (CEST) Subject: [Rodbcext-commits] r42 - in pkg/geoclimate: . R Message-ID: <20130826050859.499CE18597F@r-forge.r-project.org> 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