[adegenet-commits] r398 - pkg/R

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

Author: jombart
Date: 2009-06-12 12:57:55 +0200 (Fri, 12 Jun 2009)
New Revision: 398

Modified:
   pkg/R/haploSim.R
Log:
added a new arg to sample Haplo


Modified: pkg/R/haploSim.R
===================================================================
--- pkg/R/haploSim.R	2009-06-11 22:20:40 UTC (rev 397)
+++ pkg/R/haploSim.R	2009-06-12 10:57:55 UTC (rev 398)
@@ -279,6 +279,8 @@
     cat("\nHaplotype length :", ncol(x$seq),"nucleotids")
     cat("\nProportion of NA ancestors :", signif(mean(is.na(x$ances)),5))
     cat("\nNumber of known ancestors :", sum(!is.na(x$ances)))
+    nbAncInSamp <- sum(x$ances %in% labels(x))
+    cat("\nNumber of ancestors within the sample :", nbAncInSamp)
     cat("\nDate range :", min(x$dates,na.rm=TRUE),"-",max(x$dates,na.rm=TRUE))
     ##nUniqSeq <- length(unique(apply(as.character(x$seq),1,paste,collapse="")))
     ##cat("\nNumber of unique haplotypes :", nUniqSeq)
@@ -485,11 +487,17 @@
 ###################
 ## sample.haploSim
 ###################
-sample.haploSim <- function(x, n){
+sample.haploSim <- function(x, n, ancesWithinSample=FALSE){
     ## EXTRACT THE SAMPLE ##
+    if(ancesWithinSample)  {
+        available <- x$ances %in% labels(x)
+        res <- x[sample((1:nrow(x$seq))[available], n, replace=FALSE)]
+    } else {
     res <- x[sample(1:nrow(x$seq), n, replace=FALSE)]
 
+    }
 
+
     ## RETRIEVE SOME PARAMETERS FROM HAPLOSIM CALL
     prevCall <- as.list(x$call)
     if(!is.null(prevCall$mu)){