[Phylobase-commits] r659 - in branches/edgesNAto0: R data inst/unitTests man

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Wed Sep 23 02:33:02 CEST 2009


Author: pdc
Date: 2009-09-23 02:33:01 +0200 (Wed, 23 Sep 2009)
New Revision: 659

Modified:
   branches/edgesNAto0/R/checkdata.R
   branches/edgesNAto0/R/class-phylo4.R
   branches/edgesNAto0/R/class-phylomats.R
   branches/edgesNAto0/R/methods-phylo4.R
   branches/edgesNAto0/R/prune.R
   branches/edgesNAto0/R/setAs-Methods.R
   branches/edgesNAto0/R/treewalk.R
   branches/edgesNAto0/data/geospiza.rda
   branches/edgesNAto0/inst/unitTests/runit.class-phylo4d.R
   branches/edgesNAto0/inst/unitTests/runit.methods-phylo4.R
   branches/edgesNAto0/inst/unitTests/runit.methods-phylo4d.R
   branches/edgesNAto0/inst/unitTests/runit.setAs-Methods.R
   branches/edgesNAto0/inst/unitTests/runit.subset.R
   branches/edgesNAto0/man/phylo4-display.Rd
   branches/edgesNAto0/man/phylo4.Rd
   branches/edgesNAto0/man/subset-methods.Rd
Log:
Initial changeset for root ancestor change

Modified: branches/edgesNAto0/R/checkdata.R
===================================================================
--- branches/edgesNAto0/R/checkdata.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/checkdata.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -60,12 +60,13 @@
     if (!all(nDesc[1:nTips]==0))
       return("nodes 1 to nTips must all be tips")
 
-    if (nRoots>0) {
-      if (sum(is.na(E[,1]))!=1) {
-        return("for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==NA")
+    if (nRoots > 0) {
+      if (sum(E[, 1] == 0) != 1) {
+        return("for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==0")
       }
-      root.node <- unname(E[which(is.na(E[,1])),2])
-      if (!root.node==nTips+1)
+      root.node <- unname(E[which(E[,1] == 0), 2])
+      if (!root.node == nTips + 1)
+        ## TODO this isn't actually a requirement
         return("root node must be first row of edge matrix")
     }
 
@@ -109,7 +110,7 @@
     }
     else {
         if(!all(names(object at node.label) %in%  nodeId(object, "internal")))
-            stop("Internal names for tips don't match tip ID numbers")
+            stop("Internal names for nodes don't match node ID numbers")
     }
 
     if(hasEdgeLength(object)) {

Modified: branches/edgesNAto0/R/class-phylo4.R
===================================================================
--- branches/edgesNAto0/R/class-phylo4.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/class-phylo4.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -117,8 +117,10 @@
     colnames(edge) <- c("ancestor", "descendant")
 
     ## number of tips and number of nodes
-    ntips <- sum(tabulate(na.omit(edge[, 1])) == 0)
-    nnodes <- length(unique(na.omit(c(edge)))) - ntips
+    ntips  <- sum(tabulate(na.omit(edge[, 1])) == 0)
+    # all the internal nodes except the root are the ancestor of an edge
+    nnodes <- sum(unique(c(edge)) != 0) - ntips
+    ## nnodes <- length(unique(na.omit(c(edge)))) - ntips
 
     ## edge.length
     edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE)

Modified: branches/edgesNAto0/R/class-phylomats.R
===================================================================
--- branches/edgesNAto0/R/class-phylomats.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/class-phylomats.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -77,7 +77,7 @@
         ## add explicit root
         rootnode <- which(tabulate(temptree$edgemat[,2])==0)
         ## add root node to edge matrix and branch lengths
-        temptree$edgemat <- rbind(temptree$edgemat,c(NA,rootnode))
+        temptree$edgemat <- rbind(temptree$edgemat, c(0, rootnode))
         temptree$edgelens <- c(temptree$edgelens,NA)
         reorder(phylo4(temptree$edgemat,edge.length=temptree$edgelens,
                tip.label=rownames(from),

Modified: branches/edgesNAto0/R/methods-phylo4.R
===================================================================
--- branches/edgesNAto0/R/methods-phylo4.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/methods-phylo4.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -92,7 +92,11 @@
     if(nTips(x) == 0)
         return(NULL)
     else {
-        listNodes <- sort(unique(as.vector(edges(x))))
+        ## strip out the root ancestor
+        nodesVect <- as.vector(edges(x))
+        nodesVect <- nodesVect[nodesVect != 0]
+        ## get a sorted list of the unique nodes 
+        listNodes <- sort(unique(nodesVect))
         t <- rep("internal", length(listNodes)) # FM: internal is default (I think it's safer)
         names(t) <- listNodes
 
@@ -121,13 +125,13 @@
      ## 1:nTips and nodes are not (nTips+1):nNodes
      nid <- switch(type,
          ## all nodes appear at least once in the edge matrix
-         all = unique(na.omit(as.vector(E))),
+         all = unique(as.vector(E)[as.vector(E) != 0]),
          ## tips are nodes that do not appear in the ancestor column
          tip = setdiff(E[, 2], E[, 1]),
          ## internals are nodes that *do* appear in the ancestor column
-         internal = na.omit(unique(E[, 1])),
+         internal = unique(E[E[, 1] != 0, 1]),
          ## roots are nodes that have NA as ancestor
-         root = if (!isRooted(x)) NA else unname(E[is.na(E[, 1]), 2]))
+         root = if (!isRooted(x)) NA else unname(E[E[, 1] == 0, 2]))
 
      return(sort(nid))
 
@@ -148,7 +152,7 @@
 setMethod("edges", signature(x="phylo4"),
  function(x, order, drop.root=FALSE, ...) {
      e <- x at edge
-     if (drop.root) e <- e[!is.na(e[,1]),]
+     if (drop.root) e <- e[e[, 1] != 0, ]
      e
 })
 
@@ -170,7 +174,7 @@
         isInt <- (edge[, 2] %in% edge[, 1])
         edge <- edge[isInt, , drop=FALSE]
     } else if (type=="root") {
-        isRoot <- is.na(edge[, 1])
+        isRoot <- edge[, 1] == 0
         edge <- edge[isRoot, , drop=FALSE]
     } # else just use complete edge matrix if type is "all"
     id <- paste(edge[, 1], edge[, 2], sep="-")
@@ -228,14 +232,14 @@
  function(x) {
     ## hack to avoid failure on an empty object
     if(nTips(x) == 0) return(FALSE)
-    any(is.na(edges(x)[,1]))
+    any(edges(x)[, 1] == 0)
 })
 
 setMethod("rootNode", signature(x="phylo4"),
  function(x) {
     if (!isRooted(x))
         return(NA)
-    unname(edges(x)[which(is.na(edges(x)[,1])),2])
+    unname(edges(x)[which(edges(x)[, 1] == 0), 2])
 })
 
 setReplaceMethod("rootNode", signature(x="phylo4"),
@@ -537,7 +541,7 @@
         stop("Tree must be rooted to reorder")
     }
     ## get a root node free edge matrix
-    edge <- edges(x)[!is.na(edges(x)[, 1]), ]
+    edge <- edges(x, drop.root=TRUE)
     ## Sort edges -- ensures that starting order of edge matrix doesn't
     ## affect the order of reordered trees
     edge <- edge[order(edge[, 2]), ]

Modified: branches/edgesNAto0/R/prune.R
===================================================================
--- branches/edgesNAto0/R/prune.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/prune.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -41,7 +41,7 @@
     ## remove singletons
     edge.length.new <- edgeLength(x)
     edge.label.new <- edgeLabels(x)
-    singletons <- which(tabulate(na.omit(edge.new[,1]))==1)
+    singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1)
     while (length(singletons)>0) {
         sing.node <- singletons[1]
 
@@ -62,7 +62,7 @@
         edge.label.new <- edge.label.new[-match(edge.names.drop,
             names(edge.label.new))]
 
-        singletons <- which(tabulate(na.omit(edge.new[,1]))==1)
+        singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1)
     }
 
     ## remove dropped elements from tip.label and node.label
@@ -96,7 +96,7 @@
     }
 
     ## renumber nodes in the edge matrix
-    edge.new[] <- match(edge.new, sort(unique.default(edge.new)))
+    edge.new[] <- match(edge.new, sort(unique.default(edge.new))) - 1
 
     ## update corresponding element names in the other slots
     edge.names <- makeEdgeNames(edge.new)

Modified: branches/edgesNAto0/R/setAs-Methods.R
===================================================================
--- branches/edgesNAto0/R/setAs-Methods.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/setAs-Methods.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -12,7 +12,7 @@
         }
         root.node <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2])))
 
-        from$edge <- rbind(from$edge[tip.idx,],c(NA,root.node),from$edge[int.idx,])
+        from$edge <- rbind(from$edge[tip.idx,],c(0,root.node),from$edge[int.idx,])
         if (!is.null(from$edge.length)) {
             if (is.null(from$root.edge)) {
                 from$edge.length <- c(from$edge.length[tip.idx],as.numeric(NA),from$edge.length[int.idx])

Modified: branches/edgesNAto0/R/treewalk.R
===================================================================
--- branches/edgesNAto0/R/treewalk.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/R/treewalk.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -9,7 +9,7 @@
 
 getNode <- function(phy, node, missing=c("warn","OK","fail")) {
     missing <- match.arg(missing)
-
+    browser()
     if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) {
         node <- as.integer(node)
     }
@@ -28,11 +28,15 @@
     ## node numbers
     rval <- names(labels(phy, "all"))[irval]
     rval <- as.integer(rval)
+    browser()
+    rval[node == 0]   <- "0" # root ancestor gets special treatment
     rval[is.na(node)] <- NA # return NA for any NA_character_ inputs
 
     ## node labels
     nmNd <- labels(phy, "all")[irval]
+
     names(rval) <- nmNd
+    names(rval)[rval == "0"] <- "0" # root ancestor gets special treatment
 
     ## deal with nodes that don't match
     if (any(is.na(rval))) {

Modified: branches/edgesNAto0/data/geospiza.rda
===================================================================
(Binary files differ)

Modified: branches/edgesNAto0/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- branches/edgesNAto0/inst/unitTests/runit.class-phylo4d.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/inst/unitTests/runit.class-phylo4d.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -7,7 +7,7 @@
 tr <- read.tree(text=nwk)
 
 # create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
 descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
 edge <- cbind(ancestor, descendant)
 nid.tip <- 1:5

Modified: branches/edgesNAto0/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- branches/edgesNAto0/inst/unitTests/runit.methods-phylo4.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/inst/unitTests/runit.methods-phylo4.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -7,7 +7,7 @@
 tr <- read.tree(text=nwk)
 
 # create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
 descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
 edge <- cbind(ancestor, descendant)
 nid.tip <- 1:5
@@ -69,7 +69,7 @@
 
 test.edges.phylo4 <- function() {
   checkIdentical(edges(phy.alt), edge)
-  checkIdentical(edges(phy.alt, drop.root=TRUE), edge[!is.na(edge[,1]),])
+  checkIdentical(edges(phy.alt, drop.root=TRUE), edge[edge[,1] != 0,])
 }
 
 test.edgeOrder.phylo4 <- function() {
@@ -84,7 +84,7 @@
   checkIdentical(edgeId(phy.alt, "all"), eid)
   checkIdentical(edgeId(phy.alt, "tip"), eid[descendant %in% nid.tip])
   checkIdentical(edgeId(phy.alt, "internal"), eid[!descendant %in% nid.tip])
-  checkIdentical(edgeId(phy.alt, "root"), eid[is.na(ancestor)])
+  checkIdentical(edgeId(phy.alt, "root"), eid[ancestor == 0])
 }
 
 test.hasEdgeLength.phylo4 <- function() {

Modified: branches/edgesNAto0/inst/unitTests/runit.methods-phylo4d.R
===================================================================
--- branches/edgesNAto0/inst/unitTests/runit.methods-phylo4d.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/inst/unitTests/runit.methods-phylo4d.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -3,7 +3,7 @@
 #
 
 # create phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
 descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
 edge <- cbind(ancestor, descendant)
 nid.tip <- 1:5

Modified: branches/edgesNAto0/inst/unitTests/runit.setAs-Methods.R
===================================================================
--- branches/edgesNAto0/inst/unitTests/runit.setAs-Methods.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/inst/unitTests/runit.setAs-Methods.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -7,7 +7,7 @@
 tr <- read.tree(text=nwk)
 
 # create analogous phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
 descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
 edge <- cbind(ancestor, descendant)
 nid.tip <- 1:5

Modified: branches/edgesNAto0/inst/unitTests/runit.subset.R
===================================================================
--- branches/edgesNAto0/inst/unitTests/runit.subset.R	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/inst/unitTests/runit.subset.R	2009-09-23 00:33:01 UTC (rev 659)
@@ -3,7 +3,7 @@
 #
 
 # create phylo4 object with a full complement of valid slots
-ancestor <- as.integer(c(6,7,7,6,8,NA,8,9,9))
+ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9))
 descendant <- as.integer(c(7,1,2,8,3,6,9,4,5))
 edge <- cbind(ancestor, descendant)
 nid.tip <- 1:5

Modified: branches/edgesNAto0/man/phylo4-display.Rd
===================================================================
--- branches/edgesNAto0/man/phylo4-display.Rd	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/man/phylo4-display.Rd	2009-09-23 00:33:01 UTC (rev 659)
@@ -92,7 +92,7 @@
      11,  5,
      11,  6,
      11,  7,
-     NA,  8), ncol=2, byrow=TRUE)
+      0,  8), ncol=2, byrow=TRUE)
 
   P2 <- phylo4(E)
   nodeLabels(P2) <- as.character(nodeId(P2, "internal"))

Modified: branches/edgesNAto0/man/phylo4.Rd
===================================================================
--- branches/edgesNAto0/man/phylo4.Rd	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/man/phylo4.Rd	2009-09-23 00:33:01 UTC (rev 659)
@@ -79,21 +79,21 @@
      
 \examples{
 # a three species tree:
-mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3,NA,4), ncol=2,
+mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3, 0,4), ncol=2,
 byrow=TRUE), tip.label=c("speciesA", "speciesB", "speciesC")) 
 mytree
 plot(mytree)
 
 # another way to specify the same tree:
-mytree <- phylo4(x=cbind(c(4,4,5,5,NA), c(1,5,2,3,4)),
+mytree <- phylo4(x=cbind(c(4, 4, 5, 5, 0), c(1, 5, 2, 3, 4)),
 tip.label=c("speciesA", "speciesB", "speciesC")) 
 
 # another way:
-mytree <- phylo4(x=rbind(c(4,1), c(4,5), c(5,2), c(5,3), c(NA,4)),
+mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)),
 tip.label=c("speciesA", "speciesB", "speciesC")) 
 
 # with branch lengths:
-mytree <- phylo4(x=rbind(c(4,1), c(4,5), c(5,2), c(5,3), c(NA,4)),
+mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)),
 tip.label=c("speciesA", "speciesB", "speciesC"), edge.length=c(1, .2,
 .8, .8, NA))
 plot(mytree)

Modified: branches/edgesNAto0/man/subset-methods.Rd
===================================================================
--- branches/edgesNAto0/man/subset-methods.Rd	2009-09-23 00:26:12 UTC (rev 658)
+++ branches/edgesNAto0/man/subset-methods.Rd	2009-09-23 00:33:01 UTC (rev 659)
@@ -142,7 +142,7 @@
 geospiza[c(1:6,14), c("wingL", "beakD")]
 
 ## note handling of root edge length:
-edgeLength(geotree)['NA-15'] <- 0.1
+edgeLength(geotree)['0-15'] <- 0.1
 geotree2 <- geotree[1:2]
 ## in subset tree, edge of new root extends back to the original root
 edgeLength(geotree2)['NA-3']



More information about the Phylobase-commits mailing list