[Phylobase-commits] r360 - pkg/R

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

Author: bbolker
Date: 2008-12-20 01:58:16 +0100 (Sat, 20 Dec 2008)
New Revision: 360

Modified:
   pkg/R/checkdata.R
   pkg/R/methods-phylo4.R
Log:
  added nodelabel length check; check for explicit edge matrix;
re-add root = nTips+1 check



Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R	2008-12-20 00:16:18 UTC (rev 359)
+++ pkg/R/checkdata.R	2008-12-20 00:58:16 UTC (rev 360)
@@ -26,6 +26,21 @@
     nTips <- sum(nDesc==0)
     if (!all(nDesc[1:nTips]==0))
       return("nodes 1 to nTips must all be tips")
+    nRoots <- sum(nAncest==0)
+    ## no longer 
+    ##if (which(nAncest==0)!=nTips+1) {
+    ##  return("root node is not at position (nTips+1)")
+    ##}
+    
+    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")
+      }
+      root.node <- unname(E[which(is.na(E[,1])),2])
+      if (!root.node==nTips+1)
+        return("root node must be first row of edge matrix")
+    }
+
     ##fixme following check fails for unrooted trees
     ##if (!all(nDesc[(nTips+1):(nTips+nNodes(object))]>0))
     ##  return("nodes (nTips+1) to (nTips+nNodes) must all be internal nodes")
@@ -35,13 +50,6 @@
         if ("poly" %in% warn)
           warning("tree includes polytomies")
     }
-    nRoots <- sum(nAncest==0)
-    ##if (which(nAncest==0)!=nTips+1) {
-    ##  return("root node is not at position (nTips+1)")
-    ##}
-    ##if (any(nAncest==0) && E[1,1]!=nTips+1) {
-    ##  return("root node must be first row of edge matrix")
-    ##}
 
     ##
     ## how do we identify loops???

Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R	2008-12-20 00:16:18 UTC (rev 359)
+++ pkg/R/methods-phylo4.R	2008-12-20 00:58:16 UTC (rev 360)
@@ -150,6 +150,8 @@
 setReplaceMethod("nodeLabels", "phylo4",
                  function(object, ..., value) {
                    ## FIXME: test length!
+                   if (length(value)!=nNodes(object))
+                     stop("label vector must have as many elements as number of internal nodes")
                    object at node.label <- value
                    object
                  })