[adegenet-commits] r684 - pkg/R

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

Author: jombart
Date: 2010-10-07 19:10:32 +0200 (Thu, 07 Oct 2010)
New Revision: 684

Modified:
   pkg/R/dapc.R
Log:
added a.score function for dapc objects


Modified: pkg/R/dapc.R
===================================================================
--- pkg/R/dapc.R	2010-10-07 15:53:12 UTC (rev 683)
+++ pkg/R/dapc.R	2010-10-07 17:10:32 UTC (rev 684)
@@ -331,6 +331,39 @@
 
 
 
+###############
+## a.score
+###############
+a.score <- function(x, n.sim=10, n.da=length(levels(x$grp)), ...){
+    if(!inherits(x,"dapc")) stop("x is not a dapc object")
+
+    ## perform DAPC based on permuted groups
+    lsim <- lapply(1:n.sim, function(i) summary(dapc(x$tab, sample(x$grp), n.pca=ncol(x$tab), n.da=n.da))$assign.per.pop)
+    sumry <- summary(x)
+
+    ## get the a-scores
+    lscores <- lapply(lsim, function(e) (sumry$assign.per.pop-e)/(1-e))
+
+    ## make a table of a-scores
+    tab <- data.frame(lscores)
+    colnames(tab) <- paste("sim", 1:n.sim, sep=".")
+    rownames(tab) <- names(sumry$assign.per.pop)
+    tab <- t(as.matrix(tab))
+
+    ## make result
+    res <- list()
+    res$tab <- tab
+    res$pop.score <- apply(tab, 2, mean)
+    res$mean <- mean(tab)
+
+    return(res)
+
+} # end a.score
+
+
+
+
+
 ############
 ## crossval
 ############