[adegenet-commits] r141 - in pkg: . R

[noreply at r-forge.r-project.org]

Author: jombart
Date: 2008-06-29 16:16:01 +0200 (Sun, 29 Jun 2008)
New Revision: 141

Modified:
   pkg/DESCRIPTION
   pkg/R/export.R
   pkg/TODO
Log:
genind2df made faster, and now works with whatever ploidy is.


Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2008-06-28 16:59:53 UTC (rev 140)
+++ pkg/DESCRIPTION	2008-06-29 14:16:01 UTC (rev 141)
@@ -9,4 +9,4 @@
 Description: Classes and functions for genetic data analysis within the multivariate framework.
 License: GPL (>=2)
 LazyLoad: yes
-Collate: classes.R auxil.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R DONOTPASSCHECK.R
\ No newline at end of file
+Collate: classes.R auxil.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R
\ No newline at end of file

Modified: pkg/R/export.R
===================================================================
--- pkg/R/export.R	2008-06-28 16:59:53 UTC (rev 140)
+++ pkg/R/export.R	2008-06-29 14:16:01 UTC (rev 141)
@@ -16,7 +16,7 @@
 genind2genotype <- function(x,pop=NULL,res.type=c("matrix","list")){
 
   if(!is.genind(x)) stop("x is not a valid genind object")
-  if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid objects")
+  if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
 
   if(!require(genetics)) stop("genetics package is not required but not installed.")
   if(is.null(pop)) pop <- x at pop
@@ -77,7 +77,7 @@
     ##  if(!inherits(x,"genind")) stop("x must be a genind object (see ?genind)")
     ##   invisible(validObject(x))
     if(!is.genind(x)) stop("x is not a valid genind object")
-    if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid objects")
+    if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
 
     if(is.null(pop)) pop <- x at pop
     if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))
@@ -129,36 +129,34 @@
       pop <- x at pop
       levels(pop) <- x at pop.names
   }
-  ## if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab))) # no longer used
-  
+
   # 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)
   
-  # kX is a list of nloc tables
-  
-  # function to recode a genotype in form "A1/A2" from frequencies
+  ## function to recode a genotype in form "A1[sep]...[sep]Ak" from frequencies
   recod <- function(vec,lab){
-      vec <- as.logical(vec)
-      sumVec <- sum(vec)
-      if(is.na(sumVec)) {
-          return(NA)
-      } else if(sumVec==2){ # heteroZ
-          return(paste(lab[vec], collapse=sep))
-      } else if(sumVec==1){ # homoZ
-          return(paste(lab[vec],lab[vec],sep=sep))
-      } else return(NA)
+      if(any(is.na(vec))) return(NA)
+      res <- paste( rep(lab,vec), collapse=sep)
+      return(res)
   }
-  
-  ##  recod <- function(vec,lab){ ## old version, new one is faster
-  ##     if(all(is.na(vec))) return(NA)
-  ##     if(round(sum(vec),10) != 1) return(NA)
-  ##     temp <- c(which(vec==0.5),which(vec==1))
-  ##     if(length(temp)==0) return(NA)
-  ##     lab <- lab[temp]
-  ##     res <- paste(lab[1],lab[length(lab)],sep=sep)
-  ##     return(res)
+
+
+  ## OLD VERSION
+  ##   recod <- function(vec,lab){
+  ##       vec <- as.logical(vec)
+  ##       sumVec <- sum(vec)
+  ##       if(is.na(sumVec)) {
+  ##           return(NA)
+  ##       } else if(sumVec==2){ # heteroZ
+  ##           return(paste(lab[vec], collapse=sep))
+  ##       } else if(sumVec==1){ # homoZ
+  ##           return(paste(lab[vec],lab[vec],sep=sep))
+  ##       } else return(NA)
   ##   }
- 
+  
+
   # 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
@@ -167,6 +165,6 @@
 
   ## handle pop here
   if(!is.null(pop) & usepop) res <- cbind.data.frame(pop,res)
-  
+
   return(res)
 }

Modified: pkg/TODO
===================================================================
--- pkg/TODO	2008-06-28 16:59:53 UTC (rev 140)
+++ pkg/TODO	2008-06-29 14:16:01 UTC (rev 141)
@@ -26,7 +26,7 @@
 
 # CODE ISSUES:
 ==============
-*
+* fix missing data indication in summaries
 
 # DOCUMENTATION ISSUES:
 =======================