[adegenet-commits] r764 - pkg/R

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

Author: jombart
Date: 2011-01-17 20:16:38 +0100 (Mon, 17 Jan 2011)
New Revision: 764

Modified:
   pkg/R/SNPbin.R
   pkg/R/glFunctions.R
Log:
A few tweaks to previous functions.
Essentially added the possibility to use multi-core parallel computing for intensive procedures.


Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R	2011-01-17 17:01:33 UTC (rev 763)
+++ pkg/R/SNPbin.R	2011-01-17 19:16:38 UTC (rev 764)
@@ -27,8 +27,9 @@
                                     ind.names = "charOrNULL",
                                     loc.names = "charOrNULL",
                                     loc.all = "charOrNULL",
-                                    ploidy = "intOrNULL"),
-         prototype(gen = list(), n.loc = integer(0), ind.names = NULL, loc.names = NULL, loc.all = NULL, ploidy=NULL))
+                                    ploidy = "intOrNULL",
+                                    other = "list"),
+         prototype(gen = list(), n.loc = integer(0), ind.names = NULL, loc.names = NULL, loc.all = NULL, ploidy=NULL, other=list()))
 
 
 
@@ -138,7 +139,12 @@
 ####################
 ## genlight constructor
 ####################
-setMethod("initialize", "genlight", function(.Object, ...) {
+setMethod("initialize", "genlight", function(.Object, ..., multicore=require("multicore"), n.cores=NULL) {
+    if(multicore && !require(multicore)) stop("multicore package requested but not installed")
+    if(multicore && is.null(n.cores)){
+        n.cores <- multicore:::detectCores()
+    }
+
     x <- .Object
     input <- list(...)
     if(length(input)==1) names(input) <- "gen"
@@ -175,7 +181,11 @@
                 }
             }
             ##input$gen <- lapply(1:nrow(input$gen), function(i) as.integer(input$gen[i,]))
-            x at gen <- lapply(1:nrow(input$gen), function(i) new("SNPbin", as.integer(input$gen[i,])) )
+            if(multicore){
+                x at gen <- mclapply(1:nrow(input$gen), function(i) new("SNPbin", as.integer(input$gen[i,])), mc.cores=n.cores, mc.silent=TRUE, mc.cleanup=TRUE)
+            } else {
+                x at gen <- lapply(1:nrow(input$gen), function(i) new("SNPbin", as.integer(input$gen[i,])) )
+            }
         }
 
 
@@ -198,7 +208,11 @@
             }
 
             ## create SNPbin list
-            x at gen <- lapply(input$gen, function(e) new("SNPbin",e))
+            if(multicore){
+                x at gen <- mclapply(input$gen, function(e) new("SNPbin",e), mc.cores=n.cores, mc.silent=TRUE, mc.cleanup=TRUE)
+            } else {
+                x at gen <- lapply(input$gen, function(e) new("SNPbin",e))
+            }
         }
     }
 

Modified: pkg/R/glFunctions.R
===================================================================
--- pkg/R/glFunctions.R	2011-01-17 17:01:33 UTC (rev 763)
+++ pkg/R/glFunctions.R	2011-01-17 19:16:38 UTC (rev 764)
@@ -12,7 +12,7 @@
     ## use ploidy (sum absolute frequencies)
     if(alleleAsUnit){
     res <- integer(nLoc(x))
-        for(e in x at gen){
+    for(e in x at gen){
             temp <- as.integer(e)
             temp[is.na(temp)] <- 0L
             res <- res + temp
@@ -153,9 +153,15 @@
 ##
 ## PCA for genlight objects
 ##
-glPca <- function(x, center=TRUE, scale=FALSE, nf=NULL, loadings=TRUE){
+glPca <- function(x, center=TRUE, scale=FALSE, nf=NULL, loadings=TRUE,
+                  multicore=require("multicore"), n.cores=NULL){
     if(!inherits(x, "genlight")) stop("x is not a genlight object")
+    if(multicore && !require(multicore)) stop("multicore package requested but not installed")
+    if(multicore && is.null(n.cores)){
+        n.cores <- multicore:::detectCores()
+    }
 
+
     ## COMPUTE MEANS AND VARIANCES ##
     if(center) {
        vecMeans <- glMean(x, alleleAsUnit=FALSE)
@@ -222,7 +228,12 @@
 
     ## COMPUTE ALL POSSIBLE DOT PRODUCTS (XX^T / n) ##
     allComb <- combn(1:nInd(x), 2)
-    allProd <- unlist(lapply(1:ncol(allComb), function(i) dotProd(x at gen[[allComb[1,i]]], x at gen[[allComb[2,i]]], myPloidy[allComb[1,i]], myPloidy[allComb[2,i]]) ))
+    if(multicore){
+        allProd <- unlist(mclapply(1:ncol(allComb), function(i) dotProd(x at gen[[allComb[1,i]]], x at gen[[allComb[2,i]]], myPloidy[allComb[1,i]], myPloidy[allComb[2,i]]),
+                                   mc.cores=n.cores, mc.silent=TRUE, mc.cleanup=TRUE))
+    } else {
+        allProd <- unlist(lapply(1:ncol(allComb), function(i) dotProd(x at gen[[allComb[1,i]]], x at gen[[allComb[2,i]]], myPloidy[allComb[1,i]], myPloidy[allComb[2,i]]) ))
+    }
     allProd <- allProd / nInd(x) # assume uniform weights
 
     ## shape result as a matrix
@@ -233,7 +244,12 @@
     allProd <- as.matrix(allProd)
 
     ## compute the diagonal
-    temp <- unlist(lapply(1:nInd(x), function(i) dotProd(x at gen[[i]], x at gen[[i]], myPloidy[i], myPloidy[i]) ))/nInd(x)
+    if(multicore){
+        temp <- unlist(mclapply(1:nInd(x), function(i) dotProd(x at gen[[i]], x at gen[[i]], myPloidy[i], myPloidy[i]),
+                                mc.cores=n.cores, mc.silent=TRUE, mc.cleanup=TRUE))/nInd(x)
+    } else {
+        temp <- unlist(lapply(1:nInd(x), function(i) dotProd(x at gen[[i]], x at gen[[i]], myPloidy[i], myPloidy[i]) ))/nInd(x)
+    }
     diag(allProd) <- temp
 
 
@@ -373,9 +389,9 @@
 
 ## ## LARGE SCALE TEST ##
 ## ## perform glPca
-## M <- matrix(sample(c(0,1), 200*1e6, replace=TRUE), nrow=200)
+## M <- matrix(sample(c(0,1), 50*1e5, replace=TRUE), nrow=50)
 ## x <- new("genlight",M)
-## toto <- glPca(x, nf=4)
+## toto <- glPca(x, nf=4, multicore=FALSE)
 
 ## round(cor(toto$scores),10) # must be diag(1,4)
 ## round(t(toto$loadings) %*% toto$loadings,10) # must be diag(1,4)