[Phylobase-commits] r147 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 8 01:01:37 CET 2008
Author: pdc
Date: 2008-03-08 01:01:37 +0100 (Sat, 08 Mar 2008)
New Revision: 147
Modified:
pkg/R/class-oldclasses.R
pkg/R/multiphylo.R
pkg/R/phylo4.R
pkg/R/setAs-Methods.R
Log:
Move all setAs methods and oldClass defs
setAs methods should all now be kept in setAs-Methods.R. They are currently organized by whether they import or export and what they import from or export to.
Modified: pkg/R/class-oldclasses.R
===================================================================
--- pkg/R/class-oldclasses.R 2008-03-07 23:59:14 UTC (rev 146)
+++ pkg/R/class-oldclasses.R 2008-03-08 00:01:37 UTC (rev 147)
@@ -0,0 +1,13 @@
+## This file contains the old class definitions needed
+## better interoperation with other packages
+
+
+## ape classes
+setOldClass("phylo")
+
+setOldClass("multiPhylo")
+
+## setOldClass("multi.tree") ## obsolete
+
+## ade4 classes
+setOldClass("phylog")
Modified: pkg/R/multiphylo.R
===================================================================
--- pkg/R/multiphylo.R 2008-03-07 23:59:14 UTC (rev 146)
+++ pkg/R/multiphylo.R 2008-03-08 00:01:37 UTC (rev 147)
@@ -1,9 +1,6 @@
require(methods)
require(ape)
-## setOldClass("multi.tree") ## obsolete
-setOldClass("multiPhylo")
-
setClass("multiPhylo4",
representation(phylolist="list",
tree.names="character"),
@@ -14,30 +11,7 @@
representation(tip.data="data.frame"),
contains="multiPhylo4")
-setAs("multiPhylo4","multiPhylo",
- function(from,to) {
- newobj <- new("multiPhylo4",
- phylolist=lapply(from,as,to="phylo4"))
- })
-setAs("multiPhylo4d","multiPhylo",
- function(from,to) {
- newobj <- new("multiPhylo4d",
- phylolist=lapply(from,as,to="phylo4"),
- tree.names=names(from),
- tip.data=data.frame())
- })
-
-setAs("multiPhylo","multiPhylo4",
- function(from,to) {
- y <- lapply(as,from at phylolist,to="phylo")
- names(y) <- from at tree.names
- if (nrow(from at tip.data)>0) warning("discarded tip data")
- class(y) <- "multiPhylo"
- y
- })
-
-
## function to bind trees together into a multi-tree object
tbind <- function(...,check_data=FALSE) {
L <- as.list(...)
Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R 2008-03-07 23:59:14 UTC (rev 146)
+++ pkg/R/phylo4.R 2008-03-08 00:01:37 UTC (rev 147)
@@ -1,8 +1,6 @@
require(methods)
require(ape)
-setOldClass("phylo")
-
setClass("phylo4",
representation(edge="matrix",
edge.length="numeric",
@@ -278,46 +276,6 @@
##
# Alternative print method for phylo4, showing the contents of the tree data.
## Not sure if it works for unrooted trees
-setAs(from='phylo4',to='data.frame',
- def = function(from) {
- if (is.character(checkval <- check_phylo4(from))) stop(checkval) # check the phylo4
- x <- from
- E <- edges(x) # E: matrix of edges
- ancestor <- E[,1]
- node <- E[,2]
- root <- unique(ancestor[!ancestor %in% node])
- int.node <- c(root, unique(ancestor[ancestor %in% node])) # internal nodes (root first)
- tip <- node[!(node %in% ancestor)]
- n.tip <- length(tip)
- n.int <- length(int.node)
- # node <- c(root, node) # doesn't fit the ordering: root, other internal nodes, tips
- node <- c(int.node,tip)
- ## retrieve the ancestor of each node
- idx <- match(node,E[,2]) # new ordering of the descendents/edges
- # if (length(ancestor)>0) ancestor <- c(NA, ancestor)
- ancestor <- E[idx,1]
- # branch.length <- c(x at root.edge, x at edge.length) # root.edge is not an edge length
- branch.length <- edgeLength(x)[idx]
- # if (length(branch.length) == 1) branch.length <- rep("", n.tip+n.int)
- if(is.null(edgeLength(x))) branch.length <- rep(NA, length(node))
- ## node and tip labels ##
- ## beware: they cannot be NULL
- ## there are always tip labels (or check_phylo4 complains)
- ## there may not be node labels (character(0))
- if(hasNodeLabels(x)) {
- nl <- x at node.label
- } else {
- nl <- rep(NA,nNodes(x))
- }
-
- tl <- labels(x)
- taxon.name <- c(nl, tl)
- if (!isRooted(x)) {
- node.type <- c(rep("internal", n.int), rep("tip", n.tip))
- } else node.type <- c("root", rep("internal", n.int-1), rep("tip", n.tip))
-
- return(data.frame(taxon.name, node, ancestor, branch.length, node.type))
- })
printphylo4 <- function(x, printall = TRUE){
if (printall)
@@ -325,23 +283,6 @@
else print(head(as(x, 'data.frame')))
}
-setAs(from='phylo4d', to='data.frame',
- function(from) {
-
- as(from, "phylo4") -> tree # get tree
- as(tree, "data.frame") -> t_df # convert to data.frame
- tdata(from, "allnode") -> dat # get data
- old.ord <- t_df$taxon.name # save roworder of tree
-
- ## merge data.frames of tree and data
- tdat <- merge(t_df, dat, by.x="taxon.name", by.y="row.names", all.x=TRUE, all.y=FALSE, sort=FALSE)
-
- ## restore the correct order (i.e. the one of the tree data.frame)
- idx <- match(old.ord,tdat$taxon.name)
- res <- tdat[idx,]
-
- return(res) # drop "order"
-})
setGeneric("print")
@@ -749,45 +690,6 @@
})
## convert from phylo to phylo4
-setAs("phylo","phylo4",
- function(from,to) {
- 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)
- attribs = attributes(from)
- attribs$names <- NULL
- knownattr <- c("logLik","order","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=" "))
- }
- for (i in known) attr(newobj,i) <- attr(from,i)
- newobj
- })
-
-setAs("phylo","phylo4d",
- function(from,to) {
- phylo4d(as(from,"phylo4"),tip.data=data.frame())
- })
-
-
-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
- })
-
## coerce phylo4d to phylo4 -- on purpose, so no warning
extract.tree <- function(from) {
phylo4(edge=from at edge,
@@ -796,35 +698,7 @@
tip.label=from at tip.label)
}
-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
- })
-
-
-####################
-## as(phylo4,phylog)
-####################
-setOldClass("phylog")
-setAs("phylo4","phylog", function(from, to){
- if(!require(ade4)) stop("the ade4 package is required")
- x <- as(from,"phylo")
- x <- write.tree(x,file="")
- x <- newick2phylog(x)
- return(x)
-})
-
## FIXME: doesn't deal with missing node data
## (don't even know how that should be done in this case)
setGeneric("na.omit")
Modified: pkg/R/setAs-Methods.R
===================================================================
--- pkg/R/setAs-Methods.R 2008-03-07 23:59:14 UTC (rev 146)
+++ pkg/R/setAs-Methods.R 2008-03-08 00:01:37 UTC (rev 147)
@@ -0,0 +1,143 @@
+#######################################################
+## Importing from ape
+setAs("phylo", "phylo4", function(from, to) {
+ 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)
+ attribs = attributes(from)
+ attribs$names <- NULL
+ knownattr <- c("logLik", "order", "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 = " "))
+ }
+ for (i in known) attr(newobj, i) <- attr(from, i)
+ newobj
+})
+
+setAs("phylo", "phylo4d", function(from, to) {
+ phylo4d(as(from, "phylo4"), tip.data = data.frame())
+})
+
+setAs("multiPhylo", "multiPhylo4", function(from, to) {
+ y <- lapply(as, from at phylolist, to = "phylo")
+ names(y) <- from at tree.names
+ if (nrow(from at tip.data) > 0)
+ warning("discarded tip data")
+ class(y) <- "multiPhylo"
+ y
+})
+
+#######################################################
+## 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
+ warning("losing data while coercing phylo4d to phylo")
+ y
+})
+
+setAs("multiPhylo4", "multiPhylo", function(from, to) {
+ newobj <- new("multiPhylo4", phylolist = lapply(from,
+ as, to = "phylo4"))
+})
+
+setAs("multiPhylo4d", "multiPhylo", function(from, to) {
+ newobj <- new("multiPhylo4d", phylolist = lapply(from,
+ as, to = "phylo4"), tree.names = names(from), tip.data = data.frame())
+})
+
+#######################################################
+## Exporting to ade4
+setAs("phylo4", "phylog", function(from, to) {
+ if (!require(ade4))
+ stop("the ade4 package is required")
+ x <- as(from, "phylo")
+ x <- write.tree(x, file = "")
+ x <- newick2phylog(x)
+ return(x)
+})
+
+#######################################################
+## Exporting to dataframe
+setAs(from = "phylo4", to = "data.frame", def = function(from) {
+ if (is.character(checkval <- check_phylo4(from))) # check the phylo4
+ stop(checkval)
+ x <- from
+ E <- edges(x) # E: matrix of edges
+ ancestor <- E[, 1]
+ node <- E[, 2]
+ root <- unique(ancestor[!ancestor %in% node])
+ int.node <- c(root, unique(ancestor[ancestor %in% node])) # internal nodes (root first)
+ tip <- node[!(node %in% ancestor)]
+ n.tip <- length(tip)
+ n.int <- length(int.node)
+ ## node <- c(root, node) # doesn't fit the ordering: root, other internal nodes, tips
+ node <- c(int.node, tip)
+ ## retrieve the ancestor of each node
+ idx <- match(node, E[, 2]) # new ordering of the descendents/edges
+ ## if (length(ancestor)>0) ancestor <- c(NA, ancestor)
+ ancestor <- E[idx, 1]
+ ## branch.length <- c(x at root.edge, x at edge.length) # root.edge is not an edge length
+ branch.length <- edgeLength(x)[idx]
+ if (is.null(edgeLength(x))) {
+ branch.length <- rep(NA, length(node))
+ }
+ ## node and tip labels ##
+ ## beware: they cannot be NULL
+ ## there are always tip labels (or check_phylo4 complains)
+ ## there may not be node labels (character(0))
+ if (hasNodeLabels(x)) {
+ nl <- x at node.label
+ }
+ else {
+ nl <- rep(NA, nNodes(x))
+ }
+ tl <- labels(x)
+ taxon.name <- c(nl, tl)
+ if (!isRooted(x)) {
+ node.type <- c(rep("internal", n.int), rep("tip",
+ n.tip))
+ }
+ else node.type <- c("root", rep("internal", n.int - 1),
+ rep("tip", n.tip))
+ return(data.frame(taxon.name, node, ancestor, branch.length,
+ node.type))
+})
+
+setAs(from = "phylo4d", to = "data.frame", function(from) {
+ tree <- as(from, "phylo4") # get tree
+ t_df <- as(tree, "data.frame") # convert to data.frame
+ dat <- tdata(from, "allnode") # get data
+ old.ord <- t_df$taxon.name # save roworder of tree
+
+ ## merge data.frames of tree and data
+ tdat <- merge(t_df, dat, by.x = "taxon.name", by.y = "row.names",
+ all.x = TRUE, all.y = FALSE, sort = FALSE)
+
+ ## restore the correct order (i.e. the one of the tree data.frame)
+ idx <- match(old.ord, tdat$taxon.name)
+ res <- tdat[idx, ]
+ return(res) # drop "order"
+})
More information about the Phylobase-commits
mailing list