[Phylobase-commits] r335 - pkg/R

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

Author: skembel
Date: 2008-12-19 20:58:11 +0100 (Fri, 19 Dec 2008)
New Revision: 335

Modified:
   pkg/R/class-phylo4.R
   pkg/R/methods-phylo4.R
Log:
Fixing root node checking and representation

Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R	2008-12-19 18:48:51 UTC (rev 334)
+++ pkg/R/class-phylo4.R	2008-12-19 19:58:11 UTC (rev 335)
@@ -4,8 +4,7 @@
                         Nnode = "integer",
                         node.label = "character",
                         tip.label = "character",
-                        edge.label = "character",
-                        root.edge = "numeric"),
+                        edge.label = "character"),
          prototype = list(
                         edge = matrix(nrow = 0, ncol = 2,
                             dimname = list(NULL, c("ancestor", "descendant"))),
@@ -13,8 +12,7 @@
                         Nnode = as.integer(0),
                         tip.label = character(0),
                         node.label = character(0),
-                        edge.label = character(0),
-                        root.edge = as.numeric(NA)
+                        edge.label = character(0)
                        ),
          validity = check_phylo4)
 
@@ -22,7 +20,7 @@
 ## phylo4 constructor
 #####################
 
-phylo4 <- function(edge, edge.length = NULL, tip.label = NULL, node.label = NULL, edge.label = NULL, root.edge = NULL, ...){
+phylo4 <- function(edge, edge.length = NULL, tip.label = NULL, node.label = NULL, edge.label = NULL, ...){
 
     ## edge
     mode(edge) <- "integer"
@@ -66,19 +64,7 @@
     ##        edge.label <- paste("E", edge[, 2], sep = "")
     } else if (length(edge.label) != nrow(edge))
       stop("the edge labels are not consistent with the number of edges")
-    ## root.edge - if no root edge lenth provided, set to a numeric NA
-    if(is.null(root.edge)) {
-        root.edge <- as.numeric(NA)
-    }
-    
-    ##if(!is.null(root.edge)) {
-    ##    if(!round(root.edge)==root.edge) stop("root.edge must be an integer")
-    ##    root.edge <- as.integer(root.edge)
-    ##    if(root.edge > nrow(edge)) stop("indicated root.edge do not exist")
-    ##} else {
-    ##    root.edge <- as.integer(NA)
-    ##}
-
+      
     ## fill in the result
     res <- new("phylo4")
     res at edge <- edge
@@ -87,11 +73,9 @@
     res at tip.label <- tip.label
     res at node.label <- node.label
     res at edge.label <- edge.label
-    res at root.edge <- root.edge
 
     ## check_phylo4 will return a character string if object is
     ##  bad, otherwise TRUE
-    #fixme swk uncomment following once root node fixed
     if (is.character(checkval <- check_phylo4(res))) stop(checkval)
     return(res)
 }

Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R	2008-12-19 18:48:51 UTC (rev 334)
+++ pkg/R/methods-phylo4.R	2008-12-19 19:58:11 UTC (rev 335)
@@ -40,19 +40,14 @@
     x at edge
 })
 
-setMethod("rootEdge", "phylo4", function(x, order, ...) {
-    x at root.edge
-})
-
 setMethod("isRooted","phylo4", function(x) {
 
     ## hack to avoid failure on an empty object
     if(nTips(x) == 0) return(FALSE)
-    !is.na(x at root.edge) ||  ## root edge explicitly defined
     ## HACK: make sure we find the right "nTips"
     ## fixme SWK maybe broken after explicit root node addition?
-    tabulate(na.omit(edges(x)[, 1]))[nTips(x) + 1] <= 2
-    ## root node (first node after last tip) has <= 2 descendants
+
+    any(is.na(edges(x)[,1]))
     ## fixme: fails with empty tree?
     ## fixme - may fail with explicit root node in edge matrix
 })
@@ -82,20 +77,11 @@
 setMethod("rootNode", "phylo4", function(x) {
     if (!isRooted(x))
         return(NA)
-    #fixme SWK disabling check for root.edge for now until we fix
-    #if (!is.na(x at root.edge))
-    #    stop("FIXME: don't know what to do in this case")
-    ## BMB: danger!  do we require this??? fixme
-    ## return(nTips(x) + 1)
-    ## FM: alternative?
-    listNodes <- sort(unique(as.vector(edges(x))))
-    notRoot <- names(table(edges(x)[,2]))
-    iR <- listNodes[!listNodes %in% notRoot]
-    return(iR)
+    edges(x)[which(is.na(edges(x)[,1])),2]
 })
 
 setReplaceMethod("rootNode", "phylo4", function(x, value) {
-    stop("not implemented yet")
+    stop("Root node replacement not implemented yet")
 })
 
 setMethod("edgeLength", "phylo4", function(x,which) {
@@ -114,7 +100,7 @@
     else {
         nd <- getnodes(phy, node)
         iEdges <- which(phy at edge[,2] %in% nd)
-        sumEdges <- sum(phy at edge.length[iEdges])
+        sumEdges <- sum(phy at edge.length[iEdges],na.rm=TRUE)
         sumEdges
     }
 })
@@ -239,7 +225,6 @@
 #################
 ## summary phylo4
 #################
-## have to check that x$root.edge is NULL if missing
 setMethod("summary","phylo4", function (object, quiet=FALSE) {
     x <- object
     res <- list()
@@ -288,11 +273,6 @@
     ## if quiet, stop here
     if(quiet) return(invisible(res))
 
-    if(!is.null(x$root.edge)){
-        cat("  Root edge:", x$root.edge, "\n")
-    } else {
-        cat("  No root edge.\n")
-    }
     ## now, print to screen is !quiet
     cat("\n Phylogenetic tree :", res$name, "\n\n")
     cat(" Number of tips    :", res$nb.tips, "\n")