[Phylobase-commits] r522 - in pkg: R man

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

Author: francois
Date: 2009-08-20 00:47:42 +0200 (Thu, 20 Aug 2009)
New Revision: 522

Modified:
   pkg/R/methods-phylo4.R
   pkg/R/setAs-Methods.R
   pkg/man/printphylo4.Rd
Log:
provide possibility of printing objects in edge order: added option edgeOrder in printphylo4

Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R	2009-08-19 22:44:10 UTC (rev 521)
+++ pkg/R/methods-phylo4.R	2009-08-19 22:47:42 UTC (rev 522)
@@ -228,7 +228,7 @@
    function(object, type = c("tip", "internal", "allnode"),
             use.names, ..., value) {
 
-       ## default options
+       ## Default options
        if(missing(type))
            type <- "tip"
        if (missing(use.names))
@@ -334,15 +334,19 @@
 #########################################################
 
 ### print
-printphylo4 <- function(x, printall=TRUE) {
+printphylo4 <- function(x, edgeOrder=c("pretty", "real"), printall=TRUE) {
     if(!nrow(x at edge)) {
         msg <- paste("Empty \'", class(x), "\' object\n", sep="")
         cat(msg)
     }
     else {
-        if (printall)
-            print(as(x, 'data.frame'))
-        else print(head(as(x, 'data.frame')))
+        toRet <- .phylo4ToDataFrame(x, edgeOrder)
+        if (printall) {
+            print(toRet)
+        }
+        else {
+            print(head(toRet))
+        }
     }
 }
 

Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R	2009-08-19 22:44:10 UTC (rev 521)
+++ pkg/R/setAs-Methods.R	2009-08-19 22:47:42 UTC (rev 522)
@@ -81,15 +81,15 @@
 
     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)
     if (isRooted(from)) {
         ## rootnode is only node with no ancestor
-        rootpos <- which(is.na(from at edge[, 1]))    
+        rootpos <- which(is.na(from at edge[, 1]))
         brlen <- brlen[-rootpos]
-        edgemat <- unname(from at edge[-rootpos, ])    
+        edgemat <- unname(from at edge[-rootpos, ])
       } else {
         edgemat <- from at edge
     }
@@ -159,58 +159,60 @@
 
 #######################################################
 ## Exporting to dataframe
-setAs(from = "phylo4", to = "data.frame", def = function(from) {
 
+.phylo4ToDataFrame <- function(from, edgeOrder=c("pretty", "real")) {
+
+    edgeOrder <- match.arg(edgeOrder)
+
     ## Check the phylo4
     if (is.character(checkval <- checkPhylo4(from)))
         stop(checkval)
-    x <- from
 
     ## The order of 'node' defines the order of all other elements
-    node <- nodeId(x, "all")
-    ancestr <- ancestor(x, node)
-    ndType <- nodeType(x)
-    intNode <- names(ndType[ndType == "internal"])
-    tip <- names(ndType[ndType == "tip"])
+    if (edgeOrder == "pretty") {
+        node <- nodeId(from, "all")
+        ancestr <- ancestor(from, node)
+        E <- data.frame(node, ancestr)
+    }
+    else {
+        E <- edges(from)
+        node <- E[, 2]
+        ancestr <- E[, 1]
+    }
 
-    E <- data.frame(node, ancestr)
-
-    if (hasEdgeLength(x)) {
+    if (hasEdgeLength(from)) {
         nmE <- paste(E[,2], E[,1], sep="-")
-        edge.length <- edgeLength(x)[match(nmE, names(x at edge.length))]
+        edge.length <- edgeLength(from)[match(nmE, names(from at edge.length))]
     }
     else {
         edge.length <- rep(NA, nrow(E))
     }
 
-    label <- labels(x,type="all")
+
+    ndType <- nodeType(from)
+    label <- labels(from,type="all")
     label <- label[match(node, names(label))]
 
-    d <- data.frame(label, node, ancestor=ancestr, edge.length,
+    tDf <- data.frame(label, node, ancestor=ancestr, edge.length,
                     node.type=ndType[node], row.names=node)
-    d$label <- as.character(d$label)
-    d
-})
+    tDf$label <- as.character(tDf$label)
 
-setAs(from = "phylo4d", to = "data.frame", function(from) {
+    if (class(from) == "phylo4d") {
+        dat <- tdata(from, "allnode", label.type="column") # get data
 
-    if(is.character(checkval <- checkPhylo4(from)))
-        stop(checkval)
+        ## reorder data to edge matrix order, drop labels (first column)
+        if(nrow(dat) > 0 && ncol(dat) > 1) {
+            dat <- dat[match(rownames(tDf), rownames(dat)), ]
+            tDf <- cbind(tDf, dat[ ,-1 , drop=FALSE])
+        }
+        else {
+            cat("No data associated with the tree\n")
+       }
+    }
+    tDf
+}
 
-    tree <- extractTree(from)
-    ## Convert to data.frame
-    tDf <- as(tree, "data.frame")
-
-    dat <- tdata(from, "allnode", label.type="column") # get data
-
-    ## reorder data to edge matrix order, drop labels (first column)
-    if(nrow(dat) > 0 && ncol(dat) > 1) {
-         dat <- dat[match(rownames(tDf), rownames(dat)), ]
-         tdat <- cbind(tDf, dat[ ,-1 , drop=FALSE])
-     }
-     else {
-        tdat <- tDf
-        cat("No data associated with the tree\n")
-     }
-    tdat
+setAs(from = "phylo4", to = "data.frame", def=function(from) {
+    d <- .phylo4ToDataFrame(from, edgeOrder="pretty")
+    d
 })

Modified: pkg/man/printphylo4.Rd
===================================================================
--- pkg/man/printphylo4.Rd	2009-08-19 22:44:10 UTC (rev 521)
+++ pkg/man/printphylo4.Rd	2009-08-19 22:47:42 UTC (rev 522)
@@ -9,6 +9,9 @@
 }
 \arguments{
   \item{x}{a phylo4 tree or phylo4d tree+data object}
+  \item{edgeOrder}{in the data frame returned, the option 'pretty' returns the internal nodes
+  followed by the tips, the option 'real' returns the nodes in the order they are stored
+  in the edge matrix.}
   \item{printall}{default prints entire tree. printall=FALSE returns the first 6 rows}
 }
 \details{