[Mattice-commits] r40 - pkg/R

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

Author: andrew_hipp
Date: 2008-11-19 22:44:21 +0100 (Wed, 19 Nov 2008)
New Revision: 40

Modified:
   pkg/R/batchHansen.R
   pkg/R/regimes.R
   pkg/R/treeTraversal.R
Log:
continuing multiple tree fixes

Modified: pkg/R/batchHansen.R
===================================================================
--- pkg/R/batchHansen.R	2008-11-19 20:43:52 UTC (rev 39)
+++ pkg/R/batchHansen.R	2008-11-19 21:44:21 UTC (rev 40)
@@ -24,7 +24,7 @@
 #  "brown" = whether to analyse the data under a Brownian motion model
 #  "..." = additional arguments to pass along to hansen
 
-function(ouchTrees, characterStates, cladeMembersList, nodeNames <- NULL, maxNodes = NULL, regimeTitles = NULL, brown = F, rescale = 1, ...) {
+function(ouchTrees, characterStates, cladeMembersList, nodeNames = NULL, maxNodes = NULL, regimeTitles = NULL, brown = F, rescale = 1, ...) {
   ## do all the objects in ouchTrees inherit ouchtree?
   if(is(ouchTrees,'ouchtree')) ouchTrees <- list(ouchTrees)
   treeCheck <- unlist(lapply(ouchTrees, function(x) is(x,'ouchtree')))

Modified: pkg/R/regimes.R
===================================================================
--- pkg/R/regimes.R	2008-11-19 20:43:52 UTC (rev 39)
+++ pkg/R/regimes.R	2008-11-19 21:44:21 UTC (rev 40)
@@ -72,7 +72,7 @@
   times <- tree at times # class = "numeric"
   ## ------------------ end ouchtree block -------------------
   
-  if(identical(regimeTitles, NULL)) regimeTitles <- asCharacter(regimeShiftNodes)
+  if(identical(regimeTitles, NULL)) regimeTitles <- as.character(regimeShiftNodes)
   names(regimeTitles) = as.character(regimeShiftNodes)
   colorsVector = character(length(node))
   for (i in 1:length(ancestor)) {
@@ -178,15 +178,22 @@
   # set up variables
   numTrees <- length(ouchTrees)
   numNodes <- length(nodeMembers)
-  if(numNodes != dim(regMatrix)[1] stop('Number of nodes (columns) in regMatrix must equal number of items in nodeMembers list')
-  nodeMatrix <- matrix(NA, nrow = numTrees, ncol = numNodes, dimnames = list(seq(numTrees), dimnames(regMatrix)[2]))
+  if(numNodes != dim(regMatrix)[2]) stop('Number of nodes (columns) in regMatrix must equal number of items in nodeMembers list')
+  nodeMatrix <- matrix(NA, nrow = numTrees, ncol = numNodes, dimnames = list(seq(numTrees), dimnames(regMatrix)[[2]]))
   changeNodes <- list(numTrees)
   regList <- list(numTrees)
   
   # fill outdata
   for(i in seq(numNodes)) nodeMatrix[, i] <- unlist(lapply(ouchTrees, isMonophyletic, taxa = nodeMembers[[i]]))
   for(i in seq(numTrees)) {
-    changeNodes[[i]] <- c("1", unlist(lapply(nodeMembers[as.logical(nodeMatrix[i, ], mrcaOUCH, tree = ouchTrees[[i]])]))) # adds the root as a change so that paintBranches will work correctly
+    treeRegMatrix <- regMatrix * matrix(nodeMatrix[i, ], dim(regMatrix)[1], dim(regMatrix[2], byrow = T) # multiplies regMatrix by nodes present
+    treeRegMatrix <- treeRegMatrix[which(apply(treeRegMatrix, 1, sum) > 0), ] # subset for regimes that still have nodes
+    numTreeRegs <- dim(treeRegMatrix)[1]
+    treeRegs <- list(numTreeRegs)
+    for(j in seq(numTreeRegs)) {
+      changeNodes[[i]] <- c("1", unlist(lapply(nodeMembers[as.logical(nodeMatrix[i, ])], mrcaOUCH, tree = ouchTrees[[i]]))) # adds the root as a change so that paintBranches will work correctly
+      FINISH! 
+      }
     numNodesTemp <- sum(nodeMatrix[i, ])
     regList[[i]] <- lapply(changeNodes, paintBranches, tree = ouchTrees[[i]])
   }
@@ -194,7 +201,6 @@
   return(outdata)
 }
 
-
 regimeMatrix <- function(n = NULL, nodeNames = NULL, regimeNames = NULL, maxNodes = NULL) {
   if(identical(n, NULL) && identical(nodeNames, NULL)) stop("You have to give regimeMatrix the number of nodes, a vector of node names, or both")
   if(identical(nodeNames, NULL)) nodeNames <- as.character(seq(n))

Modified: pkg/R/treeTraversal.R
===================================================================
--- pkg/R/treeTraversal.R	2008-11-19 20:43:52 UTC (rev 39)
+++ pkg/R/treeTraversal.R	2008-11-19 21:44:21 UTC (rev 40)
@@ -26,13 +26,14 @@
 
 nodeDescendents <- function(tree, startNode) {
 ## Recursive function to find all the descendents of a node on an 'ouchtree' object
+## a bit clunky as written 
   startNode <- as.character(startNode) # just to be safe
   daughterBranches <- as.character(tree at nodes[tree at ancestors %in% startNode])
   nodeNames <- tree at nodelabels[tree at nodes %in% daughterBranches]
   if(!identical(as.character(daughterBranches), character(0))) {
     for(i in daughterBranches) nodeNames <- c(nodeNames, nodeDescendents(tree, i))
   }
-  return(nodeNames[!is.na(nodeNames)])
+  return(nodeNames[nodeNames %in% tree at nodelabels[tree at term]])
 }
   
 mrcaOUCH <-