Hello everyone,
I thought someone might find this useful. I went on to write a modest
function that adds a random outgroup lineage to a phylo object. It accepts
both ultrametric and standard trees with or without branch lenghts. In the
case of ultrametric trees, it will add an "ingroup" edge (leading to the
root) of length: 1/5*rootheigth, where rootheight is the oldest branching
time of the original tree. And in the case of standard trees with branch
lengths, the "outgroup" branch length will be as long as the longest branch
in the tree, and the ingroup edge will be 1/3 as long. You can also reroot
your tree internally by giving the node number of the new root (root.node).
Its possible that Liam Revell already has something similar, but I'm not
completely sure. In case you are feeling curious, I prepared a quick and
simple demo:
# The code:
add.outgroup <- function(phy, root.node=NULL){
require(ape)
if (is.null(phy$edge.length)){
tt <- rtree(2)
tt$edge.length <- NULL
tt$tip.label <- c("outgroup","drop")
phy$root.edge <- 1
if (!is.null(root.node)){
rphy <- root(phy, node=root.node)
ot <- bind.tree(rphy, tt, position=1)
} else {
ot <- bind.tree(phy, tt, position=1)
}
ot <- bind.tree(phy, tt, position=1)
res <- drop.tip(ot, "drop")
return(res)
} else if (is.ultrametric(phy)){
th <- as.numeric(sort(branching.times(phy), decreasing=T))[1]
re <- th/5
phy$root.edge <- re
tt <- rtree(2)
tt$edge.length <- c(0,0)
tt$tip.label <- c("outgroup","drop")
tt$root.edge <- th + re
ot <- bind.tree(phy, tt, position=re)
res <- drop.tip(ot, "drop")
return(res)
} else {
tl <- max(phy$edge.length)
re <- tl/3
tt <- rtree(2)
tt$edge.length <- c(0,0)
tt$tip.label <- c("outgroup","drop")
tt$root.edge <- tl
if (!is.null(root.node)){
rphy <- root(phy, node=root.node)
rphy$root.edge <- re
ot <- bind.tree(rphy, tt, position=re)
} else {
phy$root.edge <- re
ot <- bind.tree(phy, tt, position=re)
}
res <- drop.tip(ot, "drop")
return(res)
}
}
# Demo:
> require(ape)
> # for a regular tree with branch lengths
> phy <- rtree(20)
> nodes <- (length(phy$tip.label)+1):(length(phy$tip.label)+phy$Nnode)
> root.node <- sample(nodes, 1)
> rphy.w.out <- add.outgroup(phy=phy, root.node=root.node)
> is.rooted(rphy.w.out)
> # try it without rooting
> phy.w.out <- add.outgroup(phy=phy)
> is.rooted(phy.w.out)
> # tree with no branch lengths
> phynbl <- phy
> phynbl$edge.length <- NULL
> phynbl.w.out <- add.outgroup(phy=phynbl)
> is.rooted(phynbl.w.out)
> par(mfrow=c(1,4))
> plot(ladderize(phy.w.out,FALSE), main="original")
> add.scale.bar(y=19, x=max(phy.w.out$edge.length)/2)
> plot(ladderize(rphy.w.out,FALSE), main="rerooted")
> add.scale.bar(y=19, x=max(rphy.w.out$edge.length)/2)
> plot(ladderize(phynbl.w.out,FALSE), main="no branch lengths")
> # for an ultrametric tree
> phy <- pbtree(n=20)
> nodes <- (length(phy$tip.label)+1):(length(phy$tip.label)+phy$Nnode)
> root.node <- sample(nodes, 1)
> phy.w.out <- add.outgroup(phy=phy, root.node=root.node)
> is.rooted(phy.w.out)
> plot(ladderize(phy.w.out,FALSE), main="ultrametric")
> axisPhylo()
Cheers,
Santiago
--
Santiago Sánchez-Ramírez
Department of Ecology and Evolutionary Biology, University of Toronto
Department of Natural History (Mycology), Royal Ontario Museum
100 Queen's Park
Toronto, ON
M5S 2C6
Canada
Other email: [email protected]
Tel. 416-586-8025
Website: https://sites.google.com/site/santiagosnchezrmirez/
[[alternative HTML version deleted]]
_______________________________________________
R-sig-phylo mailing list - [email protected]
https://stat.ethz.ch/mailman/listinfo/r-sig-phylo
Searchable archive at http://www.mail-archive.com/[email protected]/
