[adegenet-commits] r279 - pkg/R

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

Author: jombart
Date: 2009-04-01 13:49:21 +0200 (Wed, 01 Apr 2009)
New Revision: 279

Modified:
   pkg/R/auxil.R
   pkg/R/export.R
   pkg/R/handling.R
Log:
genind2df fixed for PA; pop <- NULL now possible.


Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R	2009-04-01 11:33:10 UTC (rev 278)
+++ pkg/R/auxil.R	2009-04-01 11:49:21 UTC (rev 279)
@@ -101,7 +101,7 @@
 # checkType
 ############
 ##
-## WARNING: this does not work with all S3/S4 methods
+## WARNING: this does not work with S4 methods
 ##
 checkType <- function(x){
     if(is.character(x)){
@@ -120,7 +120,7 @@
     }
 
     ## names of functions which are ok for dominant markers
-    PAOk <- c("genind","genpop","genind2genpop","summary","df2genind",
+    PAOk <- c("genind","genpop","genind2genpop","summary","df2genind", "genind2df",
                  "truenames","seppop","na.replace","nLoc","scaleGen","spca","selpop")
 
     PAWarn <- c("df2genind")

Modified: pkg/R/export.R
===================================================================
--- pkg/R/export.R	2009-04-01 11:33:10 UTC (rev 278)
+++ pkg/R/export.R	2009-04-01 11:49:21 UTC (rev 279)
@@ -1,6 +1,6 @@
 ############################################
-# 
-# Functions to transform a genind object 
+#
+# Functions to transform a genind object
 # into other R classes
 #
 # Thibaut Jombart
@@ -23,11 +23,11 @@
   if(is.null(pop)) pop <- x at pop
   if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))
   res.type <- tolower(res.type[1])
-  
+
   # make one table by locus from x at tab
   kX <- seploc(x,res.type="matrix")
   # kX is a list of nloc tables
-  
+
   # function to recode a genotype in form "A1/A2" from frequencies
   recod <- function(vec,lab){
     if(all(is.na(vec))) return(NA)
@@ -65,7 +65,7 @@
     res <- cbind.data.frame(kGen)
     res <- makeGenotypes(res,convert=1:ncol(res))
   } else stop("Unknown res.type requested.")
-  
+
   return(res)
 }
 
@@ -85,7 +85,7 @@
 
     if(is.null(pop)) pop <- x at pop
     if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))
-    
+
     ## make one table by locus from x at tab
     kX <- seploc(x,res.type="matrix")
     ## kX is a list of nloc tables
@@ -100,7 +100,7 @@
     for(i in 1:nrmzero) {
         all.names <- lapply(all.names,function(e) gsub("^0","",e))
     }
-    
+
     ## function to recode a genotype in form "A1A2" (as integers) from frequencies
     recod <- function(vec,lab){
         if(all(is.na(vec))) return(NA)
@@ -135,11 +135,24 @@
       levels(pop) <- x at pop.names
   }
 
+  ## PA case ##
+  if(x at type=="PA"){
+      temp <- truenames(x)
+      if(is.list(temp)){
+          res <- cbind.data.frame(pop=temp[[2]],temp[[1]])
+      } else{
+          res <- temp
+      }
+
+      return(res)
+  }
+
+  ## 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)
@@ -148,20 +161,6 @@
   }
 
 
-  ## 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

Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R	2009-04-01 11:33:10 UTC (rev 278)
+++ pkg/R/handling.R	2009-04-01 11:49:21 UTC (rev 279)
@@ -654,6 +654,12 @@
 
 
 setReplaceMethod("pop", "genind", function(x, value) {
+    if(is.null(value)){
+        x at pop <- NULL
+        x at pop.names <- NULL
+        return(x)
+    }
+
     if(length(value) != nrow(x$tab)) stop("wrong length for population factor")
 
     ## coerce to factor (put levels in their order of appearance)