[adegenet-commits] r687 - pkg/R

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

Author: jombart
Date: 2010-10-18 12:44:24 +0200 (Mon, 18 Oct 2010)
New Revision: 687

Modified:
   pkg/R/dapc.R
Log:
changes to a-score done in Lyon


Modified: pkg/R/dapc.R
===================================================================
--- pkg/R/dapc.R	2010-10-18 10:43:10 UTC (rev 686)
+++ pkg/R/dapc.R	2010-10-18 10:44:24 UTC (rev 687)
@@ -334,18 +334,21 @@
 ###############
 ## a.score
 ###############
-a.score <- function(x, n.sim=10, n.da=length(levels(x$grp)), ...){
+a.score <- function(x, n.sim=10, n.pca=ncol(x$tab), n.da=length(levels(x$grp)), ...){
     if(!inherits(x,"dapc")) stop("x is not a dapc object")
+    if(n.pca>ncol(x$tab)) stop("too many PCA axes retained")
+    if(n.da>length(levels(x$grp))) stop("too many DA axes retained")
 
     ## 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)
+    lsim <- lapply(1:n.sim, function(i) summary(dapc(x$tab[,1:n.pca], sample(x$grp), n.pca=n.pca, n.da=n.da))$assign.per.pop)
     sumry <- summary(x)
 
     ## get the a-scores
     f1 <- function(Pt, Pf){
         tol <- 1e-7
-        res <- (Pt-Pf) / (1-Pf)
-        res[Pf > (1-tol)] <- 0
+        ##res <- (Pt-Pf) / (1-Pf)
+        ##res[Pf > (1-tol)] <- 0
+        res <- Pt-Pf
         return(res)
     }
 
@@ -371,6 +374,29 @@
 
 
 
+
+
+##############
+## optim.ascore
+##############
+optim.ascore <- function(x, n.da=length(levels(x$grp)), min.dim=1, max.dim=ncol(x$tab), ...){
+    ## a few checks
+    if(!inherits(x,"dapc")) stop("x is not a dapc object")
+    if(n.pca>ncol(x$tab)) stop("too many PCA axes retained")
+    if(n.da>length(levels(x$grp))) stop("too many DA axes retained")
+
+
+    ## auxiliary function
+    f1 <- function(ndim){
+        a.score(x, n.pca=ndim, n.da=n.da)$mean
+    }
+
+
+}
+
+
+
+
 ############
 ## crossval
 ############