Tuesday, April 14, 2015

Phylogenetic regression when branch lengths are unknown: A few different scenarios

In a recent R-sig-phylo discussion a user asked if it would be reasonable to use branches sampled assuming a Yule process in phylogenetic regression under conditions in which the branch lengths of the tree are unknown. Although I supplied a function designed to sample branching times on an arbitrary topology given this process, I could not answer the question of whether it was a good idea (or not) to use Yule process edge lengths when the topology was known, but branch lengths are not, even if it is reasonable to assume that the tree arose under a pure-birth process.

Here, I attempt to briefly explore that question.

First, my function to sample edges lengths under a Yule process (from last time):

yuleEdges<-function(tree,b=1,plot=TRUE,...){
    ll<-rexp(n=Ntip(tree)-1,rate=2:Ntip(tree)*b)
    tree$edge.length<-rep(0,nrow(tree$edge))
    live.nodes<-Descendants(tree,Ntip(tree)+1,"children")
    tips<-vector()
    for(i in 1:length(ll)){
        tips<-c(tips,live.nodes[live.nodes<=Ntip(tree)])
        live.nodes<-setdiff(live.nodes,tips)
        ii<-which(tree$edge[,2]%in%c(live.nodes,tips))
        tree$edge.length[ii]<-tree$edge.length[ii]+ll[i]
        node<-if(length(live.nodes)<=1) live.nodes else 
            sample(live.nodes,1) ## choose one node
        live.nodes<-c(setdiff(live.nodes,node),
            Descendants(tree,node,"children"))
        if(plot) plotTree(tree,...)
    }
    tree
}

Now, let's simulate some data. First, let's try uncorrelated data. We can thus explore bias & variance in the estimate of the contrasts/PGLS regression slope (it should be zero), as well as type I error.

## load libraries
library(phytools)
library(phangorn)
library(ape)
## simulate 200 pure-birth trees:
trees<-ttrees<-pbtree(n=50,scale=1,nsim=200)
## ttrees contains the trees with their original branch lengths
## we'll perform manipulations on trees
foo<-function(tree){
    obj<-fastBM(tree,nsim=2)
    colnames(obj)<-c("x","y")
    as.data.frame(obj)
}
xy<-lapply(ttrees,foo)

Next, as a control for our experiment, let's fit contrasts regressions (PGLS,here) to each of these, using the known, true branch lengths. We'll just pull out the slope, β1 and the P-value for each regression:

library(nlme)
fit.model<-function(tree,data){
    data$v<-diag(vcv.phylo(tree))
    fit<-gls(y~x,data=data,correlation=corBrownian(1,tree),
        weights=varFixed(~v))
    setNames(c(coefficients(fit)[2],anova(fit)$"p-value"[2]),
        c("beta","p-value"))
}
fit.true<-t(mapply(fit.model,trees,xy))
mean(fit.true[,1]) ## should be zero
## [1] -0.005196606
## should be uniform on [0,1]
hist(fit.true[,2],freq=FALSE,xlab="P-value",
    main="P-values, known branch lengths") 

plot of chunk unnamed-chunk-3

mean(fit.true[,2]<=0.05) ## should be about 0.05
## [1] 0.035

OK, now imagine we are in a situation without branch lengths. We're going to consider a few different possibilities:

(1) All branch lengths set equal to 1.0.

(2) Grafen's (1989) branch lengths.

(3) Branch lengths randomly sampled under a Yule process.

First (1), setting all branch lengths to zero:

foo<-function(tree){
    tree$edge.length<-rep(1,nrow(tree$edge))
    tree
}
trees<-lapply(ttrees,foo)
class(trees)<-"multiPhylo"
fit.equal<-t(mapply(fit.model,trees,xy))
mean(fit.equal[,1]) ## should be zero
## [1] -0.006076158
## should be uniform on [0,1]
hist(fit.equal[,2],freq=FALSE,xlab="P-value",
    main="P-values, all branch lengths 1.0")

plot of chunk unnamed-chunk-4

mean(fit.equal[,2]<=0.05) ## should be 0.05
## [1] 0.125

Now (2), using Grafen's (1989) branch lengths:

trees<-lapply(ttrees,compute.brlen)
class(trees)<-"multiPhylo"
fit.grafen<-t(mapply(fit.model,trees,xy))
mean(fit.grafen[,1]) ## should be zero
## [1] -0.007811392
## should be uniform on [0,1]
par(mar=c(5.1,4.1,4.1,2.1))
hist(fit.grafen[,2],freq=FALSE,xlab="P-value",
    main="P-values, Grafen edge lengths") 

plot of chunk unnamed-chunk-5

mean(fit.grafen[,2]<=0.05) ## should be 0.05
## [1] 0.125

Finally, (3), branch lengths sampled under a Yule process. Now for this, rather than using one set of branch lengths, for each tree we should simulate a set of branch lengths and then average our inference over this set. This is logical, because any individual set of branch lengths will be wrong, but perhaps by computing the variance among our estimated parameter and adding it to the mean variance of each estimate (under the law of total variance) should give us the correct variance of our estimator. Let's do this:

## this function simulates 100 sets of edge lengths, fits the model
## to each of them using PGLS, and extracts the coefficient & variance
## then averages the variance across trees, adds this to the variance
## among trees, and computes a p-value for the parameter from the 
## t-distribution
yuleApply<-function(tree,data,nrep=100){
    trees<-replicate(nrep,yuleEdges(tree,plot=FALSE),simplify=FALSE)
    class(trees)<-"multiPhylo"
    gls.fit<-function(tree,data){
        obj<-gls(y~x,data=data,correlation=corBrownian(1,tree))
        setNames(c(coefficients(obj)[2],obj$varBeta[2,2]),
            c("beta","varBeta"))
    }
    fit<-t(sapply(trees,gls.fit,data=data))
    b<-mean(fit[,"beta"])
    v<-var(fit[,"beta"])+mean(fit[,"varBeta"])
    p<-2*pt(abs(b/sqrt(v)),df=Ntip(tree)-1,lower.tail=FALSE)
    setNames(c(b,v,p),c("beta","varBeta","p-value"))
}
fit.yule<-t(mapply(yuleApply,ttrees,xy))
mean(fit.yule[,1]) ## should be zero
## [1] -0.03133003
## should be uniform on [0,1]
hist(fit.yule[,3],freq=FALSE,xlab="P-value",
    main="P-values, Yule branch lengths")

plot of chunk unnamed-chunk-6

mean(fit.yule[,3]<=0.05) ## should be 0.05
## [1] 0

So, unless I messed something up here, it looks as though simulating edge lengths under a Yule process, though unbiased, is excessively conservative.

Next, let's try the situation in which x and y are genuinely correlated. Again, we start with the data generation, say with β1 = 0.4:

foo<-function(tree,beta,vare){
    x<-fastBM(tree)
    e<-fastBM(tree,sig2=vare)
    y<-beta*x+e
    data.frame(x,y)
}
xy<-lapply(ttrees,foo,beta=0.4,vare=1.2)

First, with the true edge lengths:

fit.true<-t(mapply(fit.model,trees,xy))
mean(fit.true[,1]) ## should be 0.4
## [1] 0.3856536
## this is power now, rather than type I error
mean(fit.true[,2]<=0.05)
## [1] 0.615

Now all edge lengths to 1.0:

foo<-function(tree){
    tree$edge.length<-rep(1,nrow(tree$edge))
    tree
}
trees<-lapply(ttrees,foo)
class(trees)<-"multiPhylo"
fit.equal<-t(mapply(fit.model,trees,xy))
mean(fit.equal[,1]) ## should be 0.4
## [1] 0.3946721
mean(fit.equal[,2]<=0.05) ## power
## [1] 0.605

Now Grafen's edge lengths with compute.brlen:

trees<-lapply(ttrees,compute.brlen)
class(trees)<-"multiPhylo"
fit.grafen<-t(mapply(fit.model,trees,xy))
mean(fit.grafen[,1]) ## should be 0.4
## [1] 0.3856536
mean(fit.grafen[,2]<=0.05) ## power
## [1] 0.615

Now, branching times sampled under a Yule process, as before:

fit.yule<-t(mapply(yuleApply,ttrees,xy))
mean(fit.yule[,1]) ## should be 0.4
## [1] 0.3870531
mean(fit.yule[,3]<=0.05) ## power
## [1] 0.145

So, there you have it. Although it would seem to be the case that sampling branching times under which the known true branches arose, a Yule process, would be a good strategy when the branch lengths are unknown - this has the effect of leading to a type I error rate considerably below the nominal rate, as well as to low power relative to other kinds of arbitrary branch lengths. Who knew!

Monday, April 13, 2015

Sampling edge lengths under a Yule process

There has been a little bit of discussion today on R-sig-phylo listserve about transforming branch lengths.

One thing that wasn't mentioned was the possibility of sampling branch lengths under a model. I thought it would be straightforward to sample branch lengths under a Yule model (that is, a pure-birth speciation model).

The following is code that does this. (Set plot=TRUE to see a cool animation of the tree being 'grown' from left to right.)

pb_edgelength<-function(tree,b=1,plot=TRUE,...){
    ll<-rexp(n=Ntip(tree)-1,rate=2:Ntip(tree)*b)
    tree$edge.length<-rep(0,nrow(tree$edge))
    live.nodes<-Descendants(tree,Ntip(tree)+1,"children")
    tips<-vector()
    for(i in 1:length(ll)){
        tips<-c(tips,live.nodes[live.nodes<=Ntip(tree)])
        live.nodes<-setdiff(live.nodes,tips)
        ii<-which(tree$edge[,2]%in%c(live.nodes,tips))
        tree$edge.length[ii]<-tree$edge.length[ii]+ll[i]
        node<-if(length(live.nodes)<=1) live.nodes else 
            sample(live.nodes,1) ## choose one node
        live.nodes<-c(setdiff(live.nodes,node),
            Descendants(tree,node,"children"))
        if(plot) plotTree(tree,...)
    }
    tree
}

OK, now let's try it out with a tree obtained using rtree from the ape package:

library(phytools)
library(phangorn)
tree<-rtree(n=100,br=NULL) ## no branch lengths
t.pb<-pb_edgelength(tree,plot=FALSE)
plotTree(t.pb,ftype="off")

plot of chunk unnamed-chunk-2

par(mar=c(5.1,4.1,2.1,2.1))
obj<-ltt(t.pb)

plot of chunk unnamed-chunk-2

obj$gamma
## [1] -0.1807099

Compare this to Grafen's edge lengths from compute.brlen:

t.grafen<-compute.brlen(tree)
plotTree(t.grafen,ftype="off")

plot of chunk unnamed-chunk-3

par(mar=c(5.1,4.1,2.1,2.1))
obj<-ltt(t.grafen)

plot of chunk unnamed-chunk-3

obj$gamma
## [1] 6.732706

Obviously, the branching times from Grafen's branch length transformation are very different from those obtained under a Yule process!

That's it, really.

Sunday, April 12, 2015

User-supplied bug fix for fastAnc

A phytools user, David Labonte from the University of Cambridge, recently reported the following bug with the phytools function fastAnc:

“I am using your fastAnc function to estimate ancestral states of a continuous variable, and it runs smoothly, however only if CI=FALSE. I also noted that it returns a longer variance than ancestral state estimation vector. Notably, this problem only arises for non-dichotomous trees.”

David also was kind enough to provide the following example which reproduces the error very nicely (modified slightly):

library(phytools)
set.seed(1)
tree<-pbtree(n=10,scale=1)
plotTree(tree,node.numbers=TRUE)

plot of chunk unnamed-chunk-1

x<-fastBM(tree)
fastAnc(tree,x,vars=TRUE,CI=TRUE) ## runs smoothly without error
## $ace
##          11          12          13          14          15          16 
## -0.35538758 -0.39739912 -0.32825378 -0.51263348 -0.32987276 -0.13938453 
##          17          18          19 
## -0.14780235 -0.07371257 -0.09712277 
## 
## $var
##          11          12          13          14          15          16 
## 0.081863455 0.063948796 0.045742058 0.019817948 0.006889495 0.027865560 
##          17          18          19 
## 0.003468311 0.022557094 0.009799787 
## 
## $CI95
##          [,1]        [,2]
## 11 -0.9161787  0.20540351
## 12 -0.8930459  0.09824762
## 13 -0.7474467  0.09093912
## 14 -0.7885549 -0.23671206
## 15 -0.4925586 -0.16718692
## 16 -0.4665670  0.18779789
## 17 -0.2632314 -0.03237331
## 18 -0.3680854  0.22066021
## 19 -0.2911508  0.09690522
tree<-collapse.to.star(tree,fastMRCA(tree,"t6","t9"))
plotTree(tree,node.numbers=TRUE)

plot of chunk unnamed-chunk-1

fastAnc(tree,x) ## works no problem
##         11         12         13         14         15         16 
## -0.3498724 -0.3911156 -0.3188186 -0.5111098 -0.3295891 -0.1216447
fastAnc(tree,x,vars=TRUE) ## works, but vars is wrong length
## $ace
##         11         12         13         14         15         16 
## -0.3498724 -0.3911156 -0.3188186 -0.5111098 -0.3295891 -0.1216447 
## 
## $var
##          11          12          13          14          15          16 
## 0.077702044 0.060153127 0.040920299 0.018985301 0.006625218 0.015899879
fastAnc(tree,x,vars=TRUE,CI=TRUE) ## doesn't work at all
## $ace
##         11         12         13         14         15         16 
## -0.3498724 -0.3911156 -0.3188186 -0.5111098 -0.3295891 -0.1216447 
## 
## $var
##          11          12          13          14          15          16 
## 0.077702044 0.060153127 0.040920299 0.018985301 0.006625218 0.015899879 
## 
## $CI95
##          [,1]        [,2]
## 11 -0.8962241  0.19647933
## 12 -0.8718278  0.08959662
## 13 -0.7153024  0.07766520
## 14 -0.7811727 -0.24104701
## 15 -0.4891242 -0.17005403
## 16 -0.3687903  0.12550100

Even better, David solved the bug by correctly identifying the error in the code. In his own words, he says:

“I looked through the code of the function, and while I am certainly not a R coding expert, I believe the problem lies in line 28:

27    if (vars || CI) {
28        v[as.character(ancNames[, 2])]
29        names(v) <- ancNames[, 1]
30    }

analogous to the previous lines, I think this should read

27    if (vars || CI) {
28        v <- v[as.character(ancNames[, 2])]
29        names(v) <- ancNames[, 1]
30    }

This is exactly correct, and if we fix this then we find that the function now works perfectly:

source("fastAnc.R")
fastAnc(tree,x,vars=TRUE,CI=TRUE)
## $ace
##         11         12         13         14         15         16 
## -0.3498724 -0.3911156 -0.3188186 -0.5111098 -0.3295891 -0.1216447 
## 
## $var
##          11          12          13          14          15          16 
## 0.077702044 0.060153127 0.040920299 0.018985301 0.006625218 0.015899879 
## 
## $CI95
##          [,1]        [,2]
## 11 -0.8962241  0.19647933
## 12 -0.8718278  0.08959662
## 13 -0.7153024  0.07766520
## 14 -0.7811727 -0.24104701
## 15 -0.4891242 -0.17005403
## 16 -0.3687903  0.12550100

Cool! If only fixing all the bugs in phytools was this easy!

Wednesday, April 8, 2015

Finding the closest set of node rotations to a given tip ordering

An R-sig-phylo user asked the following:

“Is there an easy way to get R to automatically rotate the nodes of a phylogeny to match an arbitrary ordering of the tips?…. Say I have a particular taxonomic order, such as: SpeciesA, SpeciesC, SpeciesB…. And I want to rotate the nodes of ((C,B),A) to match it - ie to automatically rotate the nodes to give (A(C,B))”

Well, there are some functions in ape that do something related to this (or perhaps this precisely) - I'm thinking rotateConstr and perhaps cophyloplot, but phytools also has a function, minRotate, used primarily internally in phylo.to.map, which attempts to do this. It does it via a simple, greedy algorithm of performing a pre-order traversal of the tree, rotating each node, and accepting the rotation if it improves the objective function which is the match between the desired order and the realized order.

Remarkably, this seems to be surprisingly effective at finding the original order if a set of random rotations are applied to the nodes of a tree.

So, for example:

library(phytools)
tree<-pbtree(n=26,tip.label=LETTERS)
plotTree(tree)

plot of chunk unnamed-chunk-1

## random set of 100 rotations
nn<-sample(1:tree$Nnode+Ntip(tree),100,replace=TRUE)
for(i in 1:length(nn)) tree<-read.tree(text=write.tree(rotate(tree,nn[i])))
## tree all scrambled up
plotTree(tree)

plot of chunk unnamed-chunk-1

## original order
x<-setNames(1:Ntip(tree),LETTERS)
unscrambled<-minRotate(tree,x)
## objective: 48
## objective: 48
## objective: 48
## objective: 44
## objective: 40
## objective: 40
## objective: 40
## objective: 36
## objective: 36
## objective: 34
## objective: 22
## objective: 20
## objective: 18
## objective: 14
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 8
## objective: 6
## objective: 6
## objective: 2
## objective: 2
## objective: 0
## objective: 0
plotTree(unscrambled)

plot of chunk unnamed-chunk-1

This even seems to work for larger trees:

tree<-pbtree(n=200)
x<-setNames(1:200,tree$tip.label)
## random rotations
nn<-sample(1:tree$Nnode+Ntip(tree),100,replace=TRUE)
for(i in 1:length(nn)) tree<-read.tree(text=write.tree(rotate(tree,nn[i])))
## the objective function going to zero indicated fully
## unscrambled
unscrambled<-minRotate(tree,x)
## objective: 6842
## objective: 6842
## objective: 6034
## objective: 6034
## objective: 6032
## objective: 6032
## objective: 6006
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5948
## objective: 5946
## objective: 5942
## objective: 5942
## objective: 5942
## objective: 5942
## objective: 5872
## objective: 5872
## objective: 5872
## objective: 5872
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5864
## objective: 5860
## objective: 5860
## objective: 5848
## objective: 5848
## objective: 5846
## objective: 5840
## objective: 5840
## objective: 5840
## objective: 5838
## objective: 5836
## objective: 5836
## objective: 5836
## objective: 5836
## objective: 5836
## objective: 5836
## objective: 5836
## objective: 5834
## objective: 5822
## objective: 5820
## objective: 5820
## objective: 5820
## objective: 5818
## objective: 4994
## objective: 4994
## objective: 4994
## objective: 4856
## objective: 4856
## objective: 4854
## objective: 4854
## objective: 4844
## objective: 4844
## objective: 4842
## objective: 4842
## objective: 4842
## objective: 4842
## objective: 4840
## objective: 4836
## objective: 4836
## objective: 4834
## objective: 4834
## objective: 4834
## objective: 4834
## objective: 4834
## objective: 4832
## objective: 4828
## objective: 4828
## objective: 4828
## objective: 4828
## objective: 4826
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4824
## objective: 4820
## objective: 4820
## objective: 4820
## objective: 4820
## objective: 4818
## objective: 4810
## objective: 4810
## objective: 4810
## objective: 4810
## objective: 2498
## objective: 2498
## objective: 2498
## objective: 2498
## objective: 2498
## objective: 2492
## objective: 2492
## objective: 2490
## objective: 2488
## objective: 2486
## objective: 2324
## objective: 2324
## objective: 2324
## objective: 2324
## objective: 2324
## objective: 2320
## objective: 2320
## objective: 2320
## objective: 2320
## objective: 2320
## objective: 2316
## objective: 2316
## objective: 2314
## objective: 2314
## objective: 2314
## objective: 2308
## objective: 2308
## objective: 2306
## objective: 2304
## objective: 2300
## objective: 2300
## objective: 2294
## objective: 2294
## objective: 2294
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 172
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 170
## objective: 168
## objective: 168
## objective: 168
## objective: 164
## objective: 164
## objective: 160
## objective: 160
## objective: 158
## objective: 158
## objective: 158
## objective: 28
## objective: 28
## objective: 28
## objective: 28
## objective: 26
## objective: 24
## objective: 24
## objective: 24
## objective: 24
## objective: 24
## objective: 24
## objective: 24
## objective: 24
## objective: 22
## objective: 20
## objective: 18
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 10
## objective: 6
## objective: 6
## objective: 0
## objective: 0
## objective: 0
## objective: 0

I have no idea whether this will work in general - nor if this strategy will minimize the objective function if a perfect match does not exist. Nonetheless….

That's all!