[Phylobase-commits] r346 - pkg/R

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

Author: bbolker
Date: 2008-12-19 22:10:55 +0100 (Fri, 19 Dec 2008)
New Revision: 346

Modified:
   pkg/R/setAs-Methods.R
Log:
updated as("phylo4","phylo") for root in edge matrix stuff



Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R	2008-12-19 21:09:19 UTC (rev 345)
+++ pkg/R/setAs-Methods.R	2008-12-19 21:10:55 UTC (rev 346)
@@ -48,32 +48,41 @@
 #######################################################
 ## Exporting to ape
 setAs("phylo4", "phylo", function(from, to) {
-    y <- list(edge = from at edge, edge.length = from at edge.length,
-        Nnode = from at Nnode, tip.label = from at tip.label, node.label = from at node.label)
-    class(y) <- "phylo"
-    if (length(y$edge.length) == 0)
-        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
-    y
-})
-
-setAs("phylo4d", "phylo", function(from, to) {
-    y <- list(edge = from at edge, edge.length = from at edge.length,
-        Nnode = from at Nnode, tip.label = from at tip.label)
-    class(y) <- "phylo"
-    if (length(y$edge.length) == 0)
-        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 (inherits(from,"phylo4d"))
     warning("losing data while coercing phylo4d to phylo")
-    y
+  brlen <- from at edge.length
+  if (isRooted(from)) brlen <- brlen[nodeId(from,"all")!=rootNode(from)]
+  edgemat <- na.omit(from at edge)
+  y <- list(edge = na.omit(from at edge), edge.length = brlen,
+            Nnode = from at Nnode, tip.label = from at tip.label,
+            node.label = from at node.label)
+  class(y) <- "phylo"
+  if (length(y$edge.length) == 0)
+    y$edge.length <- NULL
+  if (length(y$node.label) == 0)
+    y$node.label <- NULL
+  if (isRooted(from)) {
+    root.edge <- brlen[nodeId(from,"all")==rootNode(from)]
+    if (!is.na(root.edge)) y$root.edge <- root.edge
+  }
+  y
 })
 
+## BMB: redundant????  
+## setAs("phylo4d", "phylo", function(from, to) {
+##     y <- list(edge = from at edge, edge.length = from at edge.length,
+##         Nnode = from at Nnode, tip.label = from at tip.label)
+##     class(y) <- "phylo"
+##     if (length(y$edge.length) == 0)
+##         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
+##    warning("losing data while coercing phylo4d to phylo")
+##    y
+##})
+
 setAs("multiPhylo4", "multiPhylo", function(from, to) {
     newobj <- new("multiPhylo4", phylolist = lapply(from,
         as, to = "phylo4"))
@@ -90,9 +99,8 @@
     if (!require(ade4))
         stop("the ade4 package is required")
     x <- as(from, "phylo")
-    x <- write.tree(x, file = "")
-    x <- newick2phylog(x)
-    return(x)
+    xstring <- write.tree(x, file = "")
+    newick2phylog(xstring)
 })
 
 #######################################################