[Rodbcext-commits] r12 - in pkg: . genutils genutils/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 20 10:39:37 CET 2012
Author: jaunario
Date: 2012-01-20 10:39:37 +0100 (Fri, 20 Jan 2012)
New Revision: 12
Added:
pkg/genutils/
pkg/genutils/DESCRIPTION
pkg/genutils/NAMESPACE
pkg/genutils/R/
pkg/genutils/R/dataframeutils.R
pkg/genutils/R/geoutils.r
pkg/genutils/R/sysutils.r
pkg/genutils/inst/
pkg/genutils/man/
Log:
New Package genutils for commonly used functions
Property changes on: pkg/genutils
___________________________________________________________________
Added: bugtraq:number
+ true
Added: pkg/genutils/DESCRIPTION
===================================================================
--- pkg/genutils/DESCRIPTION (rev 0)
+++ pkg/genutils/DESCRIPTION 2012-01-20 09:39:37 UTC (rev 12)
@@ -0,0 +1,11 @@
+Package: genutils
+Type: Package
+Title: IRRI Geography Lab - General Utilities
+Version: 0.0.1
+Date: 2011-10-19
+Depends: methods
+Author: Jorrel Khalil S. Aunario
+Maintainer: <jaunario at gmail.com>
+Description: [description]
+License: GPL (>=2)
+LazyLoad: yes
Added: pkg/genutils/NAMESPACE
===================================================================
--- pkg/genutils/NAMESPACE (rev 0)
+++ pkg/genutils/NAMESPACE 2012-01-20 09:39:37 UTC (rev 12)
@@ -0,0 +1 @@
+exportPattern("^[^\\.]")
\ No newline at end of file
Added: pkg/genutils/R/dataframeutils.R
===================================================================
--- pkg/genutils/R/dataframeutils.R (rev 0)
+++ pkg/genutils/R/dataframeutils.R 2012-01-20 09:39:37 UTC (rev 12)
@@ -0,0 +1,39 @@
+# 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)
+}
Added: pkg/genutils/R/geoutils.r
===================================================================
--- pkg/genutils/R/geoutils.r (rev 0)
+++ pkg/genutils/R/geoutils.r 2012-01-20 09:39:37 UTC (rev 12)
@@ -0,0 +1,78 @@
+# 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)
+}
Added: pkg/genutils/R/sysutils.r
===================================================================
--- pkg/genutils/R/sysutils.r (rev 0)
+++ pkg/genutils/R/sysutils.r 2012-01-20 09:39:37 UTC (rev 12)
@@ -0,0 +1,86 @@
+# Author: Jorrel Khalil S. Aunario, jaunario at gmail.com
+# Date : 22 February 2011
+# Version 0.0.1
+# Licence GPL v3
+
+serialn <- function(x, width=2){
+ #TODO just use sprintf
+ return(sprintf(paste("%0",width,"d",sep=""),x))
+}
+
+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)
+}
+
+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)
+}
More information about the Rodbcext-commits
mailing list