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

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

Author: bbolker
Date: 2009-08-20 17:37:05 +0200 (Thu, 20 Aug 2009)
New Revision: 529

Modified:
   pkg/R/setAs-Methods.R
   pkg/tests/roundtrip.R
Log:

   tweaks to make round trip work for rooted, unrooted, etc.
trees



Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R	2009-08-20 07:49:58 UTC (rev 528)
+++ pkg/R/setAs-Methods.R	2009-08-20 15:37:05 UTC (rev 529)
@@ -79,20 +79,22 @@
 
 setAs("phylo4", "phylo", function(from, to) {
 
-    if(is.character(checkval <- checkPhylo4(from)))
-        stop(checkval)
+    if(is.character(checkval <- checkPhylo4(from))) {
+      stop(checkval)
+    }
 
     if (inherits(from, "phylo4d"))
         warning("losing data while coercing phylo4d to phylo")
-    brlen0 <- brlen <- unname(from at edge.length)
+    brlen <- unname(from at edge.length)
     if (isRooted(from)) {
         ## rootnode is only node with no ancestor
         rootpos <- which(is.na(from at edge[, 1]))
         brlen <- brlen[-rootpos]
         edgemat <- unname(from at edge[-rootpos, ])
       } else {
-        edgemat <- from at edge
+        edgemat <- unname(from at edge)
     }
+    storage.mode(edgemat) <- "integer"
     if(hasNodeLabels(from)) {
         nodLbl <- unname(from at node.label)
       } else {
@@ -102,7 +104,7 @@
     y <- list(edge = edgemat,
               edge.length = brlen,
               tip.label = unname(from at tip.label),
-              Nnode = from at Nnode,
+              Nnode = as.integer(from at Nnode),
               node.label = nodLbl)
     class(y) <- "phylo"
     if (from at order != 'unknown') {
@@ -111,6 +113,8 @@
                                    preorder  = 'cladewise',
                                    unknown = 'unknown',
                                    pruningwise = 'pruningwise')
+    } else {
+      ## warning ??
     }
     if (length(y$edge.length) == 0)
         y$edge.length <- NULL
@@ -118,7 +122,7 @@
         y$node.label <- NULL
     ## how do we tell if there is an explicit root edge?
     if (isRooted(from)) {
-        root.edge <- edgeLength(from,rootNode(from))## brlen0[rootNode(from)]
+        root.edge <- unname(edgeLength(from,rootNode(from)))
         if (!is.na(root.edge)) y$root.edge <- root.edge
     }
     y

Modified: pkg/tests/roundtrip.R
===================================================================
--- pkg/tests/roundtrip.R	2009-08-20 07:49:58 UTC (rev 528)
+++ pkg/tests/roundtrip.R	2009-08-20 15:37:05 UTC (rev 529)
@@ -1,15 +1,24 @@
 library(phylobase)
 
-set.seed(1)
-t0 <- rcoal(5)
-t0$edge
+## set.seed(1)
+## t0A <- rcoal(5)
+t0 <- read.tree(textConnection("((t4:0.3210275554,
+(t2:0.2724586465,
+ t3:0.2724586465):
+0.0485689089):0.1397952619,(t5:0.07551818331,
+t1:0.07551818331):0.385304634);"))
+## hack around variability in ape:
+##   read.tree() and rcoal() produce sets of
+##     elements in different orders
+t0 <- unclass(t0)[c("edge","edge.length","tip.label","Nnode")]
+class(t0) <- "phylo"
 
-plot(t0)
-
+## phylo -> phylo4 -> phylo
 t1<-as(t0,"phylo4")
 t5 <- as(t1,"phylo")
 stopifnot(identical(t0,t5))
 
+## phylo4 -> phylo4vcov -> phylo4 -> phylo
 t2<-as(t1,"phylo4vcov")
 t3<-as(t2,"phylo4")
 t4<-as(t3,"phylo")
@@ -17,5 +26,18 @@
           identical(t4$tip.label,t0$tip.label) &&
           identical(t4$Nnode,t0$Nnode) &&
           max(abs(t4$edge.length-t0$edge.length))<1e-10)
-           
 
+## UNROOTED
+t6 <- unroot(t0)
+## hack around ape conversion issues:
+##  unroot() converts integer to double
+storage.mode(t6$edge) <- "integer"
+storage.mode(t6$Nnode) <- "integer"
+t7 <- as(as(t6,"phylo4"),"phylo")
+stopifnot(identical(t6,t7))
+
+## EXPLICIT ROOT EDGE
+t8 <- t0
+t8$root.edge <- 0.5
+t9 <- as(as(t8,"phylo4"),"phylo")
+stopifnot(identical(t8,t9))