[adegenet-commits] r454 - in www: . files/patches

Thu Oct 15 13:02:07 CEST 2009

Author: jombart
Date: 2009-10-15 13:02:07 +0200 (Thu, 15 Oct 2009)
New Revision: 454

Added:
   www/files/patches/genind2df.R
   www/files/patches/makefreq.R
Modified:
   www/download.html
Log:
Added new patches to the website.


Modified: www/download.html
===================================================================

--- www/download.html	2009-10-15 10:49:38 UTC (rev 453)
+++ www/download.html	2009-10-15 11:02:07 UTC (rev 454)
@@ -48,6 +48,15 @@
 removed the 'no dot' constraint in locus names<br>
 - <a style="font-family: monospace;" href="files/patches/propShared.R">propShared.R</a>:
 fixes a bug identified by Valeria Paccapelo occuring with NAs<br>
+- <a style="font-family: monospace;" href="files/patches/makefreq.R"><span
+ style="font-family: monospace;"><span
+ style="text-decoration: underline;">makefreq</span></span>.R</a>:
+makefreq is now possible after a seploc<br>
+- <a style="font-family: monospace;" href="files/patches/genind2df.R"><span
+ style="font-family: monospace;"><span
+ style="text-decoration: underline;">genind2df</span></span>.R</a>: new
+feature: alleles can be provided as different columns when exporting to
+data.frame<br>
 <br>
 <img alt="" src="images/bullet.png" style="width: 10px; height: 10px;">
 <span style="font-weight: bold;">Older

Added: www/files/patches/genind2df.R
===================================================================
--- www/files/patches/genind2df.R	                        (rev 0)
+++ www/files/patches/genind2df.R	2009-10-15 11:02:07 UTC (rev 454)
@@ -0,0 +1,78 @@
+#####################
+# Function genind2df
+#####################
+genind2df <- function(x, pop=NULL, sep="", usepop=TRUE, oneColPerAll=FALSE){
+
+  if(!is.genind(x)) stop("x is not a valid genind object")
+  ## checkType(x)
+
+  if(is.null(pop)) {
+      pop <- x at pop
+      levels(pop) <- x at pop.names
+  }
+
+  if(oneColPerAll){
+      sep <- "/"
+  }
+
+  ## PA case ##
+  if(x at type=="PA"){
+      temp <- truenames(x)
+      if(is.list(temp) & usepop){
+          res <- cbind.data.frame(pop=temp[[2]],temp[[1]])
+      } else{
+          if(is.list(temp)) {
+              res <- temp[[1]]
+          } else{
+              res <- temp
+          }
+      }
+
+      return(res) # exit here
+  }
+
+  ## codom case ##
+  # make one table by locus from x at tab
+  kX <- seploc(x,res.type="matrix")
+  kX <- lapply(kX, function(X) round(X*x at ploidy)) # take data as numbers of alleles
+  ## (kX is a list of nloc tables)
+
+  ## function to recode a genotype in form "A1[sep]...[sep]Ak" from frequencies
+  recod <- function(vec,lab){
+      if(any(is.na(vec))) return(NA)
+      res <- paste( rep(lab,vec), collapse=sep)
+      return(res)
+  }
+
+
+  # kGen is a list of nloc vectors of genotypes
+  kGen <- lapply(1:length(kX), function(i) apply(kX[[i]],1,recod,x at all.names[[i]]))
+  names(kGen) <- x at loc.names
+
+  ## if use one column per allele
+  if(oneColPerAll){
+      f1 <- function(vec){ # to repeat NA with seperators
+          vec[is.na(vec)] <- paste(rep("NA",x at ploidy), collapse=sep)
+          return(vec)
+      }
+      temp <- lapply(kGen, f1)
+      temp <- lapply(temp, strsplit,sep)
+
+      res <- lapply(temp, function(e) matrix(unlist(e), ncol=x at ploidy, byrow=TRUE))
+      res <- data.frame(res,stringsAsFactors=FALSE)
+      names(res) <- paste(rep(locNames(x),each=x at ploidy), 1:x at ploidy, sep=".")
+
+      ## handle pop here
+      if(!is.null(pop) & usepop) res <- cbind.data.frame(pop,res,stringsAsFactors=FALSE)
+
+      return(res) # exit here
+  } # end if oneColPerAll
+
+  ## build the final data.frame
+  res <- cbind.data.frame(kGen,stringsAsFactors=FALSE)
+
+  ## handle pop here
+  if(!is.null(pop) & usepop) res <- cbind.data.frame(pop,res,stringsAsFactors=FALSE)
+
+  return(res)
+}

Added: www/files/patches/makefreq.R
===================================================================
--- www/files/patches/makefreq.R	                        (rev 0)
+++ www/files/patches/makefreq.R	2009-10-15 11:02:07 UTC (rev 454)
@@ -0,0 +1,58 @@
+####################
+# Function makefreq
+####################
+makefreq <- function(x,quiet=FALSE,missing=NA,truenames=TRUE){
+
+  if(!is.genpop(x)) stop("x is not a valid genpop object")
+  ##if(x at type=="PA") stop("frequencies not computable for presence/asbence data")
+  checkType(x)
+
+  if(!quiet) cat("\n Finding allelic frequencies from a genpop object... \n")
+
+  f1 <- function(v){
+    if(all(is.na(v)) || sum(v,na.rm=TRUE)==0) return(rep(NA,length(v)))
+    return(v/(sum(v,na.rm=TRUE)))
+  }
+
+  res <- list()
+
+  tabcount <- x at tab
+
+  eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))
+  if(nLoc(x)==1){ # fix for nloc==1
+      eff.pop <- t(eff.pop)
+  }
+
+  # tabfreq is a pop x loci table of allelic frequencies
+  tabfreq <- t(apply(tabcount,1,function(r) unlist(tapply(r,x at loc.fac,f1))))
+  colnames(tabfreq) <- colnames(x at tab)
+
+  # NA treatment
+  # NA can be kept as is, or replaced 0 or by the mean frequency of the allele.
+  if(!is.na(missing)){
+    if(missing==0) tabfreq[is.na(tabfreq)] <- 0
+    if(toupper(missing)=="MEAN") {
+      moy <- apply(tabfreq,2,function(c) mean(c,na.rm=TRUE))
+      for(j in 1:ncol(tabfreq)) {tabfreq[,j][is.na(tabfreq[,j])] <- moy[j]}
+    }
+  }
+
+  if(!quiet) cat("\n...done.\n\n")
+
+  res$tab <- tabfreq
+  res$nobs <- eff.pop
+  res$call <- match.call()
+
+  ## handle truenames
+  if(truenames){
+      temp <- rep(x at loc.names,x at loc.nall)
+      colnames(res$tab) <- paste(temp,unlist(x at all.names),sep=".")
+      rownames(res$tab) <- x at pop.names
+
+      colnames(res$nobs) <- x at loc.names
+      rownames(res$nobs) <- x at pop.names
+  }
+
+  return(res)
+} #end makefreq
+

