[adegenet-commits] r662 - pkg/R

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

Author: jombart
Date: 2010-09-08 17:03:29 +0200 (Wed, 08 Sep 2010)
New Revision: 662

Modified:
   pkg/R/fstat.R
Log:
Implementation seems ok.


Modified: pkg/R/fstat.R
===================================================================
--- pkg/R/fstat.R	2010-09-08 14:47:56 UTC (rev 661)
+++ pkg/R/fstat.R	2010-09-08 15:03:29 UTC (rev 662)
@@ -29,12 +29,12 @@
 
 
 ###############
-# fst function
+## pairwise.fst
 ###############
-#
-# classical fst sensu Nei
-#
-pairwise.fst <- function(x, pop=NULL, res.type=c("dist","matrix")){
+##
+## pairwise fst sensu Nei (Ht - mean(Hs))/Ht
+##
+pairwise.fst <- function(x, pop=NULL, res.type=c("dist","matrix"), truenames=TRUE){
     ## MISC CHECKS ##
     if(!is.genind(x)) stop("x is not a valid genind object")
     if(!is.null(pop)){
@@ -47,7 +47,9 @@
         return(NULL)
     }
 
+    res.type <- match.arg(res.type)
 
+
     ## COMPUTATIONS ##
 
     ## function to compute one Fst ##
@@ -70,5 +72,22 @@
     for(i in 1:ncol(allPairs)){
         vecRes[i] <- f1(lx[[allPairs[1,i]]], lx[[allPairs[2,i]]])
     }
+
+
+    squelres <- dist(1:length(levPop))
+    res <- vecRes
+    attributes(res) <- attributes(squelres)
+
+    if(res.type=="matrix"){
+        res <- as.matrix(res)
+        if(truenames){
+            lab <- x at pop.names
+        } else {
+            lab <- names(x at pop.names)
+        }
+
+        colnames(res) <- rownames(res) <- lab
+    }
+
     return(res)
 } # end of pairwise.fst