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

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

Author: bbolker
Date: 2009-08-19 00:29:44 +0200 (Wed, 19 Aug 2009)
New Revision: 487

Added:
   pkg/tests/roundtrip.R
Modified:
   pkg/R/setAs-Methods.R
Log:
 improved handling of order in phylo <-> phylo4 conversion.  basic round-trip
works.  added test.



Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R	2009-08-18 22:04:34 UTC (rev 486)
+++ pkg/R/setAs-Methods.R	2009-08-18 22:29:44 UTC (rev 487)
@@ -25,15 +25,24 @@
             from$edge.label <- c(from$edge.label[tip.idx],NA,from$edge.label[int.idx])
         }
     }
+    oldorder <- attr(from,"order")
+    neworder <- if (is.null(oldorder)) { "unknown" } else {
+      switch(oldorder,
+             pruningwise="pruningwise",
+             cladewise="preorder")
+    }
+    attr(from,"order") <- NULL
     newobj <- phylo4(from$edge, from$edge.length, from$tip.label,
-                     node.label = from$node.label, edge.label = from$edge.label)
+                     node.label = from$node.label,
+                     edge.label = from$edge.label,
+                     order = neworder)
     attribs <- attributes(from)
     attribs$names <- NULL
-    knownattr <- c("logLik", "order", "origin", "para", "xi")
+    knownattr <- c("logLik", "origin", "para", "xi")
     known <- names(attribs)[names(attribs) %in% knownattr]
     unknown <- names(attribs)[!names(attribs) %in% c(knownattr, "class", "names")]
     if (length(unknown) > 0) {
-        warning(paste("unknown attributes ignored: ", unknown, collapse = " "))
+      warning(paste("unknown attributes ignored: ", unknown, collapse = " "))
     }
     for (i in known) attr(newobj, i) <- attr(from, i)
     newobj
@@ -75,32 +84,35 @@
     
     if (inherits(from, "phylo4d"))
         warning("losing data while coercing phylo4d to phylo")
-    brlen <- unname(from at edge.length)
+    brlen0 <- brlen <- unname(from at edge.length)
     ## rootnode is only node with no ancestor
     rootpos <- which(is.na(from at edge[, 1]))
     if (isRooted(from)) brlen <- brlen[-rootpos]
-    if(hasNodeLabels(from))
+    if(hasNodeLabels(from)) {
         nodLbl <- unname(from at node.label)
-    else
+      }  else {
         nodLbl <- character(0)
+      }
     edgemat <- unname(from at edge[-rootpos, ])
     y <- list(edge = edgemat,
-            Nnode = from at Nnode,
-            tip.label = unname(from at tip.label),
-            edge.length = brlen,
-            node.label = nodLbl)
+              edge.length = brlen,
+              tip.label = unname(from at tip.label),
+              Nnode = from at Nnode,
+              node.label = nodLbl)
     class(y) <- "phylo"
     if (from at order != 'unknown') {
         ## TODO postorder != pruningwise -- though quite similar
         attr(y, 'order') <- switch(from at order, postorder = 'unknown',
-                                      preorder  = 'cladewise')
+                                   preorder  = 'cladewise',
+                                   unknown = 'unknown',
+                                   pruningwise = 'pruningwise')
     }
     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)]
+        root.edge <- brlen0[rootNode(from)]
         if (!is.na(root.edge)) y$root.edge <- root.edge
     }
     y

Added: pkg/tests/roundtrip.R
===================================================================
--- pkg/tests/roundtrip.R	                        (rev 0)
+++ pkg/tests/roundtrip.R	2009-08-18 22:29:44 UTC (rev 487)
@@ -0,0 +1,17 @@
+library(phylobase)
+
+set.seed(1)
+t0 <- rcoal(5)
+t0$edge
+
+plot(t0)
+
+t1<-as(t0,"phylo4")
+t5 <- as(t1,"phylo")
+stopifnot(identical(t0,t5))
+
+## t2<-as(t1,"phylo4vcov")
+## t3<-as(t2,"phylo4")
+## t4<-as(t3,"phylo")
+
+## plot(test.tree) #CRASHES R!