[adegenet-commits] r864 - in www: . files/patches
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 26 16:46:09 CEST 2011
Author: jombart
Date: 2011-04-26 16:46:09 +0200 (Tue, 26 Apr 2011)
New Revision: 864
Added:
www/files/patches/auxil.R
Modified:
www/download.html
Log:
Added auxil.R file in patches.
Modified: www/download.html
===================================================================
--- www/download.html 2011-04-20 16:27:46 UTC (rev 863)
+++ www/download.html 2011-04-26 14:46:09 UTC (rev 864)
@@ -4,7 +4,7 @@
<meta content="text/html; charset=ISO-8859-1"
http-equiv="content-type">
<title>download</title>
-<script type="text/javascript">
+ <script type="text/javascript">
var _gaq = _gaq || [];
_gaq.push(['_setAccount', 'UA-20083187-1']);
@@ -16,7 +16,8 @@
var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s);
})();
-</script></head>
+ </script>
+</head>
<body>
<br>
<br>
@@ -63,13 +64,15 @@
(for
adegenet_1.2-8
or
-lower) fixes a an issue occuring when trying to
+lower)
+fixes a an issue occuring when trying to
compute frequences in data consisting in a single monomorphic locus.<br>
<a href="files/patches/export.R"><span style="font-family: monospace;">export.R</span></a>:
(for
adegenet_1.2-7
or
-lower) fixes issues in data conversion from adegenet
+lower)
+fixes issues in data conversion from adegenet
to hierfstat
(genind2hierfstat); also fixes <span style="font-family: monospace;">fstat</span>
function.<br>
@@ -77,10 +80,20 @@
(for
adegenet_1.2-8
or
-lower) implements new plotting options for dapc scatterplots<span
+lower)
+implements new plotting options for dapc scatterplots<span
style="font-family: monospace;"> (scatter</span> on <span
style="font-family: monospace;">dapc</span> objects).<br>
+<a href="files/patches/auxil.R"><span style="font-family: monospace;">auxil.R</span></a>:
+(for
+adegenet_1.2-8
+or
+lower)
+implements useful auxiliary functions for plotting data such as <span
+ style="font-family: monospace;">transp</span> or <span
+ style="font-family: monospace;">num2col</span>.<br>
<br>
+<br>
<img alt="" src="images/bullet.png" style="width: 10px; height: 10px;">
<span style="font-weight: bold;">Older
versions</span>:<br>
Added: www/files/patches/auxil.R
===================================================================
--- www/files/patches/auxil.R (rev 0)
+++ www/files/patches/auxil.R 2011-04-26 14:46:09 UTC (rev 864)
@@ -0,0 +1,217 @@
+###########################
+#
+# Auxiliary functions for
+# adegenet objects
+#
+# T. Jombart
+###########################
+
+
+#######################
+# Function rmspaces
+#######################
+# removes spaces and tab at the begining and the end of each element of charvec
+.rmspaces <- function(charvec){
+ charvec <- gsub("^([[:blank:]]*)([[:space:]]*)","",charvec)
+ charvec <- gsub("([[:blank:]]*)([[:space:]]*)$","",charvec)
+ return(charvec)
+}
+
+
+
+
+
+###################
+# Function readExt
+###################
+.readExt <- function(char){
+ temp <- as.character(char)
+ temp <- unlist(strsplit(char,"[.]"))
+ res <- temp[length(temp)]
+ return(res)
+}
+
+
+
+
+
+###################
+# Function .genlab
+###################
+# recursive function to have labels of constant length
+# base = a character string
+# n = number of labels
+.genlab <- function(base, n) {
+ f1 <- function(cha,n){
+ if(nchar(cha)<n){
+ cha <- paste("0",cha,sep="")
+ return(f1(cha,n))
+ } else {return(cha)}
+ }
+ w <- as.character(1:n)
+ max0 <- max(nchar(w))
+ w <- sapply(w, function(cha) f1(cha,max0))
+ return(paste(base,w,sep=""))
+}
+
+
+
+
+
+#######################
+# Function adegenetWeb
+#######################
+adegenetWeb <- function(){
+ cat("Opening url \"http://adegenet.r-forge.r-project.org/\" ...\n")
+ browseURL("http://adegenet.r-forge.r-project.org/")
+}
+
+
+
+
+
+############################
+# Function adegenetTutorial
+############################
+adegenetTutorial <- function(which=c("general","spca")){
+ which <- match.arg(which)
+ if(which=="general"){
+ url <- "http://adegenet.r-forge.r-project.org/files/adegenet.pdf"
+ cat("\n")
+ cat(" >> Seeking the general tutorial for adegenet.\n")
+ cat(" >> Opening url \"",url,"\".\n ", sep="")
+ cat("\n")
+ browseURL(url)
+ }
+ if(which=="spca"){
+ url <- "http://adegenet.r-forge.r-project.org/files/tutorial-spca.pdf"
+ cat("\n")
+ cat(" >> Seeking the sPCA tutorial for adegenet.\n")
+ cat(" >> Opening url \"",url,"\". \n", sep="")
+ cat("\n")
+ browseURL(url)
+ }
+}
+
+
+
+
+
+############
+# checkType
+############
+##
+## WARNING: this does not work with S4 methods
+##
+checkType <- function(x){
+ if(is.character(x)){
+ markType <- x
+ } else {
+ markType <- x at type
+ }
+
+ if(markType=="codom") return() # always ok for codominant markers
+
+ currCall <- as.character(sys.call(sys.parent()))[1]
+ currFunction <- sub("[[:space:]]*[(].*","",currCall)
+ if(currFunction==".local"){
+ warning("Current call not found - stopping check (please report this warning).")
+ return()
+ }
+
+ ## names of functions which are ok for dominant markers
+ PAOk <- c("genind","genpop","genind2genpop","summary","df2genind", "genind2df",
+ "truenames","seppop","na.replace","nLoc","scaleGen","spca","selpop")
+
+ PAWarn <- c("df2genind")
+
+ ## function exists but is experimental
+ if(currFunction %in% PAWarn){
+ msg <- paste(currFunction,"is implemented but experimental presence/absence markers")
+ warning(msg)
+ return()
+ }
+
+ ## function not implemented
+ if(! currFunction %in% PAOk){
+ msgError <- paste(currFunction,"is not implemented for presence/absence markers")
+ stop(msgError)
+ } else return() # else, ok.
+} # end checkType
+
+
+
+
+
+
+##########
+## transp
+##########
+## AUXIL FUNCTION TO USE TRANSPARENT COLORS
+transp <- function(col, alpha=.5){
+ res <- apply(col2rgb(col),2, function(c) rgb(c[1]/255, c[2]/255, c[3]/255, alpha))
+ return(res)
+}
+
+
+
+##########
+## corner
+##########
+## AUXIL FUNCTION TO ADD LETTER TO A PLOT
+corner <- function(text, posi="topleft", inset=0.1, ...){
+ oxpd <- par("xpd")
+ on.exit(par(xpd=oxpd))
+ par(xpd=TRUE)
+ myUsr <- par("usr")
+ xrange <- myUsr[1:2]
+ yrange <- myUsr[3:4]
+ x.size <- abs(diff(xrange))
+ y.size <- abs(diff(yrange))
+ inset <- rep(inset, length=2)
+ x.inset <- inset[1]
+ y.inset <- inset[2]
+
+ if(length(grep("top", posi))==1){
+ y <- yrange[2] - y.size*y.inset
+ } else {
+ y <- yrange[1] + y.size*y.inset
+ }
+
+ if(length(grep("right", posi))==1){
+ x <- xrange[2] - x.size*x.inset
+ } else {
+ x <- xrange[1] + x.size*x.inset
+ }
+
+ text(x, y, lab=text, ...)
+}
+
+
+
+
+
+###########
+## num2col
+###########
+## translate numeric values into colors of a palette
+num2col <- function(x, col.pal=heat.colors, reverse=FALSE,
+ x.min=min(x), x.max=max(x), na.col="green"){
+ if(any(is.na(x))) warning("NAs detected in x")
+ x[x < x.min] <- x.min
+ x[x > x.max] <- x.max
+ x <- x-x.min # min=0
+ x.max <- x.max-x.min # update x.max
+ x <- x/x.max # max=1
+ x <- round(x*100)
+ x[x<=0] <- 1
+ if(!reverse) {
+ pal <- col.pal(100)
+ } else {
+ pal <- rev(col.pal(100))
+ }
+
+ res <- pal[x]
+ res[is.na(res)] <- na.col
+ return(res)
+}
More information about the adegenet-commits
mailing list