[adegenet-commits] r280 - pkg/R

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

Author: jombart
Date: 2009-04-01 14:27:43 +0200 (Wed, 01 Apr 2009)
New Revision: 280

Modified:
   pkg/R/export.R
   pkg/R/handling.R
   pkg/R/import.R
Log:
Fixed df2genind for PA data.


Modified: pkg/R/export.R
===================================================================
--- pkg/R/export.R	2009-04-01 11:49:21 UTC (rev 279)
+++ pkg/R/export.R	2009-04-01 12:27:43 UTC (rev 280)
@@ -128,7 +128,7 @@
 genind2df <- function(x, pop=NULL, sep="", usepop=TRUE){
 
   if(!is.genind(x)) stop("x is not a valid genind object")
-  checkType(x)
+  ## checkType(x)
 
   if(is.null(pop)) {
       pop <- x at pop
@@ -138,10 +138,14 @@
   ## PA case ##
   if(x at type=="PA"){
       temp <- truenames(x)
-      if(is.list(temp)){
+      if(is.list(temp) & usepop){
           res <- cbind.data.frame(pop=temp[[2]],temp[[1]])
       } else{
-          res <- temp
+          if(is.list(temp)) {
+              res <- temp[[1]]
+          } else{
+              res <- temp
+          }
       }
 
       return(res)

Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R	2009-04-01 11:49:21 UTC (rev 279)
+++ pkg/R/handling.R	2009-04-01 12:27:43 UTC (rev 280)
@@ -321,7 +321,7 @@
 
 ## genind
 setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix"), drop=FALSE){
-    checkType(x)
+    ## checkType(x)
 
     ## misc checks
     if(!is.genind(x)) stop("x is not a valid genind object")
@@ -465,11 +465,13 @@
     temp <- sapply(x,function(e) e$ploidy)
     if(length(unique(temp)) != as.integer(1)) stop("objects have different levels of ploidy")
 
+
+
     ## extract info
     listTab <- lapply(x,genind2df,usepop=FALSE)
     getPop <- function(obj){
         if(is.null(obj$pop)) return(factor(rep(NA,nrow(obj$tab))))
-      pop <- obj$pop
+        pop <- obj$pop
         levels(pop) <- obj$pop.names
         return(pop)
     }
@@ -479,7 +481,7 @@
     pop <- unlist(listPop, use.name=FALSE)
     pop <- factor(pop)
 
-  ## handle genotypes
+    ## handle genotypes
     markNames <- colnames(listTab[[1]])
     listTab <- lapply(listTab, function(tab) tab[,markNames]) # resorting of the tabs
 
@@ -489,7 +491,7 @@
         tab <- rbind(tab,listTab[[i]])
     }
 
-    res <- df2genind(tab,pop=pop)
+    res <- df2genind(tab, pop=pop, ploidy=x[[1]]@ploidy, type=x[[1]]@type)
     res$call <- match.call()
 
     return(res)

Modified: pkg/R/import.R
===================================================================
--- pkg/R/import.R	2009-04-01 11:49:21 UTC (rev 279)
+++ pkg/R/import.R	2009-04-01 12:27:43 UTC (rev 280)
@@ -25,25 +25,32 @@
 
     res <- list()
     type <- match.arg(type)
-    checkType(type)
+    ## checkType(type)
 
-    ## type PA
-    if(toupper(type)=="PA"){
-        mode(X) <- "numeric"
 
-        ## pop optionnelle
-        if(!is.null(pop)){
-            if(length(pop)!= n) stop("length of factor pop differs from nrow(X)")
-            pop <- as.factor(pop)
-        }
+    ## type-independent stuff ##
+    n <- nrow(X)
+    nloc <- ncol(X)
+    ploidy <- as.integer(ploidy)
+    if(ploidy < 1L) stop("ploidy cannot be less than 1")
 
-        if(!is.null(ind.names)) rownames(X) <- ind.names
-        if(!is.null(loc.names)) colnames(X) <- loc.names
+    if(is.null(ind.names)) {ind.names <- rownames(X)}
+    if(is.null(loc.names)) {loc.names <- colnames(X)}
 
-        ## handle entirely non-typed loci and individuals
-        X <- gsub("^0*$",NA,X)
-        X <- gsub("(NA)+",NA,X)
+    ## pop optionnelle
+    if(!is.null(pop)){
+        if(length(pop)!= n) stop("length of factor pop differs from nrow(X)")
+        pop <- as.factor(pop)
+    }
 
+
+    ## PA case ##
+    if(toupper(type)=="PA"){
+        ## preliminary stuff
+        mode(X) <- "numeric"
+        rownames(X) <- ind.names
+        colnames(X) <- loc.names
+
         ## Erase entierely non-typed loci
         temp <- apply(X,2,function(c) all(is.na(c)))
         if(any(temp)){
@@ -73,23 +80,13 @@
         return(res)
     } # end type PA
 
+
+    ## codom case ##
+
     ## make sure X is in character mode
     mode(X) <- "character"
 
-    n <- nrow(X)
-    nloc <- ncol(X)
-    ploidy <- as.integer(ploidy)
-    if(ploidy < as.integer(1)) stop("ploidy cannot be less than 1")
 
-    if(is.null(ind.names)) {ind.names <- rownames(X)}
-    if(is.null(loc.names)) {loc.names <- colnames(X)}
-
-    ## pop optionnelle
-    if(!is.null(pop)){
-      if(length(pop)!= n) stop("length of factor pop differs from nrow(X)")
-      pop <- as.factor(pop)
-    }
-
     ## find or check the number of coding characters, 'ncode'
     if(is.null(sep)){
         if(!is.null(ncode)) {