[adegenet-commits] r382 - pkg/R

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

Author: jombart
Date: 2009-06-08 18:13:24 +0200 (Mon, 08 Jun 2009)
New Revision: 382

Modified:
   pkg/R/haploSim.R
   pkg/R/seqTrack.R
Log:
One fix to use nb of nucleotids in optimize.haploSim.
working on compromise computations.


Modified: pkg/R/haploSim.R
===================================================================
--- pkg/R/haploSim.R	2009-06-08 15:26:42 UTC (rev 381)
+++ pkg/R/haploSim.R	2009-06-08 16:13:24 UTC (rev 382)
@@ -385,10 +385,10 @@
 optimize.seqTrack.haploSim <- function(x, thres=0.2, optim=c("min","max"),
                               prox.mat=NULL, nstep=10, step.size=1e3, rMissDate=.rUnifTimeSeq, ...){
 
-    myX <- dist.dna(x$seq, model="raw")
     seq.names <- labels(x)
     seq.dates <- as.POSIXct(x)
     seq.length <- ncol(x$seq)
+    myX <- dist.dna(x$seq, model="raw") * seq.length
     prevCall <- as.list(x$call)
     if(is.null(prevCall$mu)){
         mu0 <- 0.0001

Modified: pkg/R/seqTrack.R
===================================================================
--- pkg/R/seqTrack.R	2009-06-08 15:26:42 UTC (rev 381)
+++ pkg/R/seqTrack.R	2009-06-08 16:13:24 UTC (rev 382)
@@ -617,7 +617,6 @@
 
 
 
-
 #################
 ## get.result.by
 #################
@@ -672,7 +671,28 @@
 ## get.consensus
 #################
 get.consensus <- function(listres){
+    res <- list()
 
+    ## tables of occurences of ancestors
+    temp <- apply(listres$ances, 1, table)
+
+    ## compute compromise
+    if(is.vector(temp)){
+        newances <- temp
+    } else {
+        f1 <- function(tab){
+            res <- names(tab)[tab==max(tab)]
+            if(length(res)==1) return(res)
+            return(NA)
+        }
+
+        newances <- sapply(temp, f1)
+        ances.support <- sapply(temp, function(e) max(e, na.rm=TRUE)/sum(e, na.rm=TRUE))
+    }
+
+    ## form the output
+    res$id <- 1:nrow(listres$ances)
+    res$ances
     return(res)
 }