[adegenet-commits] r1132 - pkg/R

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

Author: jombart
Date: 2013-05-16 17:22:54 +0200 (Thu, 16 May 2013)
New Revision: 1132

Modified:
   pkg/R/dapc.R
Log:
changing the default colors of scatter dapc

Modified: pkg/R/dapc.R
===================================================================
--- pkg/R/dapc.R	2013-05-16 08:14:12 UTC (rev 1131)
+++ pkg/R/dapc.R	2013-05-16 15:22:54 UTC (rev 1132)
@@ -486,7 +486,7 @@
 ##############
 ## scatter.dapc
 ##############
-scatter.dapc <- function(x, xax=1, yax=2, grp=x$grp, col=rainbow(length(levels(grp))), pch=20, bg="lightgrey", solid=.7,
+scatter.dapc <- function(x, xax=1, yax=2, grp=x$grp, col=seasun(length(levels(grp))), pch=20, bg="white", solid=.7,
                          scree.da=TRUE, scree.pca=FALSE, posi.da="bottomright", posi.pca="bottomleft", bg.inset="white",
                          ratio.da=.25, ratio.pca=.25, inset.da=0.02, inset.pca=0.02, inset.solid=.5,
                          onedim.filled=TRUE, mstree=FALSE, lwd=1, lty=1, segcol="black",
@@ -514,8 +514,8 @@
         par(mar = c(0.1, 0.1, 0.1, 0.1), bg=bg)
         on.exit(par(opar))
         axes <- c(xax,yax)
+
         ## basic empty plot
-        ## s.label(x$ind.coord[,axes], clab=0, cpoint=0, grid=FALSE, addaxes = FALSE, cgrid = 1, include.origin = FALSE, ...)
         s.class(x$ind.coord[,axes], fac=grp, col=col, cpoint=0, cstar = cstar, cellipse = cellipse, axesell = axesell, label = label,
                 clabel = clabel, xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, origin = origin, include.origin = include.origin,
                 sub = sub, csub = csub, possub = possub, cgrid = cgrid, pixmap = pixmap, contour = contour, area = area)
@@ -547,6 +547,8 @@
         }
 
     } else {
+        ## set screeplot of DA to FALSE (just 1 bar)
+        scree.da <- FALSE
 
         ## get plotted axis
         if(ncol(x$ind.coord)==1) {
@@ -989,12 +991,14 @@
 
 xvalDapc <- function (x, ...) UseMethod("xvalDapc")
 
-xvalDapc.data.frame <- function(x, grp, n.pca.max, n.da=NULL, training.set = 1/2,
+xvalDapc.data.frame <- function(x, grp, n.pca.max, n.da=NULL, training.set = 0.9,
+                                result=c("groupMean","overall"),
                                 center=TRUE, scale=FALSE, n.pca=NULL, n.rep=10, ...){
 
     ## CHECKS ##
     grp <- factor(grp)
     n.pca <- n.pca[n.pca>0]
+    result <- match.arg(result)
     if(is.null(n.da)) {
         n.da <- length(levels(grp))-1
     }
@@ -1023,7 +1027,13 @@
             temp.pca$li <- temp.pca$li[toKeep,,drop=FALSE]
             temp.dapc <- suppressWarnings(dapc(x[toKeep,,drop=FALSE], grp[toKeep], n.pca=n.pca, n.da=n.da, dudi=temp.pca))
             temp.pred <- predict.dapc(temp.dapc, newdata=x[-toKeep,,drop=FALSE])
-            return(mean(temp.pred$assign==grp[-toKeep]))
+            if(result=="overall"){
+                out <- mean(temp.pred$assign==grp[-toKeep])
+            }
+            if(result=="groupMean"){
+                out <- mean(tapply(temp.pred$assign==grp[-toKeep], grp[-toKeep], mean))
+            }
+            return(out)
         }
         return(replicate(n.rep, f1()))
     }
@@ -1043,48 +1053,48 @@
 
 
 
-#############
-## discriVal
-#############
+## #############
+## ## discriVal
+## #############
 
-discriVal <- function (x, ...) UseMethod("discriVal")
+## discriVal <- function (x, ...) UseMethod("discriVal")
 
-discriVal.data.frame <- function(x, grp, n.pca.max, n.da=NULL, center=TRUE, scale=FALSE, n.pca=NULL, ...){
+## discriVal.data.frame <- function(x, grp, n.pca.max, n.da=NULL, center=TRUE, scale=FALSE, n.pca=NULL, ...){
 
-    ## CHECKS ##
-    grp <- factor(grp)
-    n.pca <- n.pca[n.pca>0]
-    if(is.null(n.da)) {
-        n.da <- length(levels(grp))-1
-    }
+##     ## CHECKS ##
+##     grp <- factor(grp)
+##     n.pca <- n.pca[n.pca>0]
+##     if(is.null(n.da)) {
+##         n.da <- length(levels(grp))-1
+##     }
 
-    ## GET FULL PCA ##
-    if(missing(n.pca.max)) n.pca.max <- min(dim(x))
-    pcaX <- dudi.pca(x, nf=n.pca.max, scannf=FALSE, center=center, scale=scale)
-    n.pca.max <- min(n.pca.max,pcaX$rank)
+##     ## GET FULL PCA ##
+##     if(missing(n.pca.max)) n.pca.max <- min(dim(x))
+##     pcaX <- dudi.pca(x, nf=n.pca.max, scannf=FALSE, center=center, scale=scale)
+##     n.pca.max <- min(n.pca.max,pcaX$rank)
 
-    ## DETERMINE N.PCA IF NEEDED ##
-    if(is.null(n.pca)){
-        n.pca <- round(pretty(1:n.pca.max,10))
-    }
-    n.pca <- n.pca[n.pca>0 & n.pca<n.pca.max]
+##     ## DETERMINE N.PCA IF NEEDED ##
+##     if(is.null(n.pca)){
+##         n.pca <- round(pretty(1:n.pca.max,10))
+##     }
+##     n.pca <- n.pca[n.pca>0 & n.pca<n.pca.max]
 
-    ## FUNCTION GETTING THE TOTAL DISCRIMINATION (SUM OF EIGENVALUES) FOR ONE GIVEN NB OF PCA PCs ##
-    ## n.pca is a number of retained PCA PCs
-    get.totdiscr <- function(n.pca){
-            temp.dapc <- suppressWarnings(dapc(x, grp, n.pca=n.pca, n.da=n.da, dudi=pcaX))
-            return(sum(temp.dapc$eig))
-    }
+##     ## FUNCTION GETTING THE TOTAL DISCRIMINATION (SUM OF EIGENVALUES) FOR ONE GIVEN NB OF PCA PCs ##
+##     ## n.pca is a number of retained PCA PCs
+##     get.totdiscr <- function(n.pca){
+##             temp.dapc <- suppressWarnings(dapc(x, grp, n.pca=n.pca, n.da=n.da, dudi=pcaX))
+##             return(sum(temp.dapc$eig))
+##     }
 
 
-    ## GET %SUCCESSFUL OF ACCURATE PREDICTION FOR ALL VALUES ##
-    res.all <- sapply(n.pca, get.totdiscr)
-    res <- data.frame(n.pca=n.pca, success=res.all)
-    return(res)
-} # end discriVal.data.frame
+##     ## GET %SUCCESSFUL OF ACCURATE PREDICTION FOR ALL VALUES ##
+##     res.all <- sapply(n.pca, get.totdiscr)
+##     res <- data.frame(n.pca=n.pca, success=res.all)
+##     return(res)
+## } # end discriVal.data.frame
 
 
-discriVal.matrix <- discriVal.data.frame
+## discriVal.matrix <- discriVal.data.frame