[adegenet-commits] r703 - pkg/R

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

Author: jombart
Date: 2010-11-03 13:24:37 +0100 (Wed, 03 Nov 2010)
New Revision: 703

Modified:
   pkg/R/export.R
Log:
Fix for export to hierfstat.


Modified: pkg/R/export.R
===================================================================
--- pkg/R/export.R	2010-10-29 11:40:57 UTC (rev 702)
+++ pkg/R/export.R	2010-11-03 12:24:37 UTC (rev 703)
@@ -83,45 +83,41 @@
     if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
     checkType(x)
 
-    if(is.null(pop)) pop <- x at pop
+    if(is.null(pop)) pop <- pop(x)
     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
+    ## ## NOTES ON THE CODING IN HIERFSTAT ##
+    ## - interpreting function is genot2al
+    ## - same coding has to be used for all loci
+    ## (i.e., all based on the maximum number of digits to be used)
+    ## - alleles have to be coded as integers
+    ## - alleles have to be sorted by increasing order when coding a genotype
+    ## - for instance, 121 is 1/21, 101 is 1/1, 11 is 1/1
 
-    ## prepare allele names
-    all.names <- x at all.names
+    ## find max number of alleles ##
+    max.nall <- max(x at loc.nall)
+    x at all.names <- lapply(x$all.names, function(e) .genlab("",max.nall)[1:length(e)])
 
-    ## check the number of first 0 to remove from all.names
-    nfirstzero <- attr(regexpr("^0*",unlist(all.names)),"match.length")
-    nrmzero <- min(nfirstzero)
 
-    for(i in 1:nrmzero) {
-        all.names <- lapply(all.names,function(e) gsub("^0","",e))
+    ## VERSION USING GENIND2DF ##
+    gen <- genind2df(x, sep="", usepop=FALSE)
+    gen <- as.matrix(data.frame(lapply(gen, as.numeric)))
+    res <- cbind(as.numeric(pop),as.data.frame(gen))
+    colnames(res) <- c("pop",x at loc.names)
+    if(!any(table(x at ind.names)>1)){
+        rownames(res) <- x at ind.names
+    } else {
+        warning("non-unique labels for individuals; using generic labels")
+        rownames(res) <- 1:nrow(res)
     }
 
-    ## function to recode a genotype in form "A1A2" (as integers) from frequencies
-    recod <- function(vec,lab){
-        if(all(is.na(vec))) return(NA)
-        if(sum(vec) < 0) return(NA)
-        temp <- which(vec!=0)
-        lab <- lab[temp]
-        res <- as.integer(paste(lab[1],lab[length(lab)],sep=""))
-        return(res)
-    }
-
-                                        # kGen is a list of nloc vectors of genotypes
-    kGen <- lapply(1:length(kX), function(i) apply(kX[[i]],1,recod,all.names[[i]]))
-    res <- cbind(as.numeric(pop),as.data.frame(kGen))
-    colnames(res) <- c("pop",x at loc.names)
-
     return(res)
-}
+} # end genind2hierfstat
 
 
 
 
+
 #####################
 # Function genind2df
 #####################