[Phylobase-commits] r689 - in pkg: R tests

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

Author: regetz
Date: 2009-10-08 00:26:16 +0200 (Thu, 08 Oct 2009)
New Revision: 689

Modified:
   pkg/R/class-phylo4.R
   pkg/tests/phylotorture.Rout.save
Log:
changed phylo4('matrix') constructor to stop storing NA elements when
not explicitly needed in slots; closes ticket #680


Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R	2009-10-06 22:37:55 UTC (rev 688)
+++ pkg/R/class-phylo4.R	2009-10-07 22:26:16 UTC (rev 689)
@@ -114,29 +114,33 @@
     edge <- as.matrix(edge[, 1:2])
     colnames(edge) <- c("ancestor", "descendant")
 
-    ## number of tips and number of nodes
-    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
+    ## create new phylo4 object and insert edge matrix
+    res <- new("phylo4")
+    res at edge <- edge
 
-    ## edge.length
+    ## get number of tips and number of nodes
+    ## (these accessors work fine now that edge matrix exists)
+    ntips <- nTips(res)
+    nnodes <- nNodes(res)
+
+    ## edge.length (drop elements if all are NA)
     edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE)
+    if (all(is.na(edge.length))) edge.length <- numeric()
 
-    ## edge.label
+    ## edge.label (drop NA elements)
     edge.label <- .createEdge(value=edge.label, edgeMat=edge, type="labels", use.names=FALSE)
+    edge.label <- edge.label[!is.na(edge.label)]
 
-    ## tip.label
+    ## tip.label (leave NA elements; let checkTree complain about it)
     tip.label <- .createLabels(value=tip.label, ntips=ntips, nnodes=nnodes,
                                type="tip")
 
-    ## node.label
+    ## node.label (drop NA elements)
     node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes,
                                 type="internal")
+    node.label <- node.label[!is.na(node.label)]
 
-    ## fill in the result
-    res <- new("phylo4")
-    res at edge <- edge
+    ## populate the slots
     res at edge.length <- edge.length
     res at label <- c(tip.label, node.label)
     res at edge.label <- edge.label

Modified: pkg/tests/phylotorture.Rout.save
===================================================================
--- pkg/tests/phylotorture.Rout.save	2009-10-06 22:37:55 UTC (rev 688)
+++ pkg/tests/phylotorture.Rout.save	2009-10-07 22:26:16 UTC (rev 689)
@@ -43,10 +43,8 @@
 > OKvals <- sapply(p1,class)!="try-error"
 > table(sapply(p1[!OKvals],as.character))
 
-   Error in .local(x, ...) : tips and nodes incorrectly numbered\n 
-                                                                 9 
-Error in vector("character", length) : invalid 'length' argument\n 
-                                                                 1 
+Error in .local(x, ...) : tips and nodes incorrectly numbered\n 
+                                                             10 
 > 
 > if (any(OKvals)) {
 +     p2 <- p1[OKvals]