[Phylobase-commits] r338 - pkg/R

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

Author: skembel
Date: 2008-12-19 21:18:17 +0100 (Fri, 19 Dec 2008)
New Revision: 338

Modified:
   pkg/R/class-phylo4d.R
   pkg/R/methods-phylo4.R
   pkg/R/prune.R
   pkg/R/setAs-Methods.R
Log:
removing root.edge as no longer necessary

Modified: pkg/R/class-phylo4d.R
===================================================================
--- pkg/R/class-phylo4d.R	2008-12-19 20:05:44 UTC (rev 337)
+++ pkg/R/class-phylo4d.R	2008-12-19 20:18:17 UTC (rev 338)
@@ -56,7 +56,6 @@
        res at tip.label <- x at tip.label
        res at node.label <- x at node.label
        res at edge.label <- x at edge.label
-       res at root.edge <- x at root.edge
 
        if(!is.null(all.data)) {
            tmpData <- all.data

Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R	2008-12-19 20:05:44 UTC (rev 337)
+++ pkg/R/methods-phylo4.R	2008-12-19 20:18:17 UTC (rev 338)
@@ -77,7 +77,7 @@
 setMethod("rootNode", "phylo4", function(x) {
     if (!isRooted(x))
         return(NA)
-    edges(x)[which(is.na(edges(x)[,1])),2]
+    unname(edges(x)[which(is.na(edges(x)[,1])),2])
 })
 
 setReplaceMethod("rootNode", "phylo4", function(x, value) {
@@ -155,9 +155,7 @@
         NULL
     else x at edge.length, node.label = if (!hasNodeLabels(x))
         NULL
-    else x at node.label, root.edge = if (is.na(x at root.edge))
-        NULL
-    else x at root.edge, attr(x, name))
+    else x at node.label, attr(x, name))
 })
 
 ## FIXME: implement more checks on this!!

Modified: pkg/R/prune.R
===================================================================
--- pkg/R/prune.R	2008-12-19 20:05:44 UTC (rev 337)
+++ pkg/R/prune.R	2008-12-19 20:18:17 UTC (rev 338)
@@ -26,21 +26,21 @@
 
 setMethod("prune","phylo4",
           function(phy, tip, trim.internal = TRUE, subtree = FALSE,
-                   root.edge = 0,...) {
-            DropTip(phy,tip,trim.internal, subtree, root.edge)
+                   ...) {
+            DropTip(phy,tip,trim.internal, subtree)
           })
 
 ## trace("prune", browser, signature = "phylo4d")
 ## untrace("prune", signature = "phylo4d")
 setMethod("prune","phylo4d",
           function(phy, tip, trim.internal = TRUE, subtree = FALSE,
-                   root.edge = 0,...) {
+                   ...) {
             ## need unique labels to match data correctly
             oldnodelabels <- phy at node.label
             nodetags <- .genlab("N",nNodes(phy))
             phy at node.label <- nodetags
             oldtiplabels <- phy at tip.label
-            phytr <- DropTip(phy,tip,trim.internal, subtree, root.edge)
+            phytr <- DropTip(phy,tip,trim.internal, subtree)
             ## this DROPS data
             ntr = match(phytr at node.label,nodetags)
             ttr = match(phytr at tip.label,oldtiplabels)
@@ -53,8 +53,8 @@
 
 setMethod("prune","phylo",
           function(phy, tip, trim.internal = TRUE, subtree = FALSE,
-                   root.edge = 0,...) {
-            DropTip(phy,tip,trim.internal, subtree, root.edge)
+                   ...) {
+            DropTip(phy,tip,trim.internal, subtree)
           })
 
 ## setMethod("prune","ANY",

Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R	2008-12-19 20:05:44 UTC (rev 337)
+++ pkg/R/setAs-Methods.R	2008-12-19 20:18:17 UTC (rev 338)
@@ -3,20 +3,23 @@
 setAs("phylo", "phylo4", function(from, to) {
     #fixme SWK kludgy fix to add root to an ape edge matrix
     if (is.rooted(from)) {
-        if (is.null(from$root.edge)) {
-            from$root.edge <- as.numeric(setdiff(unique(from$edge[,1]),unique(from$edge[,2])))
-        }
-        from$edge <- rbind(from$edge,c(NA,from$root.edge))
+        root.edge <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2])))
+        #fix - figure out node id of edge
+        from$edge <- rbind(from$edge,c(NA,root.edge))
         if (!is.null(from$edge.length)) {
-            from$edge.length <- c(from$edge.length,as.numeric(NA))
+            if (is.null(from$root.edge)) {
+                from$edge.length <- c(from$edge.length,as.numeric(NA))
+            }
+            else {
+                from$edge.length <- c(from$edge.length,from$root.edge)
+            }
         }
         if (!is.null(from$edge.label)) {
-            from$edge.label <- c(from$edge.label,paste("E",from$root.edge,sep=""))
+            from$edge.label <- c(from$edge.label,paste("E",root.edge,sep=""))
         }
     }
     newobj <- phylo4(from$edge, from$edge.length, from$tip.label,
-        node.label = from$node.label, edge.label = from$edge.label,
-        root.edge = from$root.edge)
+        node.label = from$node.label, edge.label = from$edge.label)
     attribs = attributes(from)
     attribs$names <- NULL
     knownattr <- c("logLik", "order", "origin", "para", "xi")
@@ -52,8 +55,8 @@
         y$edge.length <- NULL
     if (length(y$node.label) == 0)
         y$node.label <- NULL
-    if (!is.na(from at root.edge))
-        y$root.edge <- from at root.edge
+    #if (!is.na(from at root.edge))
+    #    y$root.edge <- from at root.edge
     y
 })
 
@@ -65,8 +68,8 @@
         y$edge.length <- NULL
     if (length(y$node.label) == 0)
         y$node.label <- NULL
-    if (!is.na(from at root.edge))
-        y$root.edge <- from at root.edge
+    #if (!is.na(from at root.edge))
+    #    y$root.edge <- from at root.edge
     warning("losing data while coercing phylo4d to phylo")
     y
 })