[adegenet-commits] r352 - in pkg: . R

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

Author: jombart
Date: 2009-06-03 22:29:15 +0200 (Wed, 03 Jun 2009)
New Revision: 352

Added:
   pkg/R/simuFlu.R
Modified:
   pkg/DESCRIPTION
   pkg/R/seqTrack.R
Log:
started to play with simuFlu; added the file and some nice code


Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2009-06-03 16:16:06 UTC (rev 351)
+++ pkg/DESCRIPTION	2009-06-03 20:29:15 UTC (rev 352)
@@ -9,4 +9,4 @@
 Description: Classes and functions for genetic data analysis within the multivariate framework.
 License: GPL (>=2)
 LazyLoad: yes
-Collate: classes.R auxil.R handling.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R colorplot.R loadingplot.R sequences.R seqTrack.R
+Collate: classes.R auxil.R handling.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R colorplot.R loadingplot.R sequences.R seqTrack.R simuFlu.R

Modified: pkg/R/seqTrack.R
===================================================================
--- pkg/R/seqTrack.R	2009-06-03 16:16:06 UTC (rev 351)
+++ pkg/R/seqTrack.R	2009-06-03 20:29:15 UTC (rev 352)
@@ -499,12 +499,9 @@
             } # end for j
 
             ## retain a given % (thres) of the dates ##
-            toKeep <- valRes < quantile(valRes, thres) ## NOT WORKING FOR optim==max !!!
+            toKeep <- valRes <= quantile(valRes, thres) ## NOT WORKING FOR optim==max !!!
 
             date <- date[,toKeep,drop=FALSE] # retained posterior
-            newDates <- apply(date, 1, function(vec)
-                              sample(vec, size=step.size, replace=TRUE)) # new prior
-            newDates <- t(newDates)
 
             ## DEBUGING ##
             cat("\ntoKeep:\n")
@@ -513,6 +510,9 @@
             print(head(date))
             ## END DEBUGING ##
 
+            newDates <- apply(date, 1, function(vec)
+                              sample(vec, size=step.size, replace=TRUE)) # new prior
+            newDates <- t(newDates)
 
             ## re-initialize posterior distributions
             if(i<nstep){
@@ -585,11 +585,15 @@
 
     ## reconstruct the result with new dates
     res <- lapply(1:ncol(date), function(i)
-                   seqTrack(seq.names=seq.names, seq.dates=date[,i], W=W,
+                   seqTrack(seq.names=seq.names, seq.dates=as.POSIXct(date[,i]), W=W,
                                     optim=optim, prox.mat=prox.mat, ...))
     ances <- data.frame(lapply(res, function(e) e$ances))
+    ances <- matrix(as.integer(unlist(ances)), nrow=nrow(ances))
+
     ances.date <- data.frame(lapply(res, function(e) e$ances.date))
+    ances.date <- matrix(as.character(unlist(ances.date)), nrow=nrow(ances.date))
 
+
     res <- list(ances=ances, date=date, ances.date=ances.date, valsim=valRes)
     return(res)
 
@@ -601,6 +605,19 @@
 
 
 
+
+
+
+#################
+## get.consensus
+#################
+get.consensus <- function(listres){
+
+    return(res)
+}
+
+
+
 ###############
 ## seqTrack.ml
 ###############

Added: pkg/R/simuFlu.R
===================================================================
--- pkg/R/simuFlu.R	                        (rev 0)
+++ pkg/R/simuFlu.R	2009-06-03 20:29:15 UTC (rev 352)
@@ -0,0 +1,27 @@
+simuFlu <- function(N=100, seq.length=100, mu=0.0035){
+    NUCL <- c("a","t","c","g")
+    res <- list()
+
+    ## AUXILIARY FUNCTIONS ##
+    ## generate sequence from scratch
+    gen.seq <- function(){
+        return(sample(NUCL, size=seq.length, replace=TRUE))
+    }
+
+    ## create substitutions for defined SNPs
+    substi <- function(snp){
+        res <- sapply(snp, function(e) sample(setdiff(NUCL,e),1))
+        return(res)
+    }
+
+    ## duplicate a sequence (including possible mutations)
+    seq.dupli <- function(seq){
+        toChange <- as.logical(rbinom(n=seq.length, size=1, prob=mu))
+        res <- seq
+        if(sum(toChange)>0) {
+            res[toChange] <- substi(res[toChange])
+        }
+        return(res)
+    }
+
+}