phytools/0000755000176200001440000000000013202062445012131 5ustar liggesusersphytools/inst/0000755000176200001440000000000013027036441013110 5ustar liggesusersphytools/inst/CITATION0000644000176200001440000000113512130372061014240 0ustar liggesuserscitHeader("To cite phytools in publication use:") citEntry( entry="Article", title="phytools: An R package for phylogenetic comparative biology (and other things).", author="Liam J. Revell", journal="Methods in Ecology and Evolution", year=2012, volume="3", pages="217-223", textVersion="Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). Methods Ecol. Evol. 3 217-223. doi:10.1111/j.2041-210X.2011.00169.x" ) citFooter("As phytools is continually evolving, you may want to cite its version number. Find it with 'help(package=phytools)'.") phytools/NAMESPACE0000644000176200001440000001776713201672437013401 0ustar liggesusersexport(add.arrow, add.color.bar, add.everywhere, add.random, add.simmap.legend, add.species.to.genus, aic.w, allFurcTrees) export(allRotations, anc.Bayes, anc.ML, anc.trend, ancThresh, applyBranchLengths, arc.cladelabels, as.multiPhylo, ave.rates, averageTree) export(backbone.toPhylo, bd, bmPlot, bind.tip, bind.tree.simmap, biplot.phyl.pca, branching.diffusion, brownie.lite, brownieREML) export(cladelabels, coef.phyl.RMA, collapse.to.star, collapseTree, compare.chronograms, consensus.edges, contMap, cophylo, countSimmap) export(compute.mr, cospeciation) export(density.multiSimmap, densityMap, densityTree, describe.simmap, di2multi.simmap, dot.legend, dotTree, drop.clade, drop.leaves) export(drop.tip.contMap, drop.tip.densityMap, drop.tip.simmap, drop.tip.singleton) export(edgelabels.cophylo, edgeProbs, errorbar.contMap, estDiversity, evol.rate.mcmc, evol.vcv, evolvcv.lite, exhaustiveMP) export(expand.clade, expm, export.as.xml, extract.clade.simmap, extract.strahlerNumber) export(fancyTree, fastAnc, fastBM, fastDist, fastHeight, fastMRCA, findMRCA, fit.bd, fit.yule, fitBayes, fitMk, fitDiversityModel, fitPagel) export(force.ultrametric) export(gammatest, genus.to.species.tree, genSeq, geo.legend, get.treepos, getCladesofSize, getDescendants, getExtant, getExtinct, getnode) export(getParent, getSisters, getStates) export(labelnodes, ladderize.simmap, lambda.transform, lik.bd, likMlambda, likSurface.rateshift, linklabels, locate.fossil, locate.yeti) export(ls.consensus, ls.tree, ltt, ltt95) export(make.era.map, make.simmap, make.transparent, map.overlap, Map.Overlap, map.to.singleton, mapped.states, markChanges) export(matchLabels, matchNodes, mergeMappedStates, midpoint.root, minRotate, minSplit, minTreeDist, modified.Grafen) export(mrp.supertree, multi.mantel, multiC, multiOU, multiRF) export(nodeheight, nodeHeights, nodelabels.cophylo, node.paths) export(optim.phylo.ls, orderMappedEdge) export(paintBranches, paintSubTree, paste.tree, pbtree, pgls.Ives, pgls.SEy, phenogram, phyl.cca, phyl.pairedttest, phyl.pca, phyl.resid, phyl.RMA) export(phyl.vcv, phylo.heatmap, phylo.toBackbone, phylo.to.map, phylANOVA, phyloDesign, phylomorphospace, phylomorphospace3d, phylosig) export(plot.changesMap, plot.contMap, plot.cophylo, plot.densityMap, plot.fitMk, plot.fitPagel, plot.phyl.RMA, plot.phylo.to.map, plot.gfit) export(plotBranchbyTrait, plotSimmap, plotThresh, plotTree, plotTree.barplot, plotTree.boxplot, plotTree.errorbars, plotTree.singletons) export(plotTree.splits, plotTree.wBars, posterior.evolrate, posthoc, posthoc.ratebytree) export(ratebystate, ratebytree, rateshift, read.newick, read.simmap, reorder.backbonePhylo, reorderSimmap, rep.multiPhylo, rep.phylo) export(repPhylo, reroot, rerootingMethod, rescaleSimmap, resolveAllNodes, resolveNode, rotate.multi, rotateNodes, rootedge.to.singleton) export(roundBranches, roundPhylogram, rstate) export(sampleFrom, setMap, sim.corrs, sim.history, sim.ratebystate, sim.rates, skewers, splitEdgeColor, splitplotTree) export(splitTree, starTree, strahlerNumber) export(threshBayes, threshDIC, threshState, tiplabels.cophylo, tipRotate, to.matrix, treeSlice) export(untangle) export(vcvPhylo) export(write.simmap, writeAncestors, writeNexus) S3method(plot, densityMap) S3method(plot, contMap) S3method(plot, phylo.to.map) S3method(plot, backbonePhylo) S3method(reorder, backbonePhylo) S3method(print, backbonePhylo) S3method(print, phyl.pca) S3method(summary, phyl.pca) S3method(biplot, phyl.pca) S3method(print, brownie.lite) S3method(print, densityMap) S3method(print, contMap) S3method(print, rateshift) S3method(logLik, rateshift) S3method(print, evol.vcv) S3method(plot, ltt95) S3method(print, ltt95) S3method(plot, describe.simmap) S3method(print, describe.simmap) S3method(rep, phylo) S3method(rep, multiPhylo) S3method(print, fitPagel) S3method(print, ltt) S3method(print, multiLtt) S3method(plot, ltt) S3method(plot, multiLtt) S3method(plot, cophylo) S3method(print, cophylo) S3method(plot, simmap) S3method(print, simmap) S3method(summary, simmap) S3method(plot, multiSimmap) S3method(print, multiSimmap) S3method(summary, multiSimmap) S3method(reorder, simmap) S3method(plot, rateshift) S3method(print, fastAnc) S3method(print, anc.ML) S3method(print, fitMk) S3method(summary, fitMk) S3method(logLik, fitMk) S3method(print, brownieREML) S3method(AIC, fitMk) S3method(print, phylo.to.map) S3method(as.phylo, simmap) S3method(as.multiPhylo, multiSimmap) S3method(as.multiPhylo, phylo) S3method(plot, fitPagel) S3method(plot, fitMk) S3method(plot, gfit) S3method(plot, phyl.pca) S3method(summary, cophylo) S3method(print, multiCophylo) S3method(plot, multiCophylo) S3method(logLik, simmap) S3method(logLik, multiSimmap) S3method(plot, cospeciation) S3method(print, cospeciation) S3method(density, multiSimmap) S3method(plot, changesMap) S3method(print, changesMap) S3method(plot, phyloScattergram) S3method(print, phyloScattergram) S3method(di2multi, simmap) S3method(print, aic.w) S3method(print, phyl.RMA) S3method(coef, phyl.RMA) S3method(residuals, phyl.RMA) S3method(plot, phyl.RMA) S3method(print, ratebytree) S3method(print, evolvcv.lite) S3method(print, expand.clade) S3method(plot, expand.clade) S3method(posthoc, ratebytree) S3method(print, posthoc.ratebytree) S3method(AIC, ratebytree) S3method(print, fit.bd) S3method(logLik, fit.bd) S3method(print, anc.trend) S3method(logLik, anc.trend) S3method(print, ancThresh) S3method(plot, ancThresh) S3method(print, evol.rate.mcmc) S3method(print, threshBayes) S3method(plot, threshBayes) S3method(print, rerootingMethod) S3method(plot, rerootingMethod) S3method(logLik, rerootingMethod) S3method(print, fitBayes) S3method(plot, fitBayes) S3method(print, ratebystate) S3method(print, phylANOVA) S3method(print, pgls.Ives) S3method(logLik, pgls.Ives) S3method(print, phyl.cca) S3method(print, anc.Bayes) S3method(plot, anc.Bayes) importFrom(animation, ani.options, ani.record, ani.replay, saveVideo) importFrom(ape, .PlotPhyloEnv, .uncompressTipLabel, ace, all.equal.phylo, as.DNAbin, as.phylo, bind.tree, branching.times, collapse.singles) importFrom(ape, consensus, compute.brlen, cophenetic.phylo, corBrownian, di2multi, dist.dna, dist.nodes, drop.tip, edgelabels, extract.clade) importFrom(ape, getMRCA, is.binary.tree) importFrom(ape, is.monophyletic, is.rooted, is.ultrametric, ladderize, matexpo, mrca, multi2di, neworder_phylo, neworder_pruningwise) importFrom(ape, nodelabels, Ntip, pic, plot.phylo, prop.part, read.tree, reorder.phylo, root, rotate, rtree, stree, tiplabels) importFrom(ape, unroot, vcv, vcv.phylo, write.tree) importFrom(clusterGeneration, genPositiveDefMat) importFrom(maps, map) importFrom(mnormt, dmnorm, pd.solve) importFrom(msm, MatrixExp) importFrom(numDeriv, hessian) importFrom(phangorn, allTrees, Ancestors, as.phyDat, dist.hamming, midpoint, NJ, nni, nnls.tree, optim.parsimony, parsimony, phyDat, pratchet, treedist, RF.dist, KF.dist, path.dist, SPR.dist, Children, Descendants, threshStateC) importFrom(plotrix, arctext, draw.arc, draw.circle, draw.ellipse, textbox) importFrom(scatterplot3d, scatterplot3d) importFrom(stats, cophenetic, reorder, runif, setNames, optim, dexp, dnorm, rnorm, var, nlminb, biplot, pchisq, rexp, optimize, logLik, as.dist, pnorm, median, cor, aggregate, rgamma, dgamma, lm, rbinom, rgeom, pt, anova, p.adjust, screeplot, rchisq, optimHess, rmultinom, sd, dunif, dist, plogis, density, coef, cmdscale) importFrom(methods, hasArg) importFrom(graphics, strwidth, par, segments, locator, lines, text, strheight, symbols, plot, layout, plot.new, title, axis, points, plot.window, polygon, rect, curve, image, mtext, arrows, barplot, boxplot, contour, hist, abline, legend, grid) importFrom(utils, flush.console, installed.packages, str, capture.output) importFrom(grDevices, palette, colors, dev.hold, dev.flush, rainbow, heat.colors, gray, colorRampPalette, dev.new, rgb, pdf, dev.off, col2rgb) importFrom(combinat, permn) importFrom(coda, HPDinterval) importFrom(nlme, gls, varFixed) importFrom(MASS, ginv) phytools/data/0000755000176200001440000000000013027037142013043 5ustar liggesusersphytools/data/anoletree.rda0000644000176200001440000001222312564410646015522 0ustar liggesusers] |SE)aAXP@ r$7i"\(-M.M yc)-觟QYE"( XD'"--;1g+vJQ~33g̜yސ982Nt\45%c{E N>mp`nB.pwr@KB=S'Y*r 鈜l!>TC95#OXGL~O4IѩΩ)I$ 'R թӑz~2!dH7\CK58HG(.\Mi( tJ-Щ/  4S 2$2ByC:Ю\9\ȇ|2 %ZDBȷpг),2 %r 9ovg/R 4+ԡSS  ʩq1mCX~  +[= @o%x2 4 9Z?h% W@-@KJ! H8t?@ ~ AA'/?$‡P ./ zt ~ >G(;Gpc!\GCjXn,\Ч>?8 g /gcx2!?>C n&D5˃Ik]x= kieBVn!AnX @h C~W!/bœVp_~Bx%5ECu+.Ӷ^ vPʍ((5+b; 0 Fl ;y!V6Bg1׆K ŠU0ĆydDo+*t)F:m[ֵ56J>N eWb\Ib:p}ڀhVQ˰+o+$k(}划p 8&|ڼKVw7ʼyip:jvc㻵m %a"X)W-u)_ 6y1en߸E ݂Vxkq(:NB= !,5O݉ݒ4^DסZnea*RZ2-ŰQ/!waiieM3NE?Jg`廕_ i1sZgthY-gr56# 8. 6}I7_]k~wF?붋/C+o_ Unl6zc_3ܵς4TohGߦt&gDk| }KǮ k_l"$ל]mPGѬ6=u2љ-;]ba:xS_gIFUUtxހCz"+:6w{P;%r[7q-I$toSTmxu>סS?6u%_8:?q;p;19bKż!/,ѽs*['?P; EUOޣ?;E5LYh?6tAf\[;ѱ.E>2\JY 0 w6:;n ~= &WOFgBﰼIt^oW.xzSwBkt|nAZGO7ԴL~SZknVt`VNƫ߽ʞ_p5A{6t,Y>m&_ъj銊˿BsWYJ'̞}ytb{):ZSJL&K>%{:[SmYhD_mG$e/7O^T~hH6ѱ]wtOA[Uf?t)DC;s~?gUѱ)c=l& ]<~^Ir-19MŐGRѡj7xoj};|̀2{G?.~' X>;&.Λ, Ӽ~]aw7,Lt]ܓn؀j%=oD oy륱=^md:w0ţ% }b3fmuEJx'vגu??Rݯm}>ͪѴf>*^Rp_D+=87o޿{$ ,q{i5:sW ţ2` g7돪ύE,׽8׃[thtt5=ޅؘ3M[^"ڬ?Lygh.٭{8~VqS5!QJxak04"R#I.փKL'N&R6 h.₆!0PQʆޑA C#%PJ4 h)0TG]pxi:&!k䱷5T6tva@L.(0DD ӘajDr"(J4L(0l ץ*[!:xk?}_maB*7-C[6M9HbA2e$UntR/\$5 U,e-wD&Ɣuz򿞜|jp kG6NaMi冡a OYnSv< mVPFrk$',X(]Sfbw l߁i\nXY4Gx3Y/}*EJ Ѱ̣Db KFJ4,(ゆE*,e)eÂ7òv,)[?WV&[mv/Q4ͰplP\Bm7v mu:jyKdCvvٶ]D67hQ-JٰQBJ4l 8s6" 4l,Ѣ#Om0949;Utf½?24ccd;-Vn/lQaK..hC@*m_8.zpwPVcTaC G[?U; UvxMALfĘv'L6E)ѰuJոavҥDÆo #O]lN禡>IFUԷz.єm6dkR6l|L;N)6)Ѱmt:2oy݁$wЬz-ykt1#Siw" sH8r 1(pA#ʹ/PʆJ4 :h8!Qʆ&ʹG͎D9ӭGۭ#rE9'#1J4Qx oqAÁ%(p8H9p]$ں-ކGV 1)pt:7>*y5v}lϠVdLk庩{{ڴAG<5,- x)p4)ӡ3hnL{j!wGwg1vm먥#\}~hş˭Sc/\jdj2į!'ڋQ8Yn/>[<'^~qN/ɘj>3F%.w.mNdC]}.C6]#\}~}Gȷ܆n$6Y>p?SM/1dZ>Vf|e#sp<[k6h51VVbXj3cHKL:cJ$ҀinKc w#y neXXIh306IbL䲌0~3cQK︼;O*ؤڰZRimVƐd `0)lg#$lXp ~ŬAf %R+c`UY0"sX1΃hѐfs0aY lSr45"i2fZAPE.6hRq*I1UEU0lI6AӀmgs1!TeV'+TJy R`ؔY=C$, :l%)r=Ĩ[BtdVe1#nF$FlE5I7. z0),o43tgUC*)X_cekb(kP'W; Sn`XV]j`mb±rW58Oa(ư õkmiʚNf3Id -d ep06ڔY6 j9 1Ul0YnCX=Y;+ۋbe{lQqj%kd̲ذ+5`M٦,i*c*SAPٲ,[-Z\e3(  *9Z01 "{blYE}qw4˺]F0㒙e#q&9V&=Mr*™2)WHQefPw2%I78vV&]E%<6`,r`u*NC  UQhuO*WW.75O=?[>@Ǖ jN6+'&t Nޛ#f|WϻRo-m2hܐ?m{6r{)? .g5N4c͚vTjt)%ۇ]6z -.(7칮F>4ȏ7ShLjX"Lk5%2"㉣0A/ nhFoQI{x[wHUk6bH x$|,2)`sEMd*_ΰU ”6R$c W@LWoŬnphytools/R/0000755000176200001440000000000013201723665012341 5ustar liggesusersphytools/R/backbonePhylo.R0000644000176200001440000002453612741776063015266 0ustar liggesusers## function to manipulate & plot objects of class "backbonePhylo" ## written by Liam J. Revell 2013, 2016 backbone.toTrans<-function(obj){ tip.label<-obj$tip.label clade.label<-sapply(obj$tip.clade,function(x) x$label) N<-sapply(obj$tip.clade,function(x) x$N) depth<-sapply(obj$tip.clade,function(x) x$depth) data.frame(tip.label,clade.label,N,depth) } ## convert "phylo" to "backbonePhylo" phylo.toBackbone<-function(x,trans=NULL,...){ if(!inherits(x,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(interactive)) interactive<-list(...)$interactive else interactive<-is.null(trans) if(hasArg(height)) height<-list(...)$height else height<-"mean" if(interactive){ options(locatorBell=FALSE) if(is.null(x$node.label)) x$node.label<-as.character(1:x$Nnode+Ntip(x)) if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...) cat(" Select clade to collapse.\n") flush.console() check<-textbox(x=c(par()$usr[1],par()$usr[1]+ 0.1*(par()$usr[2]-par()$usr[1])), y=par()$usr[4],c("click to stop"),justify="c") xy<-unlist(locator(1)) while(!(xy[1]>par()$usr[1]&&xy[1]check&&xy[2] ") flush.console() clab<-readLines(n=1) if(obj$where<=Ntip(x)){ if(clab=="") clab<-x$tip.label[obj$where] tlab<-x$tip.label[obj$where] depth<-obj$pos N<-if(inherits(x,"backbonePhylo")) x$tip.clade[[obj$where]]$N else 1 if(!inherits(x,"backbonePhylo")){ trans<-data.frame(tip.label=as.character(tlab), clade.label=as.character(clab),N=N,depth=depth) x<-phylo.toBackbone(x,trans) } else { x$tip.clade[[obj$where]]<-list(label=as.character(clab), N=N,depth=depth, id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE), collapse="")) x$tip.label[obj$where]<-x$tip.clade[[obj$where]]$id } } else { if(clab=="") clab<-x$node.label[obj$where-Ntip(x)] tlab<-x$node.label[obj$where-Ntip(x)] split<-list(node=obj$where, bp=x$edge.length[which(x$edge[,2]==obj$where)]-obj$pos) tip.clade<-if(!is.null(x$tip.clade)) x$tip.clade else NULL aclass<-class(x) tmp<-splitTree(x,split) tip<-which(tmp[[1]]$tip.label=="NA") if(height=="mean") depth<-obj$pos+ mean(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) else if(height=="max") depth<-obj$pos+ max(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) else if(height=="min") depth<-obj$pos+ min(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]<- tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]+depth if(inherits(x,"backbonePhylo")){ dd<-getDescendants(x,obj$where) N<-sum(sapply(x$tip.clade[dd[dd<=Ntip(x)]],function(x) x$N)) } else { dd<-getDescendants(x,obj$where) N<-sum(dd<=Ntip(x)) } x<-tmp[[1]] x$tip.label[tip]<-tlab trans<-data.frame(tip.label=as.character(tlab), clade.label=as.character(clab),N=N,depth=depth) x<-phylo.toBackbone(x,trans) } if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...) cat("\n Select clade to collapse (or STOP).\n") flush.console() check<-textbox(x=c(par()$usr[1],par()$usr[1]+ 0.1*(par()$usr[2]-par()$usr[1])), y=par()$usr[4],c("click to stop"),justify="c") xy<-unlist(locator(1)) } } else { if(!inherits(x,"backbonePhylo")){ x$tip.clade<-list() for(i in 1:length(x$tip.label)){ if(x$tip.label[i]%in%trans$tip.label){ ii<-which(trans$tip.label==x$tip.label[i]) x$tip.clade[[i]]<-list() x$tip.clade[[i]]$label<-as.character(trans$clade.label[ii]) x$tip.clade[[i]]$N<-trans$N[ii] x$tip.clade[[i]]$depth<-trans$depth[ii] } else { x$tip.clade[[i]]<-list() x$tip.clade[[i]]$label<-as.character(x$tip.label[i]) x$tip.clade[[i]]$N<-1 x$tip.clade[[i]]$depth<-x$edge.length[which(x$edge[,2]==i)] } x$tip.clade[[i]]$id<-paste(sample(c(letters,LETTERS,0:9),6, replace=TRUE),collapse="") } x$tip.label<-sapply(x$tip.clade,function(y) y$id) class(x)<-c("backbonePhylo","phylo") } else { for(i in 1:nrow(trans)){ ii<-which(x$tip.label==trans$tip.label[i]) tmp<-as.character(trans$clade.label[i]) x$tip.clade[[length(x$tip.clade)+1]]<- list(label=tmp,N=trans$N[i],depth=trans$depth[i], id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE), collapse="")) x$tip.label[ii]<-x$tip.clade[[length(x$tip.clade)]]$id clade.id<-sapply(x$tip.clade,function(y) y$id) ii<-sapply(clade.id,function(x,y) if(x%in%y) which(y==x) else -1, y=x$tip.label) x$tip.clade<-x$tip.clade[ii>0] x$tip.clade<-x$tip.clade[ii[ii>0]] } } } x } ## convert to object of class "phylo" backbone.toPhylo<-function(x){ if(!inherits(x,"backbonePhylo")) stop("x not an object of class \"backbonePhylo\"") x$tip.label<-sapply(x$tip.clade,function(x) x$label) x$tip.clade<-NULL class(x)<-"phylo" x } ## reorder backbone phylogeny reorder.backbonePhylo<-function(x,order="cladewise",...){ ii<-reorder(backbone.toPhylo(x),order,index.only=TRUE) x$edge<-x$edge[ii,] x$edge.length<-x$edge.length[ii] attr(x,"order")<-order x } ## print method print.backbonePhylo<-function(x,...){ cat(paste("\nBackbone phylogenetic tree with",length(x$tip.clade), "subtrees and",x$Nnode,"resolved internal nodes.\n")) n<-min(length(x$tip.clade),5) cat("\nLabels: ") cat(paste(sapply(x$tip.clade[1:n],function(y) y$label),collapse=", ")) cat(", ...\nDiversities: ") cat(paste(sapply(x$tip.clade[1:n],function(y) y$N),collapse=", ")) cat(", ...\n\n") } ## scale N scaleN<-function(x,k){ for(i in 1:length(x$tip.clade)) if(x$tip.clade[[i]]$N>1) x$tip.clade[[i]]$N<-x$tip.clade[[i]]$N*k x } ## plot backbone phylogeny with triangles plot.backbonePhylo<-function(x,...){ if(!inherits(x,"backbonePhylo")) stop("x not an object of class \"backbonePhylo\"") if(hasArg(vscale)) vscale<-list(...)$vscale else vscale<-1 if(hasArg(col)) col<-list(...)$col else col<-"grey" if(length(col)!=Ntip(x)){ if(!is.null(names(col))){ tmp<-setNames(rep("grey",Ntip(x)),sapply(x$tip.clade,function(x) x$label)) for(i in 1:length(col)) tmp[which(names(tmp)==names(col)[i])]<-col[i] col<-tmp } else col<-setNames(rep(col[1],Ntip(x)),sapply(x$tip.clade, function(x) x$label)) } if(is.null(names(col))) names(col)<-sapply(x$tip.clade, function(x) x$label) col<-col[sapply(x$tip.clade,function(x) x$label)] names(col)<-sapply(x$tip.clade,function(x) x$id) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(sep)) sep<-list(...)$sep else sep<-1 if(hasArg(fixed.height)) fixed.height<-list(...)$fixed.height else fixed.height<-FALSE if(hasArg(print.clade.size)) print.clade.size<-list(...)$print.clade.size else print.clade.size<-FALSE if(hasArg(fixed.n1)) fixed.n1<-list(...)$fixed.n1 else fixed.n1<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(fixed.height||print.clade.size){ obj<-x for(i in 1:Ntip(obj)){ if(print.clade.size){ obj$tip.clade[[i]]$label<-if(x$tip.clade[[i]]$N>1||fixed.n1) paste(x$tip.clade[[i]]$label," (n=", x$tip.clade[[i]]$N,")",sep="") else x$tip.clade[[i]]$label ii<-which(names(col)==x$tip.clade[[i]]$label) names(col)[ii]<-obj$tip.clade[[i]]$label } if(fixed.height) obj$tip.clade[[i]]$N<-if(x$tip.clade[[i]]$N>1||fixed.n1) sum(sapply(x$tip.clade,function(y) y$N))/Ntip(x) else 1 } x<-obj } x<-scaleN(x,vscale) tt<-backbone.toPhylo(x) n<-sum(sapply(x$tip.clade,function(x) x$N)) cw<-reorder.backbonePhylo(x,"cladewise") y<-vector(length=length(cw$tip.clade)+cw$Nnode) ii<-order(cw$edge[,2][cw$edge[,2]<=Ntip(cw)]) z<-c(0,cumsum(sapply(cw$tip.clade[order(ii)],function(x) x$N))) nn<-sapply(2:length(z),function(i,x) (x[i]-x[i-1])/2+x[i-1],x=z) y[cw$edge[cw$edge[,2]<=length(cw$tip.clade),2]]<-nn[1:length(cw$tip.clade)] pw<-reorder.backbonePhylo(x,"pruningwise") nn<-unique(pw$edge[,1]) for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } # compute start & end points of each edge X<-nodeHeights(tt) # open & size a new plot plot.new() par(mar=rep(0.1,4)) pp<-par("pin")[1] sw<-par("cex")*(max(strwidth(sapply(cw$tip.clade,function(x) x$label), units="inches")))+1.37*par("cex")*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp, interval=c(0,1e6))$minimum if(is.null(xlim)) xlim<-c(min(X),max(X)+sw/alp) if(is.null(ylim)) ylim<-c(0,n) plot.window(xlim=xlim,ylim=ylim) # plot horizontal edges for(i in 1:nrow(X)){ if(cw$edge[i,2]>length(cw$tip.clade)) lines(X[i,],rep(y[cw$edge[i,2]],2), lwd=lwd,lend=2) else lines(c(X[i,1],X[i,2]-cw$tip.clade[[cw$edge[i,2]]]$depth), rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2) } # plot vertical relationships for(i in 1:x$Nnode+length(x$tip.clade)) lines(X[which(cw$edge[,1]==i),1], range(y[cw$edge[which(cw$edge[,1]==i),2]]),lwd=lwd,lend=2) for(i in 1:length(x$tip.clade)){ if(x$tip.clade[[i]]$N==1){ tmp<-sep sep<-1 } else tmp<-sep xx<-c(X[which(cw$edge[,2]==i),2]-cw$tip.clade[[i]]$depth, X[which(cw$edge[,2]==i),2],X[which(cw$edge[,2]==i),2]) yy<-c(y[cw$edge[which(cw$edge[,2]==i),2]], y[cw$edge[which(cw$edge[,2]==i),2]]+cw$tip.clade[[i]]$N/2- sep/2,y[cw$edge[which(cw$edge[,2]==i),2]]- cw$tip.clade[[i]]$N/2+sep/2) if(yy[2]j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(show.zeros||Q[i,j]>tol){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+1.5*shift.x, mean(c(s[2],e[2]))+1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ 1.5*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ 1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent("black",0.7)) } ## S3 plot method for objects resulting from fitDiscrete plot.gfit<-function(x,...){ if("mkn"%in%class(x$lik)==FALSE){ stop("Sorry. No plot method presently available for objects of this type.") } else { obj<-list() QQ<-.Qmatrix.from.gfit(x) obj$states<-colnames(QQ) m<-length(obj$states) obj$index.matrix<-matrix(NA,m,m) k<-m*(m-1) obj$index.matrix[col(obj$index.matrix)!=row(obj$index.matrix)]<-1:k obj$rates<-QQ[sapply(1:k,function(x,y) which(x==y),obj$index.matrix)] class(obj)<-"fitMk" plot(obj,...) } } phytools/R/read.newick.R0000644000176200001440000000707113123275047014662 0ustar liggesusers## function to read a Newick string with node labels & (possible) singles ## written by Liam J. Revell 2013, 2014, 2015, 2017 read.newick<-function(file="",text,...){ # check to see if reading from file if(file!="") text<-scan(file,sep="\n",what="character",...) if(length(text)>1){ tree<-lapply(text,newick) class(tree)<-"multiPhylo" } else tree<-newick(text) return(tree) } # main Newick string function # written by Liam J. Revell 2013, 2014 newick<-function(text){ text<-unlist(strsplit(text, NULL)) tip.label<-vector(mode="character") node.label<-vector(mode="character") edge<-matrix(NA,sum(text=="(")+sum(text==","),2) ei<-vector() edge.length<-vector() currnode<-1 Nnode<-currnode i<-j<-k<-1 while(text[i]!=";"){ if(text[i]=="("){ edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to new internal node ei[currnode]<-j } j<-j+1 } else if(text[i]==")"){ i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) node.label[currnode]<-temp$label i<-temp$end } else node.label[currnode]<-NA ii<-ei[currnode] # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) if(currnode>1) edge.length[ii]<-temp$edge.length else root.edge<-temp$edge.length i<-temp$end } if(currnode>1) currnode<-edge[ii,1] # move down the tree ` } else if(text[i]==","){ edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to internal node ei[currnode]<-j } j<-j+1 } } Ntip<-k-1 edge<-edge[!is.na(edge[,2]),,drop=F] edge[edge>0]<-edge[edge>0]+Ntip edge[edge<0]<--edge[edge<0] edge.length[is.na(edge.length)]<-0 if(length(edge.length)==0) edge.length<-NULL if(all(is.na(node.label))) node.label<-NULL else node.label[is.na(node.label)]<-"" # assemble into "phylo" object tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label, edge.length=edge.length,node.label=node.label) class(tree)<-"phylo" attr(tree,"order")<-"cladewise" tree } # function gets label # written by Liam J. Revell 2011-2013, 2014 getLabel<-function(text,start,stop.char=c(",",":",")",";")){ i<-0 while(is.na(match(text[i+start],stop.char))) i<-i+1 label<-paste(text[0:(i-1)+start],collapse="") return(list(label=paste(label,collapse=""),end=i+start)) } # function gets branch length # written by Liam J. Revell 2011-2013, 2014 getEdgeLength<-function(text,start){ i<-start+1 stop.char<-c(",",")",";") while(is.na(match(text[i],stop.char))) i<-i+1 edge.length<-as.numeric(paste(text[(start+1):(i-1)],collapse="")) return(list(edge.length=edge.length,end=i)) } phytools/R/ls.consensus.R0000644000176200001440000001054212727621740015126 0ustar liggesusersls.consensus<-function(trees,start=NULL,tol=1e-12,quiet=FALSE,...){ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t], t=trees[[1]]$tip.label))/length(trees) if(is.null(start)) start<-NJ(D) if(hasArg(ultrametric)) ultrametric<-list(...)$ultrametric ## should the consensus tree be ultrametric else ultrametric<-all(sapply(trees,is.ultrametric)) if(ultrametric&&!is.rooted(start)) start<-midpoint(start) curr<-nnls.tree(D,tree=start,rooted=ultrametric,trace=0) if(hasArg(optNNI)) optNNI<-list(...)$optNNI else optNNI<-TRUE if(optNNI){ Q<-Inf Qp<-attr(curr,"RSS") if(is.null(Qp)) Qp<-rss(D,curr) ct<-0 while((Q-Qp)>tol){ Q<-Qp NNIs<-.uncompressTipLabel(nni(curr)) curr<-list(curr) class(curr)<-"multiPhylo" NNIs<-c(NNIs,curr) NNIs<-lapply(NNIs,nnls.tree,dm=D,rooted=ultrametric,trace=0) qs<-sapply(NNIs,rss,D=D) ii<-which(qs==min(qs))[1] if(!quiet) message(paste("Best Q =",qs[ii])) Qp<-qs[ii] curr<-NNIs[[ii]] ct<-ct+1 } if(!quiet) message(paste("Solution found after",ct, "set of nearest neighbor interchanges.")) } else if(!quiet) message(paste("No optimization of topology performed.", "Returning start tree with LS edge lengths.")) curr } rss<-function(D,tree){ Dp<-cophenetic(tree)[rownames(D),colnames(D)] sum((D-Dp)^2)/2 } minTreeDist<-function(tree,trees,method="quadratic.path.difference",...){ if(is.null(tree$edge.length)) tree$edge.length<-runif(n=nrow(tree$edge)) e<-tree$edge.length fn<-function(e,tree,trees,m){ tree$edge.length<-e if(method=="quadratic.path.difference") d<-qpd(tree,trees) else d<-sapply(trees,function(x,y) treedist(x,y)[m], y=tree) sum(d^2) } fit<-optim(e,fn,tree=tree,trees=trees,m=method,lower=0, method="L-BFGS-B",...) tree$edge.length<-fit$par attr(tree,"SQD")<-fit$value tree } averageTree<-function(trees,start=NULL,method="quadratic.path.difference", tol=1e-12,quiet=FALSE,...){ if(!quiet) message(paste( "\n Function is attempting to find the phylogeny with ", "\n minimum distance to all trees in set under the ", "\n \"", paste(strsplit(method,"[.]")[[1]],collapse=" "), "\" criterion...\n",sep="")) if(is.null(start)){ if(method%in%c("symmetric.difference","path.difference")) start<-multi2di(consensus(trees,p=0.5)) else start<-ls.consensus(trees,quiet=TRUE) } if(method%in%c("branch.score.difference","quadratic.path.difference")){ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t], t=trees[[1]]$tip.label))/length(trees) rt<-all(sapply(trees,is.ultrametric)) } else if(method%in%c("symmetric.difference","path.difference")){ rt<-all(sapply(trees,is.rooted)) if(!rt) start<-unroot(start) } curr<-start SS<-Inf SSp<-sum(sapply(trees,function(x,y,m) treedist(x,y)[m], y=curr,m=method)^2) ct<-0 while((SS-SSp)>tol){ SS<-SSp NNIs<-.uncompressTipLabel(nni(curr)) curr<-list(curr) class(curr)<-"multiPhylo" NNIs<-c(NNIs,curr) if(method=="symmetric.difference") SSp<-colSums(sapply(NNIs,RF.dist,tree2=trees)^2) else if(method=="path.difference") SSp<-colSums(sapply(NNIs,function(x,y,m) sapply(y, function(y,x,m) setNames(treedist(y,x)[m],NULL), y=x,m=m),y=trees,m=method)^2) else { if(!rt) NNIs<-lapply(NNIs,unroot) NNIs<-lapply(NNIs,nnls.tree,dm=D,rooted=rt,trace=0) NNIs<-lapply(NNIs,minTreeDist,trees=trees,method=method, ...) SSp<-sapply(NNIs,function(x) attr(x,"SQD")) } ii<-which(SSp==min(SSp))[1] if(!quiet) message(paste(" Best SS so far =",SSp[ii])) SSp<-SSp[ii] curr<-NNIs[[ii]] ct<-ct+1 } if(!quiet) message(paste("\n Solution found after",ct, "set of nearest neighbor interchanges.\n")) curr } qpd<-function(t1,t2){ if(inherits(t1,"phylo")) t1<-list(t1) if(inherits(t2,"phylo")) t2<-list(t2) tips<-t1[[1]]$tip.label P1<-lapply(t1,function(x) cophenetic(x)[tips,tips]) P2<-lapply(t2,function(x) cophenetic(x)[tips,tips]) foo<-function(x,y) sqrt(sum((x-y)^2/2)) sapply(P2,function(x,y) sapply(y,foo,y=x),y=P1) } TREEDIST<-function(t1,t2,method){ obj<-if(method=="symmetric.difference") RF.dist(t1,t2) else if(method=="path.difference") path.dist(t1,t2) else if(method=="weighted.path.difference") path.dist(t1,t2,use.weight=TRUE) else if(method=="branch.score.difference") KF.dist(t1,t2) obj }phytools/R/paintSubTree.R0000644000176200001440000000636312564235740015104 0ustar liggesusers## paint branch(es) ## written by Liam J. Revell 2014, 2015 paintBranches<-function(tree,edge,state,anc.state="1"){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$maps)) maps<-lapply(tree$edge.length,function(x) setNames(x,anc.state)) else maps<-tree$maps ii<-sapply(edge,function(x,y) which(y==x),y=tree$edge[,2]) for(i in 1:length(ii)) maps[[ii[i]]]<-setNames(tree$edge.length[[ii[i]]],state) ## build mapped.edge matrix s<-vector() for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]])) s<-unique(s) mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s)) for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] ## add attributes to the tree tree$mapped.edge<-mapped.edge tree$maps<-maps class(tree)<-c("simmap",setdiff(class(tree),"simmap")) tree } # function paints a subtree # written by Liam Revell 2012, 2013, 2015 paintSubTree<-function(tree,node,state,anc.state="1",stem=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(stem==0&&node<=length(tree$tip)) stop("stem must be TRUE for node<=N") if(is.null(tree$edge.length)) tree<-compute.brlen(tree) if(is.null(tree$maps)){ maps<-as.list(tree$edge.length) for(i in 1:length(maps)) names(maps[[i]])<-anc.state } else maps<-tree$maps if(node>length(tree$tip)){ desc<-getDescendants(tree,node) z<-which(tree$edge[,2]%in%desc) for(i in 1:length(z)){ maps[[z[i]]]<-sum(maps[[z[i]]]) names(maps[[z[i]]])<-state } if(stem){ a<-which(tree$edge[,2]==node) b<-bySegments(maps[[a]])/max(bySegments(maps[[a]])) c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2])) d<-names(maps[[a]])[1:c] e<-maps[[a]] if(c>1){ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e)) names(maps[[a]])<-c(d,state) } else { maps[[a]]<-c((1-stem)*sum(e),stem*sum(e)) names(maps[[a]])<-c(d,state) } } } else { a<-which(tree$edge[,2]==node) b<-bySegments(maps[[a]])/max(bySegments(maps[[a]])) c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2])) d<-names(maps[[a]])[1:c] e<-maps[[a]] if(c>1){ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e)) names(maps[[a]])<-c(d,state) } else { maps[[a]]<-c((1-stem)*sum(e),stem*sum(e)) names(maps[[a]])<-c(d,state) } } s<-vector() for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]])) s<-unique(s) mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s)) for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] tree$mapped.edge<-mapped.edge tree$maps<-maps class(tree)<-c("simmap",setdiff(class(tree),"simmap")) return(tree) } # function # written by Liam Revell 2012 bySegments<-function(z){ XX<-matrix(0,length(z),2,dimnames=list(names(z),c("start","end"))) XX[1,2]<-z[1] if(length(z)>1){ for(j in 2:length(z)){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+z[j] } } return(XX) } phytools/R/contMap.R0000644000176200001440000001647513105347341014076 0ustar liggesusers## function plots reconstructed values for ancestral characters along the edges of the tree ## written by Liam J. Revell 2012-2017 contMap<-function(tree,x,res=100,fsize=NULL,ftype=NULL,lwd=4,legend=NULL, lims=NULL,outline=TRUE,sig=3,type="phylogram",direction="rightwards", plot=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(method)) method<-list(...)$method else method<-"fastAnc" if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-"trait value" h<-max(nodeHeights(tree)) steps<-0:res/res*max(h) H<-nodeHeights(tree) if(method=="fastAnc") a<-fastAnc(tree,x) else if(method=="anc.ML") { fit<-anc.ML(tree,x) a<-fit$ace if(!is.null(fit$missing.x)) x<-c(x,fit$missing.x) } else if(method=="user"){ if(hasArg(anc.states)) anc.states<-list(...)$anc.states else { cat("No ancestral states have been provided. Using states estimated with fastAnc.\n\n") a<-fastAnc(tree,x) } if(length(anc.states)H[i,1]),which(stepsH[i,1]),which(steps=trans[length(trans)]) state<-names(trans)[length(trans)] else { i<-1 while(x>trans[i]){ state<-names(trans)[i] i<-i+1 } } state } ## S3 print method for objects of class "contMap" ## uses print.densityMap internally ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016 plot.contMap<-function(x,...){ if(inherits(x,"contMap")){ lims<-x$lims x<-list(tree=x$tree,cols=x$cols) class(x)<-"densityMap" } else stop("x should be an object of class \"contMap\"") H<-nodeHeights(x$tree) # get & set optional arguments if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-TRUE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-4 if(hasArg(sig)) sig<-list(...)$sig else sig<-3 if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(is.null(legend)) legend<-0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-"trait value" # done optional arguments leg.txt<-c(round(lims[1],sig),leg.txt,round(lims[2],sig)) plot(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,leg.txt=leg.txt, type=type,mar=mar,direction=direction,offset=offset,xlim=xlim,ylim=ylim,hold=hold) } ## S3 print method for object of class 'contMap' ## written by Liam J. Revell 2013 print.contMap<-function(x,digits=6,...){ cat("Object of class \"contMap\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep="")) cat(paste("(2) A mapped continuous trait on the range (",round(x$lims[1],digits),", ",round(x$lims[2],digits),").\n\n",sep="")) } ## drop tips from an object of class 'contMap' ## written by Liam J. Revell 2014 drop.tip.contMap<-function(x,tip){ if(!inherits(x,"contMap")) cat("x should be an object of class \"contMap\"\n") else { x$tree<-drop.tip.simmap(x$tree,tip) return(x) } } ## add error bars to contMap plot ## written by Liam J. Revell 2017 errorbar.contMap<-function(obj,...){ if(hasArg(x)) x<-list(...)$x else x<-setNames(sapply(1:Ntip(obj$tree),function(x,obj){ ii<-which(obj$tree$edge[,2]==x) ss<-names(obj$tree$maps[[ii]][length(obj$tree$maps[[ii]])]) obj$lims[1]+as.numeric(ss)/(length(obj$cols)-1)*diff(obj$lims) },obj=obj),obj$tree$tip.label) if(hasArg(scale.by.ci)) scale.by.ci<-list(...)$scale.by.ci else scale.by.ci<-TRUE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-14 tree<-obj$tree aa<-fastAnc(tree,x,CI=TRUE) xlim<-range(aa$CI95) if(xlim[2]>obj$lims[2]||xlim[1]0) cbind(assoc,assoc) else NULL if(is.null(assoc)){ cat("No associations provided or found.\n") rotate<-FALSE } } ## check to verify that all taxa in assoc are in tree ii<-sapply(assoc[,1],"%in%",tr1$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,1] not in tr1. Removing species & links.\n") } ii<-sapply(assoc[,2],"%in%",tr2$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,2] not in tr2. Removing species & links.\n") } ## now check if rotation is to be performed if(rotate){ cat("Rotating nodes to optimize matching...\n") flush.console() if("exhaustive"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) M1<-M2<-matrix(NA,length(tt1),length(tt2)) for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) M1[i,j]<-attr(tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),"minRotate") M2[i,j]<-attr(tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute"),"minRotate") } } MM<-M1+M2 ij<-which(MM==min(MM),arr.ind=TRUE) obj<-list() for(i in 1:nrow(ij)){ tr1<-tt1[[ij[i,1]]] attr(tr1,"minRotate")<-M1[ij[i,1],ij[i,2]] tr2<-tt2[[ij[i,2]]] attr(tr2,"minRotate")<-M2[ij[i,1],ij[i,2]] tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj[[i]]<-list(trees=tt,assoc=assoc) class(obj[[i]])<-"cophylo" } if(length(obj)>1) class(obj)<-"multiCophylo" else obj<-obj[[1]] } else if ("all"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) obj<-vector(mode="list",length=length(tt1)*length(tt2)) ij<-1 for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) obj[[ij]]<-list(trees=c( tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"), tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute")), assoc=assoc) class(obj[[ij]])<-"cophylo" ij<-ij+1 } } class(obj)<-"multiCophylo" } else { x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) best.tr1<-Inf x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) best.tr2<-Inf while((best.tr2-attr(tr2,"minRotate"))>0||(best.tr1-attr(tr1,"minRotate"))>0){ best.tr1<-attr(tr1,"minRotate") best.tr2<-attr(tr2,"minRotate") x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) } tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } cat("Done.\n") } else { tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } obj } ## called internally by plot.cophylo to plot a phylogram ## written by Liam J. Revell phylogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){ if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-rep("black",nrow(tree$edge)) d<-if(direction=="rightwards") 1 else -1 ## sub "_" for " " tree$tip.label<-gsub("_"," ",tree$tip.label) ## check if edge lenths if(is.null(tree$edge.length)) tree<-compute.brlen(tree) ## rescale tree so it fits in one half of the plot ## with enough space for labels if(ftype=="off") fsize<-0 sh<-fsize*strwidth(tree$tip.label) tree$edge.length<-tree$edge.length/max(nodeHeights(tree))*(part-max(sh)) n<-Ntip(tree) ## reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1) ## reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) ## compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } ## compute start & end points of each edge X<-nodeHeights(cw)-0.5 ## plot horizontal edges for(i in 1:nrow(X)) lines(d*X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2, col=edge.col[i]) ## plot vertical relationships for(i in 1:tree$Nnode+n){ ee<-which(cw$edge[,1]==i) p<-if(i%in%cw$edge[,2]) which(cw$edge[,2]==i) else NULL if(!is.null(p)){ xx<-c(X[ee,1],X[p,2]) yy<-sort(c(y[cw$edge[ee,2]],y[cw$edge[p,2]])) } else { xx<-c(X[ee,1],X[ee[1],1]) yy<-sort(c(y[cw$edge[ee,2]],mean(y[cw$edge[ee,2]]))) } segments(x0=d*xx[1:(length(xx)-1)],y0=yy[1:(length(yy)-1)], x1=d*xx[2:length(xx)],y1=yy[2:length(yy)],lwd=lwd,lend=2,col=edge.col[ee]) } ## plot links to tips h<-max(X)+0.1*(max(X)-min(X))+max(fsize*strwidth(tree$tip.label))- fsize*strwidth(tree$tip.label) for(i in 1:n){ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]),rep(y[i],2),lwd=1,lty="dotted") if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd)) } ## plot tip labels font<-which(c("off","reg","b","i","bi")==ftype)-1 if(font>0){ for(i in 1:n) text(d*max(h+fsize*strwidth(tree$tip.label)),y[i], tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0, cex=fsize,font=font) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) ## return rightmost or leftmost edge of tip labels invisible(d*max(h+fsize*strwidth(tree$tip.label))) } ## plot links between tip taxa according to assoc ## written by Liam J. Revell 2015, 2016 makelinks<-function(obj,x,link.type="curved",link.lwd=1,link.col="black", link.lty="dashed"){ if(length(link.lwd)==1) link.lwd<-rep(link.lwd,nrow(obj$assoc)) if(length(link.col)==1) link.col<-rep(link.col,nrow(obj$assoc)) if(length(link.lty)==1) link.lty<-rep(link.lty,nrow(obj$assoc)) for(i in 1:nrow(obj$assoc)){ ii<-which(obj$trees[[1]]$tip.label==obj$assoc[i,1]) jj<-which(obj$trees[[2]]$tip.label==obj$assoc[i,2]) y<-c((ii-1)/(Ntip(obj$trees[[1]])-1),(jj-1)/(Ntip(obj$trees[[2]])-1)) if(link.type=="straight") lines(x,y,lty=link.lty[i], lwd=link.lwd[i],col=link.col[i]) else if(link.type=="curved") drawCurve(x,y,lty=link.lty[i], lwd=link.lwd[i],col=link.col[i]) } } ## plot method for class "multiCophylo" plot.multiCophylo<-function(x,...){ par(ask=TRUE) for(i in 1:length(x)) plot.cophylo(x[[i]],...) } ## plot an object of class "cophylo" ## written by Liam J. Revell 2015, 2016, 2017 plot.cophylo<-function(x,...){ plot.new() if(hasArg(mar)) mar<-list(...)$mar else mar<-c(0.1,0.1,0.1,0.1) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.5) if(hasArg(scale.bar)) scale.bar<-list(...)$scale.bar else scale.bar<-rep(0,2) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-if(any(scale.bar>0)) c(-0.1,1) else c(0,1) if(hasArg(link.type)) link.type<-list(...)$link.type else link.type<-"straight" if(hasArg(link.lwd)) link.lwd<-list(...)$link.lwd else link.lwd<-1 if(hasArg(link.col)) link.col<-list(...)$link.col else link.col<-"black" if(hasArg(link.lty)) link.lty<-list(...)$link.lty else link.lty<-"dashed" if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-list( left=rep("black",nrow(x$trees[[1]]$edge)), right=rep("black",nrow(x$trees[[2]]$edge))) obj<-list(...) par(mar=mar) plot.window(xlim=xlim,ylim=ylim) leftArgs<-rightArgs<-obj leftArgs$edge.col<-edge.col$left rightArgs$edge.col<-edge.col$right if(!is.null(obj$fsize)){ if(length(obj$fsize)>1){ leftArgs$fsize<-obj$fsize[1] rightArgs$fsize<-obj$fsize[2] sb.fsize<- if(length(obj$fsize)>2) obj$fsize[3] else 1 } else sb.fsize<-1 } else sb.fsize<-1 x1<-do.call("phylogram",c(list(tree=x$trees[[1]],part=0.4),leftArgs)) left<-get("last_plot.phylo",envir=.PlotPhyloEnv) x2<-do.call("phylogram",c(list(tree=x$trees[[2]],part=0.4, direction="leftwards"),rightArgs)) right<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!is.null(x$assoc)) makelinks(x,c(x1,x2),link.type,link.lwd,link.col, link.lty) else cat("No associations provided.\n") if(any(scale.bar>0)) add.scalebar(x,scale.bar,sb.fsize) assign("last_plot.cophylo",list(left=left,right=right),envir=.PlotPhyloEnv) } ## add scale bar ## written by Liam J. Revell 2015 add.scalebar<-function(obj,scale.bar,fsize){ if(scale.bar[1]>0){ s1<-(0.4-max(fsize*strwidth(obj$trees[[1]]$tip.label)))/max(nodeHeights(obj$trees[[1]])) lines(c(-0.5,-0.5+scale.bar[1]*s1),rep(-0.05,2)) lines(rep(-0.5,2),c(-0.05,-0.06)) lines(rep(-0.5+scale.bar[1]*s1,2),c(-0.05,-0.06)) text(mean(c(-0.5,-0.5+scale.bar[1]*s1)),rep(-0.05,2),scale.bar[1],pos=1) } if(scale.bar[2]>0){ s2<-(0.4-max(fsize*strwidth(obj$trees[[2]]$tip.label)))/max(nodeHeights(obj$trees[[2]])) lines(c(0.5-scale.bar[2]*s2,0.5),rep(-0.05,2)) lines(rep(0.5-scale.bar[2]*s2,2),c(-0.05,-0.06)) lines(rep(0.5,2),c(-0.05,-0.06)) text(mean(c(0.5-scale.bar[2]*s2,0.5)),rep(-0.05,2),scale.bar[2],pos=1) } } ## print an object of class "cophylo" ## written by Liam J. Revell 2015 print.cophylo<-function(x, ...){ cat("Object of class \"cophylo\" containing:\n\n") cat("(1) 2 (possibly rotated) phylogenetic trees in an object of class \"multiPhylo\".\n\n") cat("(2) A table of associations between the tips of both trees.\n\n") } ## print method for "multiCophylo" object print.multiCophylo<-function(x, ...) cat("Object of class \"multiCophylo\" containg",length(x),"objects of class \"cophylo\".\n\n") ## written by Liam J. Revell 2015, 2016 tipRotate<-function(tree,x,...){ if(hasArg(fn)) fn<-list(...)$fn else fn<-function(x) x^2 if(hasArg(methods)) methods<-list(...)$methods else methods<-"pre" if("exhaustive"%in%methods) methods<-"exhaustive" if(hasArg(print)) print<-list(...)$print else print<-FALSE if(hasArg(max.exhaustive)) max.exhaustive<-list(...)$max.exhaustive else max.exhaustive<-20 if(hasArg(rotate.multi)) rotate.multi<-list(...)$rotate.multi else rotate.multi<-FALSE if(rotate.multi) rotate.multi<-!is.binary.tree(tree) if(hasArg(anim.cophylo)) anim.cophylo<-list(...)$anim.cophylo else anim.cophylo<-FALSE if(anim.cophylo){ if(hasArg(left)) left<-list(...)$left else left<-NULL if(hasArg(right)) right<-list(...)$right else right<-NULL if(hasArg(assoc)) assoc<-list(...)$assoc else assoc<-NULL if(is.null(left)&&is.null(right)) anim.cophylo<-FALSE if(hasArg(only.accepted)) only.accepted<-list(...)$only.accepted else only.accepted<-TRUE } tree<-reorder(tree) nn<-1:tree$Nnode+length(tree$tip.label) if("just.compute"%in%methods){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) oo<-pp<-foo(tree,x) } if("exhaustive"%in%methods){ if(Ntip(tree)>max.exhaustive){ cat(paste("\nmethods=\"exhaustive\" not permitted for more than", max.exhaustive,"tips.\n", "If you are sure you want to run an exhaustive search for a tree of this size\n", "increasing argument max.exhaustive & re-run.\n", "Setting methods to \"pre\".\n\n")) methods<-"pre" } else { cat("Running exhaustive search. May be slow!\n") oo<-Inf tt<-allRotations(tree) foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(print) message(paste("objective:",pp)) tree<-tt } ANIM.COPHYLO<-function(tree){ dev.hold() if(is.null(left)) plot(cophylo(tree,right,assoc=assoc,rotate=FALSE),...) else if(is.null(right)) plot(cophylo(left,tree,assoc=assoc,rotate=FALSE),...) nodelabels.cophylo(node=i+Ntip(tree),pie=1,col="red",cex=0.4, which=if(is.null(left)) "left" else "right") dev.flush() } if("pre"%in%methods){ for(i in 1:tree$Nnode){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } if("post"%in%methods){ for(i in tree$Nnode:1){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } attr(tree,"minRotate")<-min(oo,pp) if(anim.cophylo) ANIM.COPHYLO(tree) tree } ## multi2di for "multiPhylo" object MULTI2DI<-function(x){ obj<-lapply(x,multi2di) class(obj)<-"multiPhylo" obj } ## labeling methods for plotted "cophylo" object ## written by Liam J. Revell 2015 nodelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) nodelabels(...) } edgelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) edgelabels(...) } tiplabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) tiplabels(...) } ## function to draw sigmoidal links ## modified from https://stackoverflow.com/questions/32046889/connecting-two-points-with-curved-lines-s-ish-curve-in-r drawCurve<-function(x,y,scale=0.01,...){ x1<-x[1] x2<-x[2] y1<-y[1] y2<-y[2] curve(plogis(x,scale=scale,location=(x1+x2)/2)*(y2-y1)+y1, x1,x2,add=TRUE,...) } ## S3 summary method ## written by Liam J. Revell 2016 summary.cophylo<-function(object,...){ cat("\nCo-phylogenetic (\"cophylo\") object:",deparse(substitute(object)), "\n\n") cat(paste("Tree 1 (left tree) is an object of class \"phylo\" containing", Ntip(object$trees[[1]]),"species.\n\n")) cat(paste("Tree 2 (right tree) is an object of class \"phylo\" containing", Ntip(object$trees[[2]]),"species.\n\n")) cat("Association (assoc) table as follows:\n\n") maxl<-max(sapply(strsplit(object$assoc[,1],""),length)) cat(paste("\tleft:",paste(rep(" ",maxl-5),collapse=""), "\t----\tright:\n",sep="")) nulo<-apply(object$assoc,1,function(x,maxl) cat(paste("\t",x[1], paste(rep(" ",maxl-length(strsplit(x[1],split="")[[1]])), collapse=""),"\t----\t",x[2],"\n",sep="")),maxl=maxl) cat("\n") } phytools/R/plotBranchbyTrait.R0000644000176200001440000001441113022022441016101 0ustar liggesusers## function to plot probability or trait value by branch ## written by Liam J. Revell 2013, 2014, 2016 plotBranchbyTrait<-function(tree,x,mode=c("edges","tips","nodes"),palette="rainbow",legend=TRUE,xlims=NULL,...){ mode<-mode[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(mode=="tips"){ x<-c(x[tree$tip.label],fastAnc(tree,x)) names(x)[1:length(tree$tip.label)]<-1:length(tree$tip.label) XX<-matrix(x[tree$edge],nrow(tree$edge),2) x<-rowMeans(XX) } else if(mode=="nodes"){ XX<-matrix(x[tree$edge],nrow(tree$edge),2) x<-rowMeans(XX) } # begin optional arguments if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(hasArg(prompt)) prompt<-list(...)$prompt else prompt<-FALSE if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(show.tip.label)) show.tip.label<-list(...)$show.tip.label else show.tip.label<-TRUE if(hasArg(show.node.label)) show.node.label<-list(...)$show.node.label else show.node.label<-FALSE if(hasArg(edge.width)) edge.width<-list(...)$edge.width else edge.width<-4 if(hasArg(edge.lty)) edge.lty<-list(...)$edge.lty else edge.lty<-1 if(hasArg(font)) font<-list(...)$font else font<-3 if(hasArg(cex)) cex<-list(...)$cex else cex<-par("cex") if(hasArg(adj)) adj<-list(...)$adj else adj<-NULL if(hasArg(srt)) srt<-list(...)$srt else srt<-0 if(hasArg(no.margin)) no.margin<-list(...)$no.margin else no.margin<-TRUE if(hasArg(root.edge)) root.edge<-list(...)$root.edge else root.edge<-FALSE if(hasArg(label.offset)) label.offset<-list(...)$label.offset else label.offset<-0.01*max(nodeHeights(tree)) if(hasArg(underscore)) underscore<-list(...)$underscore else underscore<-FALSE if(hasArg(x.lim)) x.lim<-list(...)$x.lim else x.lim<-NULL if(hasArg(y.lim)) y.lim<-list(...)$y.lim else y.lim<-if(legend&&!prompt&&type%in%c("phylogram","cladogram")) c(1-0.06*length(tree$tip.label),length(tree$tip.label)) else NULL if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(lab4ut)) lab4ut<-list(...)$lab4ut else lab4ut<-NULL if(hasArg(tip.color)) tip.color<-list(...)$tip.color else tip.color<-"black" if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(rotate.tree)) rotate.tree<-list(...)$rotate.tree else rotate.tree<-0 if(hasArg(open.angle)) open.angle<-list(...)$open.angle else open.angle<-0 # end optional arguments if(is.function(palette)) cols<-palette(n=1000) else { if(palette=="heat.colors") cols<-heat.colors(n=1000) if(palette=="gray") cols<-gray(1000:1/1000) if(palette=="rainbow") cols<-rainbow(1000,start=0.7,end=0) # blue->red } if(is.null(xlims)) xlims<-range(x)+c(-tol,tol) breaks<-0:1000/1000*(xlims[2]-xlims[1])+xlims[1] whichColor<-function(p,cols,breaks){ i<-1 while(p>=breaks[i]&&p>breaks[i+1]) i<-i+1 cols[i] } colors<-sapply(x,whichColor,cols=cols,breaks=breaks) par(lend=2) # now plot xx<-plot.phylo(tree,type=type,show.tip.label=show.tip.label,show.node.label=show.node.label,edge.color=colors, edge.width=edge.width,edge.lty=edge.lty,font=font,cex=cex,adj=adj,srt=srt,no.margin=no.margin,root.edge=root.edge, label.offset=label.offset,underscore=underscore,x.lim=x.lim,y.lim=y.lim,direction=direction,lab4ut=lab4ut, tip.color=tip.color,plot=plot,rotate.tree=rotate.tree,open.angle=open.angle,lend=2,new=FALSE) if(legend==TRUE&&is.logical(legend)) legend<-round(0.3*max(nodeHeights(tree)),2) if(legend){ if(hasArg(title)) title<-list(...)$title else title<-"trait value" if(hasArg(digits)) digits<-list(...)$digits else digits<-1 if(prompt) add.color.bar(legend,cols,title,xlims,digits,prompt=TRUE) else add.color.bar(legend,cols,title,xlims,digits,prompt=FALSE,x=par()$usr[1]+0.05*(par()$usr[2]-par()$usr[1]),y=par()$usr[3]+0.05*(par()$usr[4]-par()$usr[3])) } invisible(xx) } # function to add color bar # written by Liam J. Revell 2013, 2015, 2016 add.color.bar<-function(leg,cols,title=NULL,lims=c(0,1),digits=1,prompt=TRUE,lwd=4,outline=TRUE,...){ if(prompt){ cat("Click where you want to draw the bar\n") flush.console() x<-unlist(locator(1)) y<-x[2] x<-x[1] } else { if(hasArg(x)) x<-list(...)$x else x<-0 if(hasArg(y)) y<-list(...)$y else y<-0 } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(subtitle)) subtitle<-list(...)$subtitle else subtitle<-NULL if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(direction%in%c("rightwards","leftwards")){ X<-x+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg) if(direction=="leftwards"){ X<-X[nrow(X):1,] if(!is.null(lims)) lims<-lims[2:1] } Y<-cbind(rep(y,length(cols)),rep(y,length(cols))) } else if(direction%in%c("upwards","downwards")){ Y<-y+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg) if(direction=="downwards"){ X<-X[nrow(X):1,] if(!is.null(lims)) lims<-lims[2:1] } X<-cbind(rep(x,length(cols)),rep(x,length(cols))) } if(outline) lines(c(X[1,1],X[nrow(X),2]),c(Y[1,1],Y[nrow(Y),2]),lwd=lwd+2,lend=2) for(i in 1:length(cols)) lines(X[i,],Y[i,],col=cols[i],lwd=lwd,lend=2) if(direction%in%c("rightwards","leftwards")){ if(!is.null(lims)) text(x=x,y=y, round(lims[1],digits),pos=3,cex=fsize) if(!is.null(lims)) text(x=x+leg,y=y, round(lims[2],digits),pos=3,cex=fsize) if(is.null(title)) title<-"P(state=1)" text(x=(2*x+leg)/2,y=y,title,pos=3,cex=fsize) if(is.null(subtitle)) text(x=(2*x+leg)/2,y=y,paste("length=",round(leg,3),sep=""),pos=1,cex=fsize) else text(x=(2*x+leg)/2,y=y,subtitle,pos=1,cex=fsize) } else if(direction%in%c("upwards","downwards")){ if(!is.null(lims)) text(x=x,y=y-0.02*diff(par()$usr[3:4]),round(lims[1],digits), pos=1,cex=fsize) if(!is.null(lims)) text(x=x,y=y+leg+0.02*diff(par()$usr[3:4]), round(lims[2],digits), pos=3,cex=fsize) if(is.null(title)) title<-"P(state=1)" text(x=x-0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,title, pos=3,cex=fsize,srt=90) if(is.null(subtitle)) text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2, paste("length=",round(leg,3),sep=""),pos=1, srt=90,cex=fsize) else text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2, subtitle,pos=1,cex=fsize,srt=90) } } phytools/R/sim.rates.R0000644000176200001440000000530113061416301014356 0ustar liggesusers# simulates with multiple evolutionary rates in different parts of the tree # written by Liam J. Revell 2011, 2013, 2015 sim.rates<-function(tree,sig2,anc=0,nsim=1,internal=FALSE,plot=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$mapped.edge)){ message("tree does not contain a mapped discrete character history, using fastBM") X<-fastBM(tree,a=anc,sig2=sig2[1],nsim=nsim,internal=internal) } else { # first name (if necessary) and reorder sig2 if(is.null(names(sig2))){ message("names absent from sig2: assuming same order as $mapped.edge") if(length(sig2)==ncol(tree$mapped.edge)) names(sig2)<-colnames(tree$mapped.edge) else stop("the number of elements in sig2 should match the number of rows in mapped.edge") } sig2<-sig2[colnames(tree$mapped.edge)] # now create a tree for simulation edge.length<-rep(0,nrow(tree$edge)) # scale the edge lengths by the rate for(i in 1:ncol(tree$mapped.edge)) edge.length<-edge.length+sig2[i]*tree$mapped.edge[,i] names(edge.length)<-NULL tree<-list(Nnode=tree$Nnode,edge=tree$edge,tip.label=tree$tip.label,edge.length=edge.length) class(tree)<-"phylo" if(plot) plot(tree) # simulate X<-fastBM(tree,a=anc,nsim=nsim,internal=internal) } X } ## function simulates multiple OU regimes using a difference equation approximation ## written by Liam J. Revell 2017 multiOU<-function(tree,alpha,sig2,theta=NULL,a0=NULL,nsim=1,internal=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(nsim>1) x<-replicate(nsim,multiOU(tree,alpha,sig2,theta,a0,nsim=1,internal,...)) else { rt<-Ntip(tree)+1 if(!inherits(tree,"simmap")){ tree<-paintSubTree(tree,rt,"1") names(alpha)<-names(sig2)<-"1" } if(hasArg(dt)) dt<-list(...)$dt else dt<-1/1000*max(nodeHeights(tree)) ss<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes")))) if(is.null(theta)) theta<-setNames(rep(0,length(ss)),ss) if(is.null(a0)) a0<-0 tree<-reorder(tree,"cladewise") S<-matrix(NA,nrow(tree$edge),2) S[which(tree$edge[,1]==rt),1]<-a0 for(i in 1:nrow(tree$edge)){ x1<-S[i,1] for(j in 1:length(tree$maps[[i]])){ t<-tree$maps[[i]][j] ALPHA<-alpha[names(t)] SIG2<-sig2[names(t)] THETA<-theta[names(t)] t<-c(rep(dt,floor(t/dt)),t%%dt) for(k in 1:length(t)) x1<-x1+ALPHA*(THETA-x1)*t[k]+ rnorm(n=1,sd=sqrt(SIG2*t[k])) } S[i,2]<-x1 if(any(tree$edge[,1]==tree$edge[i,2])) S[which(tree$edge[,1]==tree$edge[i,2]),1]<-S[i,2] } x<-setNames(c(S[1,1],S[,2]),c(tree$edge[1,1], tree$edge[,2]))[as.character(1:(Ntip(tree)+tree$Nnode))] names(x)[1:Ntip(tree)]<-tree$tip.label if(!internal) x<-x[tree$tip.label] } x } phytools/R/splitplotTree.R0000644000176200001440000000740312563246417015347 0ustar liggesusers## functions to split a tree into two (or more) plots by different methods ## written by Liam J. Revell 2012, 2015 plotTree.splits<-function(tree,splits=NULL,file=NULL,fn=NULL,...){ if(is.null(fn)) fn<-function(){} ef<-0.037037037037 ## expansion factor if(!is.null(file)) pdf(file,width=8.5,height=11) if(is.null(splits)) splits<-(floor(0.5*Ntip(tree))+0.5)/Ntip(tree) if(hasArg(y.lim)) y.lim<-list(...)$y.lim else y.lim<-c(0,Ntip(tree)) S<-matrix(c(0,splits,splits,1+1/Ntip(tree)),length(splits)+1,2) S<-cbind(S[,1]+ef*(S[,2]-S[,1]),S[,2]-ef*(S[,2]-S[,1])) S<-S*diff(y.lim)+y.lim[1] for(i in nrow(S):1){ if(is.null(file)&&i=s) Y1<-Y[a,]; Y2<-Y[-a,] b<-(min(Y1)-max(Y2))/2 Y1<-Y1-s+1; Y2<-Y2 H1<-H[a,]; H2<-H[-a,] edge1<-cw$edge[a,]; edge2<-cw$edge[-a,] if(length(H1)==2){ H1<-matrix(H1,1,2); Y1<-matrix(Y1,1,2); edge1<-matrix(edge1,1,2) } if(length(H2)==2){ H2<-matrix(H2,1,2); Y2<-matrix(Y2,1,2); edge2<-matrix(edge2,1,2) } # label offset offset<-0.2*lwd/3+0.2/3 # open plot par(mar=c(0.1,0.1,0.1,0.1)) if(!new.window) layout(matrix(c(1,2),1,2)) # first half plot.new(); if(fsize*max(strwidth(cw$tip.label))<1.0){ k<-(1-fsize*max(strwidth(cw$tip.label)))/max(H) H<-k*H H1<-k*H1 H2<-k*H2 } else message("Font size too large to properly rescale tree to window.") plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1-b,max(rbind(Y1,Y2)))) for(i in 1:nrow(H1)) lines(H1[i,],Y1[i,],lwd=lwd,lend=2) nodes<-unique(edge1[,1]) for(i in 1:length(nodes)) lines(H1[which(edge1[,1]==nodes[i]),1],Y1[which(edge1[,1]==nodes[i]),1],lwd=lwd) for(i in 1:nrow(edge1)) if(edge1[i,1]%in%edge2[,1]) lines(c(H1[i,1],H1[i,1]),c(Y1[i,1],1-b),lwd=lwd,lend=2) tips<-edge1[edge1[,2]<=n,2] for(i in 1:length(tips)) if(ftype) text(H1[which(edge1[,2]==tips[i]),2],Y1[which(edge1[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset) # second half if(new.window){ dev.new(); par(mar=c(0.1,0.1,0.1,0.1)) } plot.new() if(max(Y1)>max(Y2)) Y2<-Y2+max(Y1)-max(Y2) plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1,max(rbind(Y1,Y2)+b))) for(i in 1:nrow(H2)) lines(H2[i,],Y2[i,],lwd=lwd,lend=2) nodes<-unique(edge2[,1]) for(i in 1:length(nodes)) lines(H2[which(edge2[,1]==nodes[i]),1],Y2[which(edge2[,1]==nodes[i]),1],lwd=lwd) for(i in 1:nrow(edge2)) if(edge2[i,1]%in%edge1[,1]) lines(c(H2[i,1],H2[i,1]),c(Y2[i,1],max(Y2)+b),lwd=lwd,lend=2) tips<-edge2[edge2[,2]<=n,2] for(i in 1:length(tips)) if(ftype) text(H2[which(edge2[,2]==tips[i]),2],Y2[which(edge2[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset) # reset margin and layout layout(1) par(mar=c(5,4,4,2)+0.1) } phytools/R/anc.ML.R0000644000176200001440000002206513151046147013536 0ustar liggesusers## lightweight version of ace(...,method="ML") for continuous traits ## also allows missing data in x, in which case missing data are also estimated ## written by Liam J. Revell 2011, 2013, 2014, 2015 anc.ML<-function(tree,x,maxit=2000,model=c("BM","OU","EB"),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(model[1]=="BM") obj<-anc.BM(tree,x,maxit,...) else if(model[1]=="OU") obj<-anc.OU(tree,x,maxit,...) else if(model[1]=="EB") obj<-anc.EB(tree,x,maxit,...) else stop(paste("Do not recognize method",model)) obj } ## internal to estimate ancestral states under a BM model ## written by Liam J. Revell 2011, 2013, 2014, 2016 anc.BM<-function(tree,x,maxit,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(vars)) vars<-list(...)$vars else vars<-FALSE if(hasArg(CI)) CI<-list(...)$CI else CI<-FALSE ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) ## function returns the log-likelihood likelihood<-function(par,C,invC,detC,xvals,msp,trace){ sig2<-par[1] a<-par[2] y<-par[1:(tree$Nnode-1)+2] xvals<-c(xvals,setNames(par[1:length(msp)+tree$Nnode+1],msp)) xvals<-xvals[rownames(C)[1:length(tree$tip.label)]] z<-c(xvals,y)-a logLik<-(-z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2- detC/2)[1,1] if(trace) print(c(sig2,logLik)) -logLik } ## compute C C<-vcvPhylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] ## assign starting values zz<-fastAnc(tree,c(x,setNames(rep(mean(x),length(xx)),xx))) y<-zz[2:length(zz)] a<-zz[1] bb<-c(c(x,setNames(rep(mean(x),length(xx)),xx))[tree$tip.label],y) sig2<-((bb-a)%*%invC%*%(bb-a)/nrow(C))[1,1] fit<-optim(c(sig2,a,y,rep(mean(x),length(xx))),fn=likelihood,C=C,invC=invC, detC=detC,xvals=x,msp=xx,trace=trace,method="L-BFGS-B", lower=c(10*.Machine$double.eps,rep(-Inf,tree$Nnode+length(xx))), control=list(maxit=maxit)) if(vars||CI){ H<-hessian(likelihood,fit$par,C=C,invC=invC,detC=detC, xvals=x,msp=xx,trace=trace) vcv<-solve(H) } states<-fit$par[1:tree$Nnode+1] names(states)<-c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)]) obj<-list(sig2=fit$par[1],ace=states,logLik=-fit$value,counts=fit$counts, convergence=fit$convergence,message=fit$message,model="BM") if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1], c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)])) if(CI){ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+1]), obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+1])) rownames(obj$CI95)<-c(length(tree$tip)+1, rownames(C)[(length(tree$tip)+1):nrow(C)]) } if(length(xx)>0){ obj$missing.x<-setNames(fit$par[1:length(xx)+tree$Nnode+1],xx) if(vars) obj$missing.var<-setNames(diag(vcv)[1:length(xx)+ tree$Nnode+1],xx) if(CI){ obj$missing.CI95<-cbind(obj$missing.x- 1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]), obj$missing.x+1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1])) rownames(obj$missing.CI95)<-xx } } class(obj)<-"anc.ML" obj } ## internal to estimate ancestral states under an OU model (this may not work) ## written by Liam J. Revell 2014 anc.OU<-function(tree,x,maxit=2000,...){ ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(a.init)) a.init<-list(...)$a.init else a.init<-2*log(2)/max(nodeHeights(tree)) likOU<-function(par,tree,x,trace){ sig2<-par[1] alpha<-par[2] a0<-par[3] a<-par[1:(tree$Nnode-1)+3] logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),sig2*vcvPhylo(tree,model="OU",alpha=alpha)) if(trace) print(c(sig2,alpha,logLik)) -logLik } x<-x[tree$tip.label] pp<-rep(NA,tree$Nnode+2) pp[1:tree$Nnode+2]<-fastAnc(tree,x) pp[1]<-phyl.vcv(as.matrix(c(x,pp[2:tree$Nnode+2])),vcvPhylo(tree),lambda=1)$R[1,1] pp[2]<-a.init ## arbitrarily fit<-optim(pp,likOU,tree=tree,x=x,trace=trace,method="L-BFGS-B", lower=c(tol,tol,rep(-Inf,tree$Nnode)),upper=rep(Inf,length(pp)), control=list(maxit=maxit)) obj<-list(sig2=fit$par[1],alpha=fit$par[2], ace=setNames(fit$par[1:tree$Nnode+2],1:tree$Nnode+length(tree$tip.label)), logLik=-fit$value,counts=fit$counts,convergence=fit$convergence, message=fit$message,model="OU") class(obj)<-"anc.ML" obj } ## EB is the Early-burst model (Harmon et al. 2010) and also called the ACDC model ## (accelerating-decelerating; Blomberg et al. 2003). Set by the a rate parameter, EB fits a model where ## the rate of evolution increases or decreases exponentially through time, under the model ## r[t] = r[0] * exp(a * t), where r[0] is the initial rate, a is the rate change parameter, and t is ## time. The maximum bound is set to -0.000001, representing a decelerating rate of evolution. The minimum ## bound is set to log(10^-5)/depth of the tree. ## internal to estimate ancestral states under an EB model ## written by Liam J. Revell 2017 anc.EB<-function(tree,x,maxit=2000,...){ ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(vars)) vars<-list(...)$vars else vars<-FALSE if(hasArg(CI)) CI<-list(...)$CI else CI<-FALSE if(hasArg(r.init)){ r.init<-list(...)$r.init obj<-phyl.vcv(as.matrix(x[tree$tip.label]), vcv(ebTree(tree,r.init)),1) s2.init<-obj$R[1,1] a0.init<-obj$alpha[1,1] } else { ## optimize r.init lik<-function(p,tree,x) logLik<--logMNORM(x,rep(p[3],Ntip(tree)), p[1]*vcvPhylo(tree,model="EB",r=p[2],anc.nodes=F)) obj<-phyl.vcv(as.matrix(x[tree$tip.label]),vcv(tree),1) fit.init<-optim(c(obj$R[1,1],0,obj$alpha[1,1]), lik,tree=tree,x=x,method="L-BFGS-B",lower=c(tol,-Inf,-Inf), upper=rep(Inf,3)) r.init<-fit.init$par[2] s2.init<-fit.init$par[1] a0.init<-fit.init$par[3] } likEB<-function(par,tree,x,trace){ sig2<-par[1] r<-par[2] obj<-fastAnc(ebTree(tree,r),x) a0<-obj[1] a<-obj[2:length(obj)] logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1), sig2*vcvPhylo(tree,model="EB",r=r)) if(trace) print(c(sig2,r,logLik)) -logLik } x<-x[tree$tip.label] pp<-rep(NA,2) pp[1]<-s2.init pp[2]<-r.init fit<-optim(pp,likEB,tree=tree,x=x,trace=trace,method="L-BFGS-B", lower=c(tol,-Inf),upper=rep(Inf,2),control=list(maxit=maxit)) obj<-list(sig2=fit$par[1],r=fit$par[2], ace=unclass(fastAnc(ebTree(tree,fit$par[2]),x)), logLik=-fit$value,counts=fit$counts,convergence=fit$convergence, message=fit$message,model="EB") if(vars||CI){ likEB.hessian<-function(par,tree,y){ sig2<-par[1] r<-par[2] a<-par[3:length(par)] logLik<-logMNORM(c(y,a[2:length(a)]),rep(a[1],Ntip(tree)+tree$Nnode-1), sig2*vcvPhylo(tree,model="EB",r=r)) -logLik } H<-hessian(likEB.hessian,c(fit$par,obj$ace),tree=tree,y=x) vcv<-solve(H) if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],1:tree$Nnode+Ntip(tree)) if(CI){ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+2]), obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+2])) rownames(obj$CI95)<-1:tree$Nnode+Ntip(tree) } } class(obj)<-"anc.ML" obj } logMNORM<-function(x,x0,vcv) -t(x-x0)%*%solve(vcv)%*%(x-x0)/2-length(x)*log(2*pi)/2-determinant(vcv,logarithm=TRUE)$modulus[1]/2 ## print method for "anc.ML" ## written by Liam J. Revell 2015, 2016 print.anc.ML<-function(x,digits=6,printlen=NULL,...){ cat(paste("Ancestral character estimates using anc.ML under a(n)", x$model,"model:\n")) Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) if(!is.null(x$var)){ cat("\nVariances on ancestral states:\n") if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits)) else printDotDot(x$var,digits,printlen) } if(!is.null(x$CI95)){ cat("\nLower & upper 95% CIs:\n") colnames(x$CI95)<-c("lower","upper") if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits)) else printDotDot(x$CI95,digits,printlen) } cat("\nFitted model parameters & likelihood:\n") if(x$model=="BM"){ obj<-data.frame(round(x$sig2,digits),round(x$logLik,digits)) colnames(obj)<-c("sig2","log-likelihood") rownames(obj)<-"" print(obj) } else if(x$model=="OU"){ obj<-data.frame(round(x$sig2,digits),round(x$alpha,digits), round(x$logLik,digits)) colnames(obj)<-c("sigma^2","alpha","logLik") rownames(obj)<-"" print(obj) } else if(x$model=="EB"){ obj<-data.frame(round(x$sig2,digits),round(x$r,digits), round(x$logLik,digits)) colnames(obj)<-c("sigma^2","r","logLik") rownames(obj)<-"" print(obj) } if(x$convergence==0) cat("\nR thinks it has found the ML solution.\n\n") else cat("\nOptimization may not have converged.\n\n") } phytools/R/add.species.to.genus.R0000644000176200001440000000464112616504147016415 0ustar liggesusers## function identifies the genus from a species name & attempts to add it to the tree ## written by Liam J. Revell 2013 add.species.to.genus<-function(tree,species,genus=NULL,where=c("root","random")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!is.ultrametric(tree)) warning("this code has only been tested with ultrametric tree\n your tree may be returned without edge lengths") where<-where[1] if(is.null(genus)){ ## get genus from species name x<-strsplit(species,"")[[1]] i<-1 while(x[i]!="_"&&x[i]!=" ") i<-i+1 genus<-paste(x[2:i-1],collapse="") } ii<-grep(paste(genus,"_",sep=""),tree$tip.label) if(length(ii)>1){ if(!is.monophyletic(tree,tree$tip.label[ii])) warning(paste(genus,"may not be monophyletic\n attaching to the most inclusive group containing members of this genus")) nn<-findMRCA(tree,tree$tip.label[ii]) if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn) else if(where=="random"){ tt<-splitTree(tree,list(node=nn,bp=tree$edge.length[which(tree$edge[,2]==nn)])) tt[[2]]<-add.random(tt[[2]],tips=gsub(" ","_",species)) tree<-paste.tree(tt[[1]],tt[[2]]) } else stop("option 'where' not recognized") } else if(length(ii)==1){ nn<-ii if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=0.5*tree$edge.length[which(tree$edge[,2]==nn)]) else if(where=="random") tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)]) else stop("option 'where' not recognized") } else warning("could not match your species to a genus\n check spelling, including case") tree } ## function take genus backbone tree & converts genus tree to species tree by simulating pure-birth subtrees ## written by Liam J. Revell 2015 genus.to.species.tree<-function(tree,species){ N<-Ntip(tree) genera<-tree$tip.label species<-gsub(" ","_",species) for(i in 1:N){ jj<-grep(paste(genera[i],"_",sep=""),species) nn<-which(tree$tip.label==genera[i]) if(length(jj)>1){ h<-runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)] tree$edge.length[which(tree$edge[,2]==nn)]<- tree$edge.length[which(tree$edge[,2]==nn)]-h sub.tree<-pbtree(n=length(jj),scale=h,tip.label=species[jj]) tree<-bind.tree(tree,sub.tree,where=nn) } else if(length(jj)==1) tree$tip.label[nn]<-species[jj] } tree } phytools/R/phyl.resid.R0000644000176200001440000000375312561736201014553 0ustar liggesusers# function to fit phylogenetic regression and compute residuals # multiple morphological traits in Y, size in x # written by Liam Revell 2011, 2015 ref. Revell (2009; Evolution) phyl.resid<-function(tree,x,Y,method="BM"){ # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check and sort data # X X<-cbind(1,x) if(is.null(rownames(X))){ print("x has no names. function will assume that the order of x matches tree$tip.label") rownames(X)<-tree$tip.label } else X<-X[tree$tip.label,] # sort # Y Y<-as.matrix(Y) if(is.null(rownames(Y))){ print("y has no names. function will assume that the order of y matches tree$tip.label") rownames(Y)<-tree$tip.label } else Y<-as.matrix(Y[tree$tip.label,]) # sort # analyze if(method=="BM"){ C<-vcv.phylo(tree) beta<-solve(t(X)%*%solve(C)%*%X)%*%t(X)%*%solve(C)%*%Y resid<-Y-X%*%beta return(list(beta=beta,resid=resid)) } else if(method=="lambda"){ C<-vcv.phylo(tree) maxLambda<-max(C)/max(C[upper.tri(C)]) lambda<-vector() logL<-vector() beta<-matrix(NA,ncol(X),ncol(Y),dimnames=list(colnames(X),colnames(Y))) for(i in 1:ncol(Y)){ res<-optimize(f=likelihood.lambda,interval=c(0,maxLambda),y=Y[,i],X=X,C=C,maximum=TRUE) lambda[i]<-res$maximum logL[i]<-as.numeric(res$objective) C.l<-lambda.transform(lambda[i],C) beta[,i]<-solve(t(X)%*%solve(C.l)%*%X)%*%t(X)%*%solve(C.l)%*%Y[,i] } resid<-Y-X%*%beta return(list(beta=beta,lambda=lambda,logL=logL,resid=resid)) } } # likelihood function for the regression model with lambda likelihood.lambda<-function(lambda,y,X,C){ n<-nrow(C) C.lambda<-lambda.transform(lambda,C) beta<-solve(t(X)%*%solve(C.lambda)%*%X)%*%(t(X)%*%solve(C.lambda)%*%y) sig2e<-as.double((1/n)*(t(y-X%*%beta)%*%solve(C.lambda)%*%(y-X%*%beta))) logL<--(1/2)*t(y-X%*%beta)%*%solve(sig2e*C.lambda)%*%(y-X%*%beta)-(1/2)*determinant(sig2e*C.lambda,logarithm=TRUE)$modulus-(n/2)*log(2*pi) return(logL) } phytools/R/make.simmap.R0000644000176200001440000004216713077410420014671 0ustar liggesusers# function creates a stochastic character mapped tree as a modified "phylo" object # written by Liam Revell 2013, 2014, 2015, 2016, 2017 make.simmap<-function(tree,x,model="SYM",nsim=1,...){ if(inherits(tree,"multiPhylo")){ ff<-function(yy,x,model,nsim,...){ zz<-make.simmap(yy,x,model,nsim,...) if(nsim>1) class(zz)<-NULL return(zz) } if(nsim>1) mtrees<-unlist(sapply(tree,ff,x,model,nsim,...,simplify=FALSE),recursive=FALSE) else mtrees<-sapply(tree,ff,x,model,nsim,...,simplify=FALSE) class(mtrees)<-c("multiSimmap","multiPhylo") } else { ## get optional arguments if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(hasArg(message)) pm<-list(...)$message else pm<-TRUE if(hasArg(tol)) tol<-list(...)$tol else tol<-0 if(hasArg(Q)) Q<-list(...)$Q else Q<-"empirical" if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-1000 if(hasArg(samplefreq)) samplefreq<-list(...)$samplefreq else samplefreq<-100 if(hasArg(vQ)) vQ<-list(...)$vQ else vQ<-0.1 prior<-list(alpha=1,beta=1,use.empirical=FALSE) if(hasArg(prior)){ pr<-list(...)$prior prior[names(pr)]<-pr } ## done optional arguments # check if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # if vector convert to binary matrix if(!is.matrix(x)) xx<-to.matrix(x,sort(unique(x))) else xx<-x xx<-xx[tree$tip.label,] xx<-xx/rowSums(xx) # reorder to cladewise tree<-bt<-reorder.phylo(tree,"cladewise") if(!is.binary.tree(bt)) bt<-multi2di(bt) # some preliminaries N<-length(tree$tip) m<-ncol(xx) root<-N+1 # get conditional likelihoods & model if(is.character(Q)&&Q=="empirical"){ XX<-getPars(bt,xx,model,Q=NULL,tree,tol,m,pi=pi,args=list(...)) L<-XX$L Q<-XX$Q logL<-XX$loglik if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution else pi<-pi/sum(pi) # obtain from input if(pm) printmessage(Q,pi,method="empirical") mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE) } else if(is.character(Q)&&Q=="mcmc"){ if(prior$use.empirical){ qq<-fitMk(bt,xx,model)$rates prior$alpha<-qq*prior$beta } get.stationary<-if(pi[1]=="estimated") TRUE else FALSE if(pi[1]%in%c("equal","estimated")) pi<-setNames(rep(1/m,m),colnames(xx)) # set equal else pi<-pi/sum(pi) # obtain from input XX<-mcmcQ(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi=pi) L<-lapply(XX,function(x) x$L) Q<-lapply(XX,function(x) x$Q) logL<-lapply(XX,function(x) x$loglik) pi<-if(get.stationary) lapply(Q,statdist) else lapply(1:nsim,function(x,y) y, y=pi) if(pm) printmessage(Reduce('+',Q)/length(Q),pi,method="mcmc") mtrees<-if(nsim>1) mapply(smap,L=L,Q=Q,pi=pi,logL=logL,MoreArgs= list(tree=tree,x=x,N=N,m=m,root=root),SIMPLIFY=FALSE) else list(smap(tree=tree,x=x,N=N,m=m,root=root,L=L[[1]],Q=Q[[1]],pi=pi[[1]], logL=logL[[1]])) } else if(is.matrix(Q)){ XX<-getPars(bt,xx,model,Q=Q,tree,tol,m,pi=pi,args=list(...)) L<-XX$L logL<-XX$loglik if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution else pi<-pi/sum(pi) # obtain from input if(pm) printmessage(Q,pi,method="fixed") mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE) } if(length(mtrees)==1) mtrees<-mtrees[[1]] else class(mtrees)<-c("multiSimmap","multiPhylo") } (if(hasArg(message)) list(...)$message else TRUE) if((if(hasArg(message)) list(...)$message else TRUE)&&inherits(tree,"phylo")) message("Done.") return(mtrees) } # print message # written by Liam J. Revell 2013 printmessage<-function(Q,pi,method){ if(method=="empirical"||method=="fixed") cat("make.simmap is sampling character histories conditioned on the transition matrix\n\nQ =\n") else if(method=="mcmc"){ cat("make.simmap is simulating with a sample of Q from\nthe posterior distribution\n") cat("\nMean Q from the posterior is\nQ =\n") } print(Q) if(method=="empirical") cat("(estimated using likelihood);\n") else if(method=="fixed") cat("(specified by the user);\n") cat("and (mean) root node prior probabilities\npi =\n") if(is.list(pi)) pi<-Reduce("+",pi)/length(pi) print(pi) flush.console() } # mcmc for Q used in Q="mcmc" # written by Liam J. Revell 2013 mcmcQ<-function(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi,args=list()){ update<-function(x){ x<-abs(x+rnorm(n=np,mean=0,sd=sqrt(vQ))) return(x) } # get model matrix if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ np<-rate[]<-1 diag(rate)<-NA } if(model=="ARD"){ np<-m*(m-1) rate[col(rate)!=row(rate)]<-1:np } if(model=="SYM") { np<-m*(m-1)/2 sel<-col(rate)=runif(n=1)){ yy<-zz p<-pp } } # now run MCMC generation, sampling at samplefreq cat(paste("Running",samplefreq*nsim,"generations of MCMC, sampling every",samplefreq,"generations.\nPlease wait....\n\n")) flush.console() XX<-vector("list",nsim) for(i in 1:(samplefreq*nsim)){ pp<-update(p) Qp<-matrix(c(0,pp)[rate+1],m,m) diag(Qp)<--rowSums(Qp,na.rm=TRUE) zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args) p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))- yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE))) if(p.odds>=runif(n=1)){ yy<-zz p<-pp } if(i%%samplefreq==0){ Qi<-matrix(c(0,p)[rate+1],m,m) diag(Qi)<--rowSums(Qi,na.rm=TRUE) XX[[i/samplefreq]]<-getPars(bt,xx,model,Qi,tree,tol,m,TRUE,pi=pi,args) } } return(XX) } # get pars # written by Liam J. Revell 2013, 2017 getPars<-function(bt,xx,model,Q,tree,tol,m,liks=TRUE,pi,args=list()){ if(!is.null(args$pi)) args$pi<-NULL args<-c(list(tree=bt,x=xx,model=model,fixedQ=Q,output.liks=liks,pi=pi),args) obj<-do.call(fitMk,args) N<-length(bt$tip.label) II<-obj$index.matrix+1 lvls<-obj$states if(liks){ L<-obj$lik.anc rownames(L)<-N+1:nrow(L) if(!is.binary.tree(tree)){ ancNames<-matchNodes(tree,bt) L<-L[as.character(ancNames[,2]),] rownames(L)<-ancNames[,1] } L<-rbind(xx,L) rownames(L)[1:N]<-1:N } else L<-NULL Q<-matrix(c(0,obj$rates)[II],m,m,dimnames=list(lvls,lvls)) if(any(rowSums(Q,na.rm=TRUE)0) rexp(n=1,rate=-Q[s,s]) else t-sum(dt) if(sum(dt)<(t-tol)){ dt<-c(dt,0) if(sum(Q[s,][-match(s,colnames(Q))])>0) names(dt)[length(dt)]<-rstate(Q[s,][-match(s,colnames(Q))]/sum(Q[s,][-match(s,colnames(Q))])) else names(dt)[length(dt)]<-s } else dt[length(dt)]<-dt[length(dt)]-sum(dt)+t } return(dt) } # function uses numerical optimization to solve for the stationary distribution # written by Liam J. Revell 2013 statdist<-function(Q){ foo<-function(theta,Q){ Pi<-c(theta[1:(nrow(Q)-1)],1-sum(theta[1:(nrow(Q)-1)])) sum((Pi%*%Q)^2) } k<-nrow(Q) if(nrow(Q)>2){ fit<-optim(rep(1/k,k-1),foo,Q=Q,control=list(reltol=1e-16)) return(setNames(c(fit$par[1:(k-1)],1-sum(fit$par[1:(k-1)])),rownames(Q))) } else { fit<-optimize(foo,interval=c(0,1),Q=Q) return(setNames(c(fit$minimum,1-fit$minimum),rownames(Q))) } } ## S3 print method for objects of class "simmap" & multiSimmap ## based on print.phylo in ape print.simmap<-function(x,printlen=6,...){ N<-Ntip(x) M<-x$Nnode cat(paste("\nPhylogenetic tree with",N,"tips and",M,"internal nodes.\n\n")) cat("Tip labels:\n") if(N>printlen) cat(paste("\t",paste(x$tip.label[1:printlen],collapse=", "),", ...\n",sep="")) else print(x$tip.label) ss<-sort(unique(c(getStates(x,"tips"),getStates(x,"nodes")))) cat(paste("\nThe tree includes a mapped, ",length(ss),"-state discrete character with states:\n", sep="")) if(length(ss)>printlen) cat(paste("\t",paste(ss[1:printlen],collapse=", "),", ...\n",sep="")) else cat(paste("\t",paste(ss,collapse=", "),"\n",sep="")) rlab<-if(is.rooted(x)) "Rooted" else "Unrooted" cat("\n",rlab,"; includes branch lengths.\n",sep="") } print.multiSimmap<-function(x,details=FALSE,...){ N<-length(x) cat(N,"phylogenetic trees with mapped discrete characters\n") if(details){ n<-sapply(x,Ntip) s<-sapply(x,function(x) length(unique(c(getStates(x,"tips"),getStates(x,"nodes"))))) for(i in 1:N) cat("tree",i,":",n[i],"tips,",s[i],"mapped states\n") } } ## S3 summary method for objects of class "simmap" & "multiSimmap" summary.simmap<-function(object,...) describe.simmap(object,...) summary.multiSimmap<-function(object,...) describe.simmap(object,...) ## for backward compatibility with any function using apeAce internally apeAce<-function(tree,x,model,fixedQ=NULL,...){ if(hasArg(output.liks)){ output.liks<-list(...)$output.liks return(fitMk(tree,x,model,fixedQ,...)) } else { output.liks<-TRUE return(fitMk(tree,x,model,fixedQ,output.liks=TRUE,...)) } } ## S3 logLik methods for "simmap" & "multiSimmap" logLik.simmap<-function(object,...) object$logL logLik.multiSimmap<-function(object,...) sapply(object,function(x) x$logL) ## S3 density method for "multiSimmap" density.multiSimmap<-function(x,...){ if(hasArg(method)) method<-list(...)$method else method<-"changes" if(!method%in%c("densityMap","changes")){ cat("method not recognized. Setting to default method.\n\n") method<-"changes" } if(method=="densityMap") obj<-densityMap(x,plot=FALSE,...) else if(method=="changes"){ if(hasArg(bw)) bw<-list(...)$bw else bw<-1 tmp<-summary(x) ab<-lapply(2:ncol(tmp$count),function(i,x) x[,i],x=tmp$count) names(ab)<-sapply(strsplit(colnames(tmp$count)[2:ncol(tmp$count)], ","),function(x) paste(x,collapse="->")) ab<-lapply(ab,function(x){ class(x)<-"mcmc" x }) if(.check.pkg("coda")){ hpd.ab<-lapply(ab,HPDinterval) } else { cat(" HPDinterval requires package coda.\n") cat(" Computing 95% interval from samples only.\n\n") hpd95<-function(x){ obj<-setNames(c(sort(x)[round(0.025*length(x))], sort(x)[round(0.975*length(x))]), c("lower","upper")) attr(obj,"Probability")<-0.95 obj } hpd.ab<-lapply(ab,hpd95) } minmax<-range(unlist(ab)) pcalc<-function(x,mm) hist(x,breaks=seq(mm[1]-1.5,mm[2]+1.5,bw),plot=FALSE) p.ab<-lapply(ab,pcalc,mm=minmax) states<-colnames(tmp$ace) trans<-names(ab) obj<-list(hpd=hpd.ab, p=p.ab, states=states,trans=trans, bw=bw, mins=sapply(ab,min), meds=sapply(ab,median), means=sapply(ab,mean), maxs=sapply(ab,max)) class(obj)<-"changesMap" } else if(method=="timings"){ cat("This method doesn't work yet.\n") obj<-NULL } obj } ## S3 plot method for "changesMap" object from density.multiSimmap plot.changesMap<-function(x,...){ p<-x$p hpd<-x$hpd bw<-x$bw if(length(x$trans)==2){ plot(p[[1]]$mids,p[[1]]$density,xlim=c(min(x$mins)-1, max(x$maxs)+1),ylim=c(0,1.2*max(c(p[[1]]$density, p[[2]]$density))), type="n",xlab="number of changes", ylab="relative frequency across stochastic maps") y2<-rep(p[[1]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[1]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=make.transparent("red",0.3),border=FALSE) lines(p[[1]]$mids-bw/2,p[[1]]$density,type="s") y2<-rep(p[[2]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[2]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=make.transparent("blue",0.3),border=FALSE) lines(p[[2]]$mids-bw/2,p[[2]]$density,type="s") add.simmap.legend(colors=setNames(c(make.transparent("red",0.3), make.transparent("blue",0.3)),x$trans[1:2]), prompt=FALSE,x=min(x$mins),y=0.95*par()$usr[4]) dd<-0.01*diff(par()$usr[3:4]) lines(hpd[[1]],rep(max(p[[1]]$density)+dd,2)) lines(rep(hpd[[1]][1],2),c(max(p[[1]]$density)+dd, max(p[[1]]$density)+dd-0.005)) lines(rep(hpd[[1]][2],2),c(max(p[[1]]$density)+dd, max(p[[1]]$density)+dd-0.005)) text(mean(hpd[[1]]),max(p[[1]]$density)+dd, paste("HPD(",x$trans[1],")",sep=""), pos=3) lines(hpd[[2]],rep(max(p[[2]]$density)+dd,2)) lines(rep(hpd[[2]][1],2),c(max(p[[2]]$density)+dd, max(p[[2]]$density)+dd-0.005)) lines(rep(hpd[[2]][2],2),c(max(p[[2]]$density)+dd, max(p[[2]]$density)+dd-0.005)) text(mean(hpd[[2]]),max(p[[2]]$density)+dd, paste("HPD(",x$trans[2],")",sep=""), pos=3) } else { k<-length(x$states) par(mfrow=c(k,k)) ii<-1 max.d<-max(unlist(lapply(p,function(x) x$density))) for(i in 1:k){ for(j in 1:k){ if(i==j) plot.new() else { plot(p[[ii]]$mids,p[[ii]]$density,xlim=c(min(x$mins)-1, max(x$maxs)+1),ylim=c(0,1.2*max.d), type="n",xlab="number of changes", ylab="relative frequency",main=x$trans[ii],font.main=1) ##title(main=) y2<-rep(p[[ii]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[ii]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=make.transparent("blue",0.3),border=FALSE) lines(p[[ii]]$mids-bw/2,p[[ii]]$density,type="s") dd<-0.03*diff(par()$usr[3:4]) lines(hpd[[ii]],rep(max(p[[ii]]$density)+dd,2)) text(mean(hpd[[ii]]),max(p[[ii]]$density)+dd,"HPD",pos=3) ii<-ii+1 } } } } } print.changesMap<-function(x, ...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-2 cat("\nDistribution of changes from stochastic mapping:\n") NROW<-ceiling(length(x$trans)/2) if(NROW>1) cat("\n") for(i in 1:NROW){ ii<-2*i-1 jj<-ii+1 cat(paste("\t",x$trans[ii],"\t\t",x$trans[jj],"\n",sep="")) cat(paste("\tMin. :",round(x$mins[ii],signif), "\tMin. :",round(x$mins[jj],signif),"\n",sep="")) cat(paste("\tMedian :",round(x$meds[ii],signif), "\tMedian :",round(x$meds[jj],signif),"\n",sep="")) cat(paste("\tMean :",round(x$means[ii],signif), "\tMean :",round(x$means[jj],signif),"\n",sep="")) cat(paste("\tMax. :",round(x$maxs[ii],signif), "\tMax. :",round(x$maxs[jj],signif),"\n\n",sep="")) } for(i in 1:length(x$trans)) cat("95% HPD interval(",x$trans[i],"): [",x$hpd[[i]][1],", ", x$hpd[[i]][2],"]\n",sep="") cat("\n") } phytools/R/locate.fossil.R0000644000176200001440000001022213161011673015220 0ustar liggesusers## code to place a fossil taxon into a tree using ML and continuous data ## written by Liam J. Revell 2014, 2015, 2017 locate.fossil<-function(tree,X,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(rotate)) rotate<-list(...)$rotate else rotate<-TRUE if(hasArg(edge.constraint))edge.constraint<-list(...)$edge.constraint else edge.constraint<-tree$edge[,2] if(hasArg(time.constraint)) time.constraint<-list(...)$time.constraint else time.constraint<-c(0,max(nodeHeights(tree))) if(any(time.constraint<0)) time.constraint<-max(nodeHeights(tree))+time.constraint if(length(time.constraint)==1) time.constraint<-rep(time.constraint,2) if(!is.matrix(X)) X<-as.matrix(X) tip<-setdiff(rownames(X),tree$tip.label) fossilML(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate) } fossilML<-function(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate){ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using ML. Please wait....\n",sep="")) if(ncol(X)>1&&rotate){ pca<-phyl.pca(tree,X[tree$tip.label,]) obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1) X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec } lik.tree<-function(par,tip,tree,edge,height,XX,rotate,time.constraint){ tip.depth<-par[1] tip.height<-par[2] if(tip.height>(tip.depth+1e-6)){ ii<-which(tree$edge[,2]==edge) tree<-bind.tip(tree,tip,where=edge,position=min(height[2]-tip.depth,tree$edge.length[ii]), edge.length=tip.height-tip.depth) if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE)) if(plot){ plotTree(tree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) title(paste("log(L) = ",signif(sum(ll),6),sep="")) axis(1) } logL<-sum(ll) } else logL<--.Machine$double.xmax/1e100 logL } ee<-intersect(tree$edge[,2],edge.constraint) H<-nodeHeights(tree) hh<-unique(c(tree$edge[H[,1]<=time.constraint[2],2],tree$edge[H[,2]<=time.constraint[2],2])) ee<-intersect(ee,hh) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ ii<-which(tree$edge[,2]==ee[i]) lower<-c(H[ii,1],time.constraint[1]) upper<-c(H[ii,2],time.constraint[2]) par<-c(mean(lower),mean(upper)) fit[[i]]<-optim(par,lik.tree,tip=tip,tree=tree,edge=ee[i],height=H[ii,],XX=X,rotate=rotate, time.constraint=time.constraint, method="L-BFGS-B",lower=lower,upper=upper,control=list(fnscale=-1)) } logL<-sapply(fit,function(x) x$value) ii<-which(logL==max(logL)) if(length(ii)==1){ fit<-fit[[ii]] edge<-ee[ii] mltree<-bind.tip(tree,tip,where=edge, position=H[which(tree$edge[,2]==edge),2]-fit$par[1], edge.length=fit$par[2]-fit$par[1]) mltree$logL<-fit$value } else { fit<-fit[ii] mltree<-vector(mode="list",length=length(ii)) for(i in 1:length(ii)){ edge<-ee[ii[i]] mltree[[i]]<-bind.tip(tree,tip,where=edge, position=H[which(tree$edge[,2]==edge),2]-fit[[i]]$par[1], edge.length=fit[[i]]$par[2]-fit[[i]]$par[1]) mltree[[i]]$logL<-fit[[i]]$value } class(mltree)<-"multiPhylo" } if(!quiet) cat("Done.\n") if(plot){ if(class(mltree)=="phylo"){ plotTree(mltree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) title(paste("Optimized position of taxon \"",tip,"\"",sep="")) axis(1) } else { par(mfrow=c(1,length(mltree))) for(i in 1:length(mltree)){ plotTree(mltree[[i]],mar=c(2.1,0.1,0.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) axis(1) } } } mltree } phytools/R/ratebystate.R0000644000176200001440000000610313201426036015003 0ustar liggesusers## simulation based test for a correlation between the state of x & the rate of y ## written by Liam J. Revell 2013, 2017 ratebystate<-function(tree,x,y,nsim=100,corr=c("pearson","spearman"),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") corr<-corr[1] if(hasArg(sim.method)) sim.method<-list(...)$sim.method else sim.method<-"sim.corrs" if(hasArg(method)) method<-list(...)$method else method<-"by.node" if(hasArg(message)) message<-list(...)$message else message<-TRUE if(hasArg(logarithm)) logarithm<-list(...)$logarithm else logarithm<-FALSE if(!is.binary.tree(tree)) tree<-multi2di(tree) V<-phyl.vcv(cbind(x,y),vcv(tree),lambda=1)$R if(method=="by.branch"){ aa<-c(x[tree$tip.label],fastAnc(tree,x)) names(aa)[1:length(tree$tip)]<-1:length(tree$tip) aa<-rowMeans(matrix(aa[tree$edge],nrow(tree$edge),2)) a<-vector() for(i in 1:tree$Nnode+length(tree$tip)){ j<-which(tree$edge[,1]==i) a[i-length(tree$tip)]<-sum(aa[j]*tree$edge.length[j])/sum(tree$edge.length[j]) } names(a)<-1:tree$Nnode+length(tree$tip) } else a<-fastAnc(tree,x) if(logarithm) a<-exp(a) b<-pic(y,tree)[names(a)]^2 r<-cor(a,b,method=corr) beta<-setNames(lm(b~a)$coefficients[2],NULL) foo<-function(tree,V){ if(sim.method=="fastBM") XY<-fastBM(tree,nsim=2)%*%sqrt(diag(diag(V))) else if(sim.method=="sim.corrs") XY<-sim.corrs(tree,V) a<-fastAnc(tree,XY[,1]) b<-pic(XY[,2],tree)[names(a)]^2 r<-cor(a,b,method=corr) return(r) } r.null<-c(r,replicate(nsim-1,foo(tree,V))) P<-mean(abs(r.null)>=abs(r)) obj<-list(beta=beta,r=r,P=P,corr=corr,method=method) class(obj)<-"ratebystate" obj } # function simulates rate by state evolution for x & y # written by Liam J. Revell 2013 sim.ratebystate<-function(tree,sig2x=1,sig2y=1,beta=c(0,1),...){ if(hasArg(method)) method<-list(...)$method else method<-"by.node" if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(logarithm)) logarithm<-list(...)$logarithm else logarithm<-FALSE x<-fastBM(tree,a=if(logarithm) beta[1] else 0,sig2=sig2x,internal=TRUE) if(method=="by.node") ss<-x[1:tree$Nnode+length(tree$tip.label)] else if(method=="by.branch") ss<-rowMeans(matrix(x[tree$edge],nrow(tree$edge),2)) zz<-tree if(!logarithm) zz$edge.length<-beta[2]*zz$edge.length*(beta[1]+ss-min(ss)) else zz$edge.length<-beta[2]*zz$edge.length*exp(ss) y<-fastBM(zz,sig2=sig2y) if(plot) phenogram(zz,x,type="b",colors="blue",ftype="off", xlab="expected variance",ylab="independent variable (x)") x<-x[tree$tip.label] return(cbind(x,y)) } ## S3 print method print.ratebystate<-function(x,digits=6,...){ cat("\nObject of class \"ratebystate\".\n") cat("\nSummary of object:\n") cat(paste(" beta[1] = ",round(x$beta,digits),"\n",sep="")) cat(paste(" ",if(x$corr=="pearson") "Pearson " else "Spearman ","correlation (r) = ",round(x$r,digits), "\n",sep="")) cat(paste(" P-value (from simulation) = ",round(x$P,digits), "\n\n",sep="")) cat(paste("Analysis was conducted using \"",x$method, "\" method.\n\n",sep="")) } phytools/R/bmPlot.R0000644000176200001440000001006212564206726013725 0ustar liggesusers# visualize discrete time Brownian simulation on a tree # written by Liam J. Revell 2012, 2013, 2015 bmPlot<-function(tree,type="BM",anc=0,sig2=1/1000,ngen=1000,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(return.tree)) return.tree<-list(...)$return.tree else return.tree<-TRUE tr<-reorder(tree) H<-nodeHeights(tr) tr$edge.length<-round(tr$edge.length/max(H)*ngen) tr<-di2multi(tr) h<-nodeHeights(tr)[,1] bmSim<-function(start,n) cumsum(c(start,rnorm(n,sd=sqrt(sig2)))) X<-T<-list() N<-length(tr$tip) for(i in 1:nrow(tr$edge)){ if(tr$edge[i,1]==(N+1)) X[[i]]<-bmSim(anc,tr$edge.length[i]) else { parent<-match(tr$edge[i,1],tr$edge[,2]) X[[i]]<-bmSim(X[[parent]][length(X[[parent]])],tr$edge.length[i]) } T[[i]]<-h[i]+0:tr$edge.length[i] } if(type=="BM") cols<-bm(X,T) else if(type=="threshold") cols<-th(X,T,...) if(return.tree){ if(type=="BM") tr$X<-X else if(type=="threshold"){ if(hasArg(thresholds)) thresholds<-list(...)$thresholds else stop("no thresholds provided for type=\"threshold\"") thresholds<-setNames(c(thresholds,Inf),letters[1:(length(thresholds)+1)]) xx<-lapply(X,function(x,y) sapply(x[2:length(x)],threshState,thresholds=y),y=thresholds) maps<-lapply(tr$edge.length,function(x) rep(1,x)) maps<-mapply(function(x,y) setNames(x,y),x=maps,y=xx) maps<-lapply(maps,mergeAdjacent) tr$maps<-maps class(tr)<-c("simmap",setdiff(class(tr),"simmap")) } } Y<-matrix(NA,nrow(tr$edge),2) Y[,1]<-sapply(X,function(x) x[1]) Y[,2]<-sapply(X,function(x) x[length(x)]) x<-Y[tr$edge[,2]%in%1:N,2] names(x)<-tr$tip.label[tr$edge[tr$edge[,2]%in%1:N,2]] a<-c(anc,Y[tr$edge[,2]%in%(N+2:tr$Nnode),2]) names(a)<-c(N+1,tr$edge[tr$edge[,2]%in%(N+2:tr$Nnode),2]) xx<-c(x[tr$tip],a[as.character(N+1:tr$Nnode)]) if(!return.tree) return(xx) else return(list(x=xx,tree=tr,colors=cols)) } # plots type="BM" bm<-function(X,T,...){ minX<-min(sapply(X,min)) maxX<-max(sapply(X,max)) plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),xlim=c(minX,maxX),ylab="time",xlab="phenotype") for(i in 1:length(X)) lines(X[[i]],T[[i]]) if(hasArg(colors)) cols<-list(...)$colors else cols<-"black" return(cols) } # plots type="threshold" th<-function(X,T,...){ minX<-min(sapply(X,min)) maxX<-max(sapply(X,max)) if(hasArg(thresholds)) thresholds<-list(...)$thresholds else stop("no thresholds provided for type='threshold'") if(hasArg(colors)) cols<-list(...)$colors else { cols<-c("black","red","blue","green") while(length(thresholds)>(length(cols)-1)) cols<-c(cols,c("black","red","blue","green")) } thresholds<-thresholds+1e-16 plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),xlim=c(minX,maxX),ylab="time",xlab="liability") for(i in 1:length(X)) if(length(X[[i]])>1) for(j in 1:(length(X[[i]])-1)) if(threshCol(X[[i]][j],thresholds,cols)==threshCol(X[[i]][j+1],thresholds,cols)) lines(X[[i]][c(j,j+1)],T[[i]][c(j,j+1)],col=threshCol(X[[i]][j+1],thresholds,cols)) else { t<-thresholds[which(sort(c(thresholds,min(X[[i]][c(j,j+1)])))==min(X[[i]][c(j,j+1)]))] lines(c(X[[i]][j],t),c(T[[i]][j],T[[i]][j]+abs(diff(c(X[[i]][j],t))/diff(X[[i]][c(j,j+1)]))),col=threshCol(X[[i]][j],thresholds,cols)) lines(c(X[[i]][j+1],t),c(T[[i]][j+1],T[[i]][j+1]-abs(diff(c(X[[i]][j+1],t))/diff(X[[i]][c(j,j+1)]))),col=threshCol(X[[i]][j+1],thresholds,cols)) } for(i in 1:length(thresholds)) lines(rep(thresholds[i],2),c(0,max(sapply(T,max))),lty="dashed") return(setNames(cols[1:(length(thresholds)+1)],letters[1:(length(thresholds)+1)])) } # returns a color based on position relative to thresholds threshCol<-function(x,thresholds,cols){ t<-c(-Inf,thresholds,Inf); i<-1 while(x>t[i]) i<-i+1 return(cols[i-1]) } # merge adjacent map in the same state mergeAdjacent<-function(x){ ii<-1 y<-x[1] if(length(x)>1){ for(i in 2:length(x)){ if(names(x)[i]==names(y)[ii]) y[ii]<-y[ii]+x[i] else{ y<-c(y,x[i]) ii<-ii+1 } } } return(y) } phytools/R/multi.mantel.R0000644000176200001440000000354212043571167015102 0ustar liggesusers# function for multiple matrix regression with P-values computed by Mantel permutation of the dependent matrix # written by Liam J. Revell 2012 multi.mantel<-function(Y,X,nperm=1000){ y<-unfoldLower(Y) if(!is.list(X)) X<-list(X) Xv<-sapply(X,unfoldLower) colnames(Xv)<-paste("X",1:ncol(Xv),sep="") fit<-lm(y~Xv) coefficients<-fit$coefficients smmry<-summary(fit) r.squared<-smmry$r.squared fstatistic<-smmry$fstatistic[1] pF<-0 tstatistic<-smmry$coefficients[,"t value"] pT<-rep(0,length(tstatistic)) # begin Mantel permutations Y<-Yp<-as.matrix(Y) for(i in 1:nperm){ y<-unfoldLower(Yp) fitp<-lm(y~Xv) smmryp<-summary(fitp) pF<-pF+as.numeric(smmryp$fstatistic[1]>=fstatistic)/nperm pT<-pT+as.numeric(abs(smmryp$coefficients[,"t value"])>=abs(tstatistic))/nperm rndm<-sample(1:nrow(Yp)) Yp<-Y[rndm,rndm] } names(coefficients)<-names(tstatistic)<-names(pT)<-c("(intercept)",paste("X",1:ncol(Xv),sep="")) names(fstatistic)<-NULL residuals<-foldtoLower(fit$residuals); attr(residuals,"Labels")<-rownames(Y) fitted.values<-foldtoLower(fit$fitted.values); attr(fitted.values,"Labels")<-rownames(Y) return(list(r.squared=r.squared, coefficients=coefficients, tstatistic=tstatistic, fstatistic=fstatistic, probt=pT, probF=pF, residuals=residuals, fitted.values=fitted.values)) } # function unfolds the sub-diagonal of a "dist" object or symmetric matrix into a vector # written by Liam J. Revell 2012 unfoldLower<-function(X){ if(class(X)=="dist") X<-as.matrix(X) x<-vector() for(i in 2:ncol(X)-1) x<-c(x,X[(i+1):nrow(X),i]) names(x)<-NULL return(x) } # function folds vector into lower matrix "dist" object foldtoLower<-function(x){ n<-(1+sqrt(1+8*length(x)))/2 X<-matrix(0,n,n) j<-0 for(i in 2:n-1){ X[(i+1):n,i]<-x[i:(n-1)+j] j<-j+(n-i-1) } return(as.dist(X)) } phytools/R/phylo.heatmap.R0000644000176200001440000000527313177122507015244 0ustar liggesusers## function for phylogenetic heat map ## written by Liam J. Revell 2016, 2017 phylo.heatmap<-function(tree,X,fsize=1,colors=NULL,standardize=FALSE,...){ if(length(fsize)!=3) fsize<-rep(fsize,3) if(hasArg(legend)) legend<-list(...)$legend else legend<-TRUE if(hasArg(labels)) labels<-list(...)$labels else labels<-TRUE if(hasArg(split)) split<-list(...)$split else split<-c(0.5,0.5) split<-split/sum(split) if(is.null(colnames(X))) colnames(X)<-paste("var",1:ncol(X),sep="") if(standardize){ sd<-apply(X,2,function(x) sqrt(var(x,na.rm=TRUE))) X<-(X-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(X,na.rm=TRUE))/ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd) } if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,(2-0.5)*split[2]/split[1]+0.5) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-if(legend) c(if(standardize) -0.15 else -0.1, if(labels) 1.1 else 1) else c(0,if(labels) 1.1 else 1) if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(1.1,4) if(is.null(colors)) colors<-heat.colors(n=20)[20:1] if(hasArg(grid)) add.grid <- list(...)$grid else add.grid <- FALSE cw<-untangle(tree,"read.tree") plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(cw,fsize=fsize[1],...) START<-h+1/2*((2-0.5)*split[2]/split[1]+0.5-h)/(ncol(X)-1)+ 0.5*strwidth("W")*fsize[1] END<-(2-0.5)*split[2]/split[1]+0.5-1/2*((2-0.5)*split[2]/split[1]+ 0.5-START)/(ncol(X)-1) X<-X[cw$tip.label,] image(x=seq(START,END,by=(END-START)/(ncol(X)-1)), z=t(X[cw$tip.label,]),add=TRUE, col=colors,...) if(add.grid){ dx <- (END - START)/(ncol(X) - 1) x <- seq(START - dx/2, END + dx/2, by = dx) nTips <- length(tree$tip.label) y <- c(-1/(2*(nTips-1)), seq(0, 1, length = nTips) + 1/(2*(nTips-1)) ) segments(x, y[1], x, y[length(y)]) segments(x[1], y, x[length(x)], y) } if(legend) add.color.bar(leg=END-START,cols=colors,lims=range(X,na.rm=TRUE), title=if(standardize) "standardized value" else "value", subtitle=if(standardize) "SD units" else "",prompt=FALSE,x=START, y=-1/(2*(Ntip(cw)-1))-3*fsize[3]*strheight("W"), digits=if(max(abs(X),na.rm=TRUE)<1) round(log10(1/max(abs(X),na.rm=TRUE)))+1 else 2,fsize=fsize[3]) if(labels) text(x=seq(START,END,by=(END-START)/(ncol(X)-1)), y=rep(1+1/(2*(Ntip(cw)-1))+0.4*fsize[2]*strwidth("I"),ncol(X)), colnames(X),srt=70,adj=c(0,0.5),cex=fsize[2]) if(any(is.na(X))){ ii<-which(is.na(X),arr.ind=TRUE) x.na<-seq(START,END,by=(END-START)/(ncol(X)-1))[ii[,2]] y.na<-seq(0,1,by=1/(nrow(X)-1))[ii[,1]] for(i in 1:length(x.na)){ xx<-x.na[i]+c(1/2,-1/2)*(END-START)/(ncol(X)-1) yy<-y.na[i]+c(-1/2,1/2)*1/(nrow(X)-1) lines(xx,yy) } } } phytools/R/phylomorphospace.R0000644000176200001440000001304112565415326016063 0ustar liggesusers# this funciton creates a phylomorphospace plot (Sidlauskas 2006) # written by Liam J. Revell 2010-13, 2015 phylomorphospace<-function(tree,X,A=NULL,label=c("radial","horizontal","off"),control=list(),...){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(nrow(X)!=length(tree$tip)) stop("X must contain the same number of rows as species in tree.") if(is.null(rownames(X))){ warning("X is missing row names; assuming order of tip labels.") rownames(X)<-tree$tip.label } if(ncol(X)!=2){ warning("X has more than 2 columns. Using only the first 2 columns.") X<-X[,1:2] } # get ancestral states if(is.null(A)) A<-apply(X,2,fastAnc,tree=tree) # control list con=list(col.edge=setNames(rep("black",nrow(tree$edge)),as.character(tree$edge[,2])), col.node=setNames(rep("black",max(tree$edge)),as.character(1:max(tree$edge)))) con[(namc<-names(control))]<-control # get optional arguments if(hasArg(node.by.map)) node.by.map<-list(...)$node.by.map else node.by.map<-FALSE if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype) label<-"off" if(hasArg(node.size)){ node.size<-list(...)$node.size if(length(node.size)==1) node.size<-c(node.size,node.size) } else node.size<-c(1,1.3) # set xlim & ylim if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-expand(range(c(X[,1],A[,1])),1.1) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-expand(range(c(X[,2],A[,2])),1.1) # set xlab & ylab if(hasArg(xlab)) xlab<-list(...)$xlab else xlab<-colnames(X)[1] if(hasArg(ylab)) ylab<-list(...)$ylab else ylab<-colnames(X)[2] # set font size for tip labels if(hasArg(fsize)) fsize<-0.75*list(...)$fsize else fsize<-0.75 # check if colors for stochastic mapping if(hasArg(colors)) colors<-list(...)$colors else if(!is.null(tree$maps)) colors<-setNames(palette()[1:ncol(tree$mapped.edge)],sort(colnames(tree$mapped.edge))) # set lwd if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-if(is.null(tree$maps)) 1 else 2 # other optional arguments? if(hasArg(axes)) axes<-list(...)$axes else axes<-TRUE if(hasArg(add)) add<-list(...)$add else add<-FALSE # deprecate to logical label argument label<-label[1] if(label==TRUE||label==FALSE) message("options for label have changed.\nNow choose \"radial\", \"horizontal\", or \"off\".") if(label==TRUE) label<-"radial" if(label==FALSE) label<-"off" # do some bookkeeping aa<-setNames(c(X[tree$tip.label,1],A[,1]),c(1:length(tree$tip.label),rownames(A))) bb<-setNames(c(X[tree$tip.label,2],A[,2]),c(1:length(tree$tip.label),rownames(A))) XX<-matrix(aa[as.character(tree$edge)],nrow(tree$edge),2) YY<-matrix(bb[as.character(tree$edge)],nrow(tree$edge),2) # plot projection if(!add) plot(x=A[1,1],y=A[1,2],xlim=xlim,ylim=ylim,xlab=xlab,ylab=ylab,pch=16,cex=0.1,col="white",axes=axes,frame.plot=TRUE) if(is.null(tree$maps)){ for(i in 1:nrow(XX)) lines(XX[i,],YY[i,],col=con$col.edge[as.character(tree$edge[i,2])],lwd=lwd) } else { for(i in 1:nrow(XX)){ xx<-tree$maps[[i]]/sum(tree$maps[[i]])*(XX[i,2]-XX[i,1]) yy<-tree$maps[[i]]/sum(tree$maps[[i]])*(YY[i,2]-YY[i,1]) cc<-names(tree$maps[[i]]) x<-XX[i,1]; y<-YY[i,1] for(j in 1:length(xx)){ lines(c(x,x+xx[j]),c(y,y+yy[j]),col=colors[cc[j]],lwd=lwd) x<-x+xx[j]; y<-y+yy[j] } } if(node.by.map){ zz<-c(getStates(tree,type="tips"),getStates(tree)) names(zz)[1:length(tree$tip.label)]<-sapply(names(zz)[1:length(tree$tip.label)],function(x,y) which(y==x),y=tree$tip.label) con$col.node<-setNames(colors[zz],names(zz)) } } zz<-c(tree$edge[1,1],tree$edge[tree$edge[,2]>length(tree$tip.label),2]) points(c(XX[1,1],XX[tree$edge[,2]>length(tree$tip.label),2]),c(YY[1,1],YY[tree$edge[,2]>length(tree$tip.label),2]),pch=16,cex=node.size[1],col=con$col.node[as.character(zz)]) zz<-tree$edge[tree$edge[,2]<=length(tree$tip.label),2] points(XX[tree$edge[,2]<=length(tree$tip.label),2],YY[tree$edge[,2]<=length(tree$tip.label),2],pch=16,cex=node.size[2],col=con$col.node[as.character(zz)]) zz<-sapply(1:length(tree$tip.label),function(x,y) which(x==y),y=tree$edge[,2]) if(label!="off"){ asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3]) for(i in 1:length(tree$tip.label)){ ii<-which(tree$edge[,2]==i) aa<-atan(asp*(YY[ii,2]-YY[ii,1])/(XX[ii,2]-XX[ii,1]))/(2*pi)*360 adj<-if(XX[ii,2]sig2 theta[2]->lambda theta[3]->dbar V<-sig2*lambda.transform(C,lambda)+V.diff logL<-as.numeric(-t(d-dbar)%*%solve(V,d-dbar)/2-determinant(V)$modulus[1]/2-length(d)*log(2*pi)/2) return(logL) } # maximize the likelihood if(!fixed) res=optim(c(mean(pic(d,multi2di(tree))^2),lambda,h0),likelihood,d=d,C=C,V.diff=V.diff,method="L-BFGS-B",lower=c(1e-8,0,-Inf),upper=c(Inf,1,Inf),hessian=TRUE,control=list(fnscale=-1)) else res=optim(c(mean(pic(d,multi2di(tree))^2),lambda,h0),likelihood,d=d,C=C,V.diff=V.diff,method="L-BFGS-B",lower=c(1e-8,lambda-1e-8,-Inf),upper=c(Inf,lambda,Inf),hessian=TRUE,control=list(fnscale=-1)) # test se.dbar<-sqrt(-1/res$hessian[3,3]) t<-(res$par[3]-h0)/se.dbar P<-2*pt(abs(t),df=length(tree$tip)-3,lower.tail=F) return(list(dbar=res$par[3],se=se.dbar,sig2=res$par[1],lambda=round(res$par[2],7),logL=res$value,t.dbar=t,P.dbar=P)) } phytools/R/densityMap.R0000644000176200001440000002201213050421724014567 0ustar liggesusers# function plots posterior density of mapped states from stochastic mapping # written by Liam J. Revell 2012, 2013, 2014, 2015, 2016 densityMap<-function(trees,res=100,fsize=NULL,ftype=NULL,lwd=3,check=FALSE,legend=NULL, outline=FALSE,type="phylogram",direction="rightwards",plot=TRUE,...){ if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(states)) states<-list(...)$states else states<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(length(lwd)==1) lwd<-rep(lwd,2) else if(length(lwd)>2) lwd<-lwd[1:2] tol<-1e-10 if(!inherits(trees,"multiPhylo")&&inherits(trees,"phylo")) stop("trees not \"multiPhylo\" object; just use plotSimmap.") if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") h<-sapply(unclass(trees),function(x) max(nodeHeights(x))) steps<-0:res/res*max(h) trees<-rescaleSimmap(trees,totalDepth=max(h)) if(check){ X<-matrix(FALSE,length(trees),length(trees)) for(i in 1:length(trees)) X[i,]<-sapply(trees,all.equal.phylo,current=trees[[i]]) if(!all(X)) stop("some of the trees don't match in topology or relative branch lengths") } tree<-trees[[1]] trees<-unclass(trees) if(is.null(states)) ss<-sort(unique(c(getStates(tree,"nodes"),getStates(tree,"tips")))) else ss<-states if(!all(ss==c("0","1"))){ c1<-paste(sample(c(letters,LETTERS),6),collapse="") c2<-paste(sample(c(letters,LETTERS),6),collapse="") trees<-lapply(trees,mergeMappedStates,ss[1],c1) trees<-lapply(trees,mergeMappedStates,ss[2],c2) trees<-lapply(trees,mergeMappedStates,c1,"0") trees<-lapply(trees,mergeMappedStates,c2,"1") } H<-nodeHeights(tree) message("sorry - this might take a while; please be patient") tree$maps<-vector(mode="list",length=nrow(tree$edge)) for(i in 1:nrow(tree$edge)){ YY<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(stepsH[i,1]),which(steps1){ for(k in 2:length(trees[[j]]$maps[[i]])){ XX[k,1]<-XX[k-1,2] XX[k,2]<-XX[k,1]+trees[[j]]$maps[[i]][k] } } for(k in 1:nrow(YY)){ lower<-which(XX[,1]<=YY[k,1]); lower<-lower[length(lower)] upper<-which(XX[,2]>=(YY[k,2]-tol))[1]; AA<-0 names(lower)<-names(upper)<-NULL if(!all(XX==0)){ for(l in lower:upper) AA<-AA+(min(XX[l,2],YY[k,2])-max(XX[l,1],YY[k,1]))/(YY[k,2]- YY[k,1])*as.numeric(rownames(XX)[l]) } else AA<-as.numeric(rownames(XX)[1]) ZZ[k]<-ZZ[k]+AA/length(trees) } } tree$maps[[i]]<-YY[,2]-YY[,1] names(tree$maps[[i]])<-round(ZZ*1000) } cols<-rainbow(1001,start=0.7,end=0); names(cols)<-0:1000 tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps) tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))] class(tree)<-c("simmap",setdiff(class(tree),"simmap")) x<-list(tree=tree,cols=cols,states=ss); class(x)<-"densityMap" if(plot) plot.densityMap(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline, type=type,mar=mar,direction=direction,offset=offset,hold=hold) invisible(x) } ## S3 plot method for objects of class "densityMap" ## also used internally by plot.contMap ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016 plot.densityMap<-function(x,...){ if(class(x)=="densityMap"){ tree<-x$tree cols<-x$cols } else stop("x should be an object of class \"densityMap\"") H<-nodeHeights(tree) # get & set optional arguments if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-FALSE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3 if(length(lwd)==1) lwd<-rep(lwd,2) else if(length(lwd)>2) lwd<-lwd[1:2] if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-c("0",paste("PP(state=",x$states[2],")",sep=""),"1") if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(is.null(legend)) legend<-0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") # done optional arguments if(legend){ if(legend>max(H)){ message("legend scale cannot be longer than total tree length; resetting") legend<-0.5*max(H) } } if(hold) null<-dev.hold() if(type=="phylogram"){ if(direction%in%c("upwards","downwards")&&legend){ par(mar=mar) plot.new() } N<-length(tree$tip.label) if(legend&&is.null(ylim)){ if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N) else { pp<-par("pin")[2] sw<-(fsize*(max(strwidth(x$tree$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches"))[1] alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else c(min(H)-0.16*max(H),max(H)+sw/alp) } } else if(is.null(ylim)) ylim<-NULL if(outline){ par(col="transparent") plotTree(tree,fsize=fsize[1],lwd=lwd[1]+2, offset=offset+0.2*lwd[1]/3+0.2/3,ftype=ftype[1],xlim=xlim, ylim=ylim,mar=mar,direction=direction,hold=FALSE, add=direction%in%c("upwards","downwards")&&legend) par(col="black") } plotSimmap(tree,cols,pts=FALSE,lwd=lwd[1],fsize=fsize[1],mar=mar,ftype=ftype[1],add=outline, xlim=xlim,ylim=ylim,direction=direction,offset=offset,hold=FALSE) if(legend){ ff<-function(dd){ if(!("."%in%dd)) dig<-0 else dig<-length(dd)-which(dd==".") dig } dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff)) if(direction%in%c("rightwards","leftwards")) add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]), digits=dig,prompt=FALSE,x=if(direction=="leftwards") max(H)-legend else 0, y=1-0.08*(N-1),lwd=lwd[2], fsize=fsize[2], direction=if(!is.null(xlim)) if(xlim[2]Ntip(tree)) root(tree,node=nn) else reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)]) fitMk(tt,yy,model=model,fixedQ=Q,output.liks=TRUE)$lik.anc[1,] } XX<-t(sapply(nn,ff)) if(tips) XX<-rbind(XX[1:n,],YY$lik.anc[1,],XX[(n+1):nrow(XX),]) else XX<-rbind(yy,YY$lik.anc[1,],XX) rownames(XX)<-1:(tree$Nnode+n) if(tips) rownames(XX)[1:n]<-tree$tip.label XX<-if(tips) XX else XX[1:tree$Nnode+n,] obj<-list(loglik=YY$logLik,Q=Q,marginal.anc=XX,tree=tree,x=yy) class(obj)<-"rerootingMethod" obj } print.rerootingMethod<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using re-rooting method\nof Yang et al. (1995):\n") if(is.null(printlen)) print(round(x$marginal.anc,digits)) else { print(round(x$marginal.anc[1:printlen,],digits)) cat("...\n") } cat("\nEstimated transition matrix,\nQ =\n") print(round(x$Q,digits)) cat("\n**Note that if Q is not symmetric the marginal\nreconstructions may be invalid.\n") cat(paste("\nLog-likelihood =",round(x$loglik,digits),"\n\n")) } plot.rerootingMethod<-function(x, ...){ args<-list(...) if(is.null(args$lwd)) args$lwd<-1 if(is.null(args$ylim)) args$ylim<-c(-0.1*Ntip(x$tree),Ntip(x$tree)) if(is.null(args$offset)) args$offset<-0.5 if(is.null(args$ftype)) args$ftype="i" args$tree<-x$tree do.call(plotTree,args) if(hasArg(piecol)) piecol<-list(...)$piecol else piecol<-setNames(colorRampPalette(c("blue", "yellow"))(ncol(x$marginal.anc)), colnames(x$marginal.anc)) if(hasArg(node.cex)) node.cex<-list(...)$node.cex else node.cex<-0.6 nodelabels(pie=x$marginal.anc[ as.character(1:x$tree$Nnode+Ntip(x$tree)),], piecol=piecol,cex=node.cex) if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex else tip.cex<-0.4 tiplabels(pie=x$x[x$tree$tip.label,],piecol=piecol, cex=tip.cex) legend(x=par()$usr[1],y=par()$usr[1], legend=colnames(x$marginal.anc), pch=21,pt.bg=piecol,pt.cex=2.2,bty="n") } logLik.rerootingMethod<-function(object,...) object$loglik phytools/R/estDiversity.R0000644000176200001440000000473012561714271015167 0ustar liggesusers# function computes an estimate of the standing diversity in each category given by x at each node # written by Liam J. Revell 2011-2013 estDiversity<-function(tree,x,method=c("asr","simulation"),model="ER",...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") method<-matchType(method[1],c("asr","simulation")) if(hasArg(nsim)) nsim<-list(...)$nsim else nsim=100 if(class(tree)!="phylo") stop("tree object must be of class 'phylo.'") if(method=="asr"){ tree<-reorder(tree,"cladewise") # reorder tree H<-nodeHeights(tree) if(!(model=="ER"||model=="SYM"||if(is.matrix(model)) isSymmetric(model) else FALSE)){ cat("Warning:\n only symmetric models allowed for method='asr'\n changing to model='ER'\n") model<-"ER" } bb<-rerootingMethod(tree,x,model=model) aa<-bb$marginal.anc Q<-bb$Q D<-matrix(0,nrow(aa),ncol(aa),dimnames=dimnames(aa)) # now loop through every node above the root message("Please wait. . . . Warning - this may take a while!") for(i in 2:nrow(aa)){ tt<-H[match(as.numeric(rownames(aa)[i]),tree$edge[,2]),2] ii<-H[,1]tt ee<-tree$edge[ii,2] hh<-H[ii,1] for(j in 1:length(ee)){ tr<-reroot(tree,node.number=ee[j],position=tt-hh[j]) D[i,]<-D[i,]+apeAce(tr,x[tr$tip.label],model=model,fixedQ=Q)$lik.anc[1,] } D[i,]<-D[i,]*aa[i,] if(i%%10==0) message(paste("Completed",i,"nodes")) } d<-rowSums(D) } else if(method=="simulation") { mtrees<-make.simmap(tree,x,nsim=nsim,model=model,message=FALSE) st<-sort(unique(x)); nn<-1:tree$Nnode+length(tree$tip) aa<-lapply(mtrees,function(x) describe.simmap(x,message=FALSE)$states) H<-nodeHeights(tree) D<-matrix(0,tree$Nnode,length(st),dimnames=list(nn,st)) CC<-lapply(mtrees,function(x) lapply(x$maps,cumsum)) # now loop through every node above the root message("Please wait. . . . Warning - this may take a while!") for(i in 2:tree$Nnode){ tt<-H[match(nn[i],tree$edge[,2]),2] ii<-H[,1]tt ee<-tree$edge[ii,2] hh<-H[ii,1] for(j in 1:length(ee)){ dd<-setNames(rep(0,length(st)),st) for(k in 1:nsim){ jj<-1; while((tt-hh[j])>CC[[k]][[which(tree$edge[,2]==ee[j])]][jj]) jj<-jj+1 ss<-names(mtrees[[k]]$maps[[which(tree$edge[,2]==ee[j])]])[jj] dd[ss]<-dd[ss]+ if(ss==aa[[k]][i]) 1/nsim else 0 } D[i,]<-D[i,]+dd } D[i,]<-D[i,] if(i%%10==0) message(paste("Completed",i,"nodes")) } d<-rowSums(D) } return(d) } phytools/R/fastAnc.R0000644000176200001440000000565012626403715014052 0ustar liggesusers## function does fast estimation of ML ancestral states using ace ## written by Liam J. Revell 2012, 2013, 2015 fastAnc<-function(tree,x,vars=FALSE,CI=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(length(class(tree)>1)) class(tree)<-"phylo" if(hasArg(anc.states)) anc.states<-list(...)$anc.states else anc.states<-NULL if(!is.null(anc.states)){ nodes<-as.numeric(names(anc.states)) tt<-tree for(i in 1:length(nodes)){ M<-matchNodes(tt,tree,method="distances",quiet=TRUE) ii<-M[which(M[,2]==nodes[i]),1] tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii) } x<-c(x,anc.states) } else tt<-tree if(!is.binary.tree(tt)) btree<-multi2di(tt) else btree<-tt M<-btree$Nnode N<-length(btree$tip.label) anc<-v<-vector() for(i in 1:M+N){ a<-multi2di(root(btree,node=i)) anc[i-N]<-ace(x,a,method="pic")$ace[1] names(anc)[i-N]<-i if(vars||CI){ picx<-pic(x,a,rescaled.tree=TRUE) b<-picx$rescaled.tree d<-which(b$edge[,1]==(length(b$tip.label)+1)) v[i-N]<-(1/b$edge.length[d[1]]+1/b$edge.length[d[2]])^(-1)*mean(picx$contr^2) names(v)[i-N]<-names(anc)[i-N] } } if(!is.binary.tree(tree)||!is.null(anc.states)){ ancNames<-matchNodes(tree,btree,method="distances",quiet=TRUE) anc<-anc[as.character(ancNames[,2])] names(anc)<-ancNames[,1] if(vars||CI){ v<-v[as.character(ancNames[,2])] names(v)<-ancNames[,1] } } obj<-list(ace=anc) if(vars) obj$var<-v if(CI){ obj$CI95<-cbind(anc-1.96*sqrt(v),anc+1.96*sqrt(v)) rownames(obj$CI95)<-names(anc) } if(length(obj)==1) obj<-obj$ace class(obj)<-"fastAnc" obj } ## print method for "fastAnc" ## written by Liam J. Revell 2015 print.fastAnc<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using fastAnc:\n") if(!is.list(x)){ if(is.null(printlen)||printlen>=length(x)) print(round(unclass(x),digits)) else printDotDot(unclass(x),digits,printlen) } else { Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) if(!is.null(x$var)){ cat("\nVariances on ancestral states:\n") if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits)) else printDotDot(x$var,digits,printlen) } if(!is.null(x$CI95)){ cat("\nLower & upper 95% CIs:\n") colnames(x$CI95)<-c("lower","upper") if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits)) else printDotDot(x$CI95,digits,printlen) } } cat("\n") } ## internal function ## written by Liam J. Revell 2015 printDotDot<-function(x,digits,printlen){ if(is.vector(x)){ x<-as.data.frame(t(as.matrix(unclass(round(x[1:printlen],digits))))) x<-cbind(x,"....") rownames(x)<-"" colnames(x)[printlen+1]<-"" print(x) } else if(is.matrix(x)){ x<-as.data.frame(rbind(round(x[1:printlen,],digits),c("....","...."))) print(x) } } phytools/R/phylANOVA.R0000644000176200001440000000615013201475366014231 0ustar liggesusers# function conducts phylogenetic ANOVA & posthoc tests # some code from phy.anova() in "geiger" # written by Liam Revell 2011, 2015, 2017 phylANOVA<-function(tree,x,y,nsim=1000,posthoc=TRUE,p.adj="holm"){ if(is.null(names(x))){ cat("Warning: no labels for x. Assuming order of tree$tip.label.\n\n") names(x)<-tree$tip.label } x<-x[tree$tip.label] if(is.null(names(y))){ cat("Warning: no labels for y. Assuming order of tree$tip.label.\n\n") names(y)<-tree$tip.label } y<-y[tree$tip.label] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") sig2<-mean(pic(y,multi2di(tree))^2) # compute BM rate for y x<-as.factor(x) # change x to factor m<-length(levels(x)) aov<-anova(lm(y~x)) F.obs<-aov[1,4] # F on empirical data if(posthoc) T.obs<-tTests(x,y) # empirical ts sims<-fastBM(tree,sig2=sig2,nsim=(nsim-1)) # simulate F.null<-vector() if(posthoc) T.null<-array(NA,dim=c(m,m,nsim),dimnames=list(levels(x),levels(x),NULL)) F.null[1]<-F.obs if(posthoc) T.null[,,1]<-T.obs for(i in 2:nsim){ F.null[i]<-anova(lm(sims[,i-1]~x))[1,4] if(posthoc) T.null[,,i]<-tTests(x,sims[,i-1]) } P.F<-sum(F.null>=F.obs)/nsim # p-value for F-test if(posthoc){ P.T<-matrix(NA,m,m,dimnames=list(levels(x),levels(x))) # uncorrected p-values from simulation for(i in 1:m) for(j in i:m){ P.T[i,j]<-sum(abs(T.null[i,j,])>=abs(T.obs[i,j]))/nsim P.T[j,i]<-P.T[i,j] } # control for multiple tests (if p.adj!="none") P.T[lower.tri(P.T)]<-p.adjust(P.T[lower.tri(P.T)],method=p.adj) for(i in 1:m) for(j in i:m) P.T[i,j]<-P.T[j,i] obj<-list(F=F.obs,Pf=P.F,T=T.obs,method=p.adj,Pt=P.T, "Sum Sq"=aov$"Sum Sq","Mean Sq"=aov$"Mean Sq") } else obj<-list(F=F.obs,Pf=P.F,"Sum Sq"=aov$"Sum Sq", "Mean Sq"=aov$"Mean Sq") class(obj)<-"phylANOVA" obj } # computes pairwise t-statistics with a pooled SD # some code from pairwise.t.test() in "stats" # written by Liam Revell 2011 tTests<-function(x,y){ if(!is.factor(x)) x<-as.factor(x) ybar<-tapply(y,x,mean,na.rm=TRUE) s<-tapply(y,x,sd,na.rm=TRUE) n<-tapply(!is.na(y),x,sum) m<-length(levels(x)) degf<-n-1 total.degf<-sum(degf) pooled.sd<-sqrt(sum(s^2*degf)/total.degf) compare.levels<-function(i,j){ dif<-ybar[i]-ybar[j] se.dif<-pooled.sd*sqrt(1/n[i]+1/n[j]) t.val<-dif/se.dif return(t.val) } T<-matrix(NA,m,m,dimnames=list(levels(x),levels(x))) for(i in 1:m) for(j in 1:m) T[i,j]<-compare.levels(levels(x)[i],levels(x)[j]) return(T) } ## S3 print method print.phylANOVA<-function(x,digits=6,...){ cat("ANOVA table: Phylogenetic ANOVA\n\n") cat("Response: y\n") object<-data.frame(round(x$"Sum Sq",digits), round(x$"Mean Sq",digits), c(round(x$F,digits),""), c(round(x$Pf,digits),"")) colnames(object)<-c("Sum Sq","Mean Sq","F value", "Pr(>F)") rownames(object)<-c("x","Residual") print(object) cat("\nP-value based on simulation.\n") cat("---------\n") cat("\n") if(!is.null(x$T)){ cat(paste("Pairwise posthoc test using method = \"", x$method,"\"\n\n",sep="")) cat("Pairwise t-values:\n") print(round(x$T,digits)) cat("\nPairwise corrected P-values:\n") print(round(x$Pt,digits)) cat("---------\n") cat("\n") } } phytools/R/pgls.Ives.R0000644000176200001440000001341713201622106014330 0ustar liggesusers## implements method of Ives et al. 2007 for PGLS regression with sampling error ## written by Liam J. Revell 2012, 2013, 2015 2017 pgls.Ives<-function(tree,X,y,Vx=NULL,Vy=NULL,Cxy=NULL,lower=c(1e-8,1e-8), fixed.b1=NULL){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") cat("\n") cat("---------------------------------------------------------------\n") cat("| **Warning: |\n") cat("| User reports suggest that this method may frequently |\n") cat("| fail to find the ML solution. Please use with caution. |\n") cat("---------------------------------------------------------------\n\n") # likelihood function lik<-function(theta,C,x,y,Mx,My,Mxy,fixed.b1=NULL){ sig2x<-theta[1] sig2y<-theta[2] b1<-if(is.null(fixed.b1)) theta[3] else fixed.b1 a<-theta[4:5] n<-nrow(C) Psi<-matrix(0,2*n,2*n) Psi[1:n,1:n]<-sig2x*C+diag(Mx) Psi[n+1:n,1:n]<-Psi[1:n,n+1:n]<-b1*sig2x*C+diag(Mxy) Psi[n+1:n,n+1:n]<-b1^2*sig2x*C+sig2y*C+diag(My) z<-c(X,y) D<-kronecker(diag(rep(1,2)),matrix(rep(1,n))) L<-dmnorm(z,(D%*%a)[,1],Psi,log=TRUE) return(-L) } # check data input format Xbar<-ybar<-NULL if((length(X)>length(unique(names(X))))&&is.null(Vx)){ a<-aggregate(X,by=list(names(X)),FUN=mean) Xbar<-setNames(a[,2],a[,1]) a<-aggregate(X,by=list(names(X)),FUN=var) Vx<-setNames(a[,2],a[,1]) nx<-summary(as.factor(names(X)))[names(Vx)] Vx<-Vx/nx if(any(is.na(Vx))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Vx[which(is.na(Vx))]<-mean(Vx*nx,na.rm=TRUE) } rm(a,nx) } if((length(y)>length(unique(names(y))))&&is.null(Vy)){ a<-aggregate(y,by=list(names(y)),FUN=mean) ybar<-setNames(a[,2],a[,1]) a<-aggregate(y,by=list(names(y)),FUN=var) Vy<-setNames(a[,2],a[,1]) ny<-summary(as.factor(names(y)))[names(Vy)] Vy<-Vy/ny if(any(is.na(Vy))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Vy[which(is.na(Vy))]<-mean(Vy*ny,na.rm=TRUE) } rm(a,ny) } if(is.null(Cxy)){ a<-aggregate(X,by=list(names(X)),FUN=mean); a<-setNames(a[,2],a[,1]) b<-aggregate(y,by=list(names(y)),FUN=mean); b<-setNames(b[,2],b[,1]) c<-(X-a[names(X)])*(y-b[names(y)]) d<-aggregate(c,by=list(names(c)),FUN=sum); d<-setNames(d[,2],d[,1]) nxy<-summary(as.factor(names(y)))[names(d)] Cxy<-d/(nxy-1)/nxy if(any(is.na(Cxy))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Cxy[which(is.na(Cxy))]<-mean(Cxy*nxy,na.rm=TRUE) } rm(a,b,c,nxy) } if(!is.null(Xbar)) X<-Xbar if(!is.null(ybar)) y<-ybar # perform calculation & organization C<-vcv.phylo(tree) X<-X[tree$tip.label] y<-y[tree$tip.label] Vx<-Vx[tree$tip.label] Vy<-Vy[tree$tip.label] Cxy<-Cxy[tree$tip.label] # get some reasonable starting values for optimization b<-if(is.null(fixed.b1)) runif(n=1,min=0,max=2)*lm(pic(y, tree)~pic(X,tree))$coefficients[2] else fixed.b1 names(b)<-NULL sig2x<-runif(n=1,min=0,max=2)*mean(pic(X,tree)^2) sig2y<-runif(n=1,min=0,max=2)*mean(pic(y,tree)^2) a<-runif(n=2,min=-1,max=1)*c(mean(X),mean(y)) # optimize regression model r<-optim(c(sig2x,sig2y,b,a),lik,C=C,x=X,y=y,Mx=Vx,My=Vy,Mxy=Cxy, fixed.b1=fixed.b1,method="L-BFGS-B", lower=c(lower,-Inf,-Inf,-Inf),control=list(factr=1e10)) k<-if(is.null(fixed.b1)) 5 else 4 if(all(Vx==0)) k<-k-1 if(all(Vy==0)) k<-k-1 # return r obj<-list(beta=c(r$par[5]-r$par[3]*r$par[4], if(is.null(fixed.b1)) r$par[3] else fixed.b1),sig2x=r$par[1], sig2y=r$par[2],a=r$par[4:5],logL=-r$value,convergence=r$convergence, message=r$message,df=c(k,Ntip(tree)-k)) class(obj)<-"pgls.Ives" obj } logLik.pgls.Ives<-function(object,...){ lik<-object$logL attr(lik,"df")<-object$df[1] lik } print.pgls.Ives<-function(x,digits=6,...){ cat("\nResult PGLS with sampling error in x & y") cat("\n (based on Ives et al. 2007):\n\n") cat("Response: y\n") object<-data.frame(x$beta[1],x$beta[2]) colnames(object)<-c("Intercept","beta[1]") rownames(object)<-"y" print(object) cat("\nSummary of ML estimated parameters:\n") object<-data.frame(round(c(x$sig2y,x$sig2x),digits), round(c(x$a[2:1]),digits),c(round(x$logL,digits),"")) colnames(object)<-c("sigma^2","a","log(L)") rownames(object)<-c("y","x") print(object) cat("---------\n") if(x$convergence==0) cat("\nR thinks it has converged.\n\n") else ("\nR may not have converged.\n\n") } ## simpler function to take sampling error into account for y only ## written by Liam J. Revell 2017 pgls.SEy<-function(model,data,corClass=corBrownian,tree=tree, se=NULL,method=c("REML","ML"),interval=c(0,1000),...){ corfunc<-corClass ## preliminaries data<-data[tree$tip.label,] if(is.null(se)) se<-setNames(rep(0,Ntip(tree)), tree$tip.label) ## likelihood function lk<-function(sig2e,data,tree,model,ve,corfunc){ tree$edge.length<-tree$edge.length*sig2e ii<-sapply(1:Ntip(tree),function(x,e) which(e==x), e=tree$edge[,2]) tree$edge.length[ii]<-tree$edge.length[ii]+ve[tree$tip.label] vf<-diag(vcv(tree)) w<-varFixed(~vf) COR<-corfunc(1,tree,...) fit<-gls(model,data=cbind(data,vf),correlation=COR,method=method,weights=w) -logLik(fit) } ## estimate sig2[e] fit<-optimize(lk,interval=interval, data=data,tree=tree,model=model,ve=se^2,corfunc=corfunc) tree$edge.length<-tree$edge.length*fit$minimum ii<-sapply(1:Ntip(tree),function(x,e) which(e==x), e=tree$edge[,2]) tree$edge.length[ii]<-tree$edge.length[ii]+ se[tree$tip.label]^2 vf<-diag(vcv(tree)) w<-varFixed(~vf) ## fit & return model gls(model,data=cbind(data,vf),correlation=corfunc(1,tree),weights=w, method=method) } phytools/R/compare.chronograms.R0000644000176200001440000000276113162731762016444 0ustar liggesusers## function to compare two time-trees ## written by Liam J. Revell 2017 compare.chronograms<-function(t1,t2,...){ if(hasArg(colors)) colors<-list(...)$colors else colors<-sapply(c("blue","red"),make.transparent,alpha=0.4) if(hasArg(arr.colors)) arr.colors<-list(...)$arr.colors else arr.colors<-sapply(c("blue","red"),make.transparent,alpha=0.7) h1<-sapply(1:Ntip(t1),nodeheight,tree=t1) h2<-sapply(1:Ntip(t2),nodeheight,tree=t2) plotTree(if(max(h1)>max(h2)) t1 else t2,plot=FALSE, mar=c(4.1,1.1,1.1,1.1),direction="leftwards") xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] par(fg="transparent",new=TRUE) plotTree(t1,color=colors[1],mar=c(4.1,1.1,1.1,1.1), xlim=xlim,direction="leftwards",lwd=3) T1<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="black") axis(1) par(fg="transparent") plotTree(t2,color=colors[2],mar=c(4.1,1.1,1.1,1.1), xlim=xlim,add=TRUE,direction="leftwards",ftype="off",lwd=3) T2<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="black") for(i in 1:t1$Nnode+Ntip(t1)){ arrows(T1$xx[i],T1$yy[i],T2$xx[i],T2$yy[i],lwd=2, col=if(T1$xx[i]>T2$xx[i]) arr.colors[2] else arr.colors[1], length=0.1) } h<-mapply(function(x,y) if(xmin(h)) 0.005*diff(xlim) else 0,min(h)), rep(T1$yy[i],2),lty="dotted") } phytools/R/optim.phylo.ls.R0000644000176200001440000000636012606754473015401 0ustar liggesusers# function performs least-squares phylogeny inference by nni # written by Liam J. Revell 2011, 2013, 2015 optim.phylo.ls<-function(D,stree=NULL,set.neg.to.zero=TRUE,fixed=FALSE,tol=1e-10,collapse=TRUE){ # change D to a matrix (if actually an object of class "dist") if(class(D)=="dist") D<-as.matrix(D) # compute the number of species n<-nrow(D) if(is.null(stree)) stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree else if(!inherits(stree,"phylo")){ cat("starting tree must be an object of class \"phylo.\" using random starting tree.\n") stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree } if(!is.binary.tree(stree)) stree<-multi2di(stree) if(is.rooted(stree)) stree<-unroot(stree) # get ls branch lengths for stree best.tree<-ls.tree(stree,D) Q<-attr(best.tree,"Q-score") bestQ<-0 # to start the loop # for search Nnni<-0 # loop while Q is not improved by nni while(bestQ-Q=0),which(obj$xx[d]<0)) deg[ii]<-180+deg[ii] ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]<0)) deg[ii]<-180+deg[ii] ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]>=0)) deg[ii]<-360+deg[ii] draw.arc(x=0,y=0,radius=ln.offset*h,deg1=min(deg), deg2=max(deg),lwd=lwd,col=col,lend=lend,n=n) if(orientation=="curved") arctext(text,radius=lab.offset*h, middle=mean(range(deg*pi/180)),cex=cex, clockwise=clockwise) else if(orientation=="horizontal"){ x0<-lab.offset*cos(median(deg)*pi/180)*h y0<-lab.offset*sin(median(deg)*pi/180)*h text(x=x0,y=y0,label=text, adj=c(if(x0>=0) 0 else 1,if(y0>=0) 0 else 1), offset=0,cex=cex) } } ## function to return a node index interactively from a plotted tree ## written by Liam J. Revell 2017 getnode<-function(...){ if(hasArg(env)) env<-list(...)$env else env<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(hasArg(show.pt)) show.pt<-list(...)$show.pt else show.pt<-FALSE xy<-unlist(locator(n=1)) if(show.pt) points(xy[1],xy[2]) d<-sqrt((xy[1]-env$xx)^2+(xy[2]-env$yy)^2) ii<-which(d==min(d))[1] ii } ## function mostly to interactively label nodes by clicking ## written by Liam J. Revell 2017 labelnodes<-function(text,node=NULL,interactive=TRUE, shape=c("circle","ellipse","rect"),...){ shape<-shape[1] if(hasArg(circle.exp)) circle.exp<-list(...)$circle.exp else circle.exp<-1.3 if(hasArg(rect.exp)) rect.exp<-list(...)$rect.exp else rect.exp<-1.6 if(hasArg(cex)) cex<-list(...)$cex else cex<-1 obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-cex*strheight("A") w<-cex*strwidth(text) rad<-circle.exp*h*diff(par()$usr[1:2])/diff(par()$usr[3:4]) if(is.null(node)){ if(!interactive){ cat("No nodes provided. Setting interactive mode to TRUE.\n") interactive<-TRUE } node<-vector(length=length(text)) } for(i in 1:length(text)){ if(interactive){ cat(paste("Click on the node you would like to label ", text[i],".\n",sep="")) flush.console() ii<-getnode(env=obj) node[i]<-ii } else ii<-node[i] if(shape=="circle") draw.circle(obj$xx[ii],obj$yy[ii],rad,col="white") else if(shape=="ellipse") draw.ellipse(obj$xx[ii],obj$yy[ii],0.8*w[i],h, col="white") else if(shape=="rect") rect(xleft=obj$xx[ii]-0.5*rect.exp*w[i], ybottom=obj$yy[ii]-0.5*rect.exp*h, xright=obj$xx[ii]+0.5*rect.exp*w[i], ytop=obj$yy[ii]+0.5*rect.exp*h,col="white", ljoin=1) text(obj$xx[ii],obj$yy[ii],label=text[i],cex=cex) } invisible(node) } ## convert object of class "birthdeath" into birth & death rates bd<-function(x){ if(class(x)!="birthdeath") stop("x should be an object of class 'birthdeath'") b<-x$para[2]/(1-x$para[1]) d<-b-x$para[2] setNames(c(b,d),c("b","d")) } ## compute AIC weights aic.w<-function(aic){ d.aic<-aic-min(aic) x<-exp(-1/2*d.aic)/sum(exp(-1/2*d.aic)) class(x)<-"aic.w" x } print.aic.w<-function(x,...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-8 print(round(unclass(x),signif)) } ## function to compute all paths towards the tips from a node ## written by Liam J. Revell node.paths<-function(tree,node){ d<-Descendants(tree,node,"children") paths<-as.list(d) while(any(d>Ntip(tree))){ jj<-1 new.paths<-list() for(i in 1:length(paths)){ if(paths[[i]][length(paths[[i]])]<=Ntip(tree)){ new.paths[[jj]]<-paths[[i]] jj<-jj+1 } else { ch<-Descendants(tree,paths[[i]][length(paths[[i]])], "children") for(j in 1:length(ch)){ new.paths[[jj]]<-c(paths[[i]],ch[j]) jj<-jj+1 } } } paths<-new.paths d<-sapply(paths,function(x) x[length(x)]) } paths } ## function to compute a modification of Grafen's edge lengths ## written by Liam J. Revell 2016 modified.Grafen<-function(tree,power=2){ max.np<-function(tree,node){ np<-node.paths(tree,node) if(length(np)>0) max(sapply(np,length)) else 0 } nn<-1:(Ntip(tree)+tree$Nnode) h<-sapply(nn,max.np,tree=tree)+1 h<-(h/max(h))^power edge.length<-vector() for(i in 1:nrow(tree$edge)) edge.length[i]<-diff(h[tree$edge[i,2:1]]) tree$edge.length<-edge.length tree } ## function to compute all rotations ## written by Liam J. Revell 2016 allRotations<-function(tree){ if(!is.binary.tree(tree)){ was.binary<-FALSE if(is.null(tree$edge.length)){ tree<-compute.brlen(tree) had.edge.lengths<-FALSE } else had.edge.lengths<-TRUE tree<-multi2di(tree) } else was.binary<-TRUE nodes<-1:tree$Nnode+Ntip(tree) trees<-vector(mode="list",length=2^length(nodes)) ii<-2 trees[[1]]<-tree for(i in 1:length(nodes)){ N<-ii-1 for(j in 1:N){ trees[[ii]]<-rotate(trees[[j]],nodes[i]) ii<-ii+1 } } trees<-lapply(trees,untangle,"read.tree") if(!was.binary){ trees<-lapply(trees,di2multi) if(!had.edge.lengths) trees<-lapply(trees, function(x){ x$edge.length<-NULL x }) } class(trees)<-"multiPhylo" trees } ## function to rotate a multifurcation in all possible ways ## written by Liam J. Revell 2016 rotate.multi<-function(tree,node){ kids<-Children(tree,node) if(length(kids)>2){ ii<-sapply(kids,function(x,y) which(y==x),y=tree$edge[,2]) jj<-permn(ii) foo<-function(j,i,t){ t$edge[i,]<-t$edge[j,] if(!is.null(t$edge.length)) t$edge.length[i]<-t$edge.length[j] untangle(t,"read.tree") } obj<-lapply(jj[2:length(jj)],foo,i=ii,t=tree) class(obj)<-"multiPhylo" } else obj<-untangle(rotate(tree,node),"read.tree") obj } ## wrapper for bind.tree that takes objects of class "simmap" ## written by Liam J. Revell 2016 bind.tree.simmap<-function(x,y,where="root"){ x<-reorder(x) y<-reorder(y) rootx<-x$edge[1,1] rooty<-y$edge[1,1] xy<-read.tree(text=write.tree(bind.tree(x,y,where))) Mx<-rbind(matchLabels(x,xy),matchNodes(x,xy,"distances")) My<-rbind(matchLabels(y,xy),matchNodes(y,xy,"distances")) if(where!="root"&&where<=Ntip(x)) Mx[which(is.na(Mx[,2])),2]<-findMRCA(xy,y$tip.label) xy$maps<-vector(mode="list",length=nrow(xy$edge)) ix<-sapply(Mx[-which(Mx[,1]==rootx),1], function(x,y) which(y==x),y=x$edge[,2]) ixy<-sapply(Mx[-which(Mx[,1]==rootx),2], function(x,y) which(y==x),y=xy$edge[,2]) xy$maps[ixy]<-x$maps[ix] iy<-sapply(My[-which(My[,1]==rooty),1], function(x,y) which(y==x),y=y$edge[,2]) ixy<-sapply(My[-which(My[,1]==rooty),2], function(x,y) which(y==x),y=xy$edge[,2]) xy$maps[ixy]<-y$maps[iy] xy$mapped.edge<-makeMappedEdge(xy$edge,xy$maps) ns<-c(setNames(getStates(xy,"tips"),1:Ntip(xy)), getStates(xy,"nodes")) xy$node.states<-cbind(ns[as.character(xy$edge[,1])], ns[as.character(xy$edge[,2])]) xy$states<-getStates(xy,"tips") attr(xy,"class")<-c("simmap",class(xy)) xy } ## generic function to convert an object of class "simmap" to "phylo" ## written by Liam J. Revell 2016 as.phylo.simmap<-function(x,...){ x$maps<-NULL x$mapped.edge<-NULL if(!is.null(x$node.states)) x$node.states<-NULL if(!is.null(x$states)) x$states<-NULL if(!is.null(x$Q)) x$Q<-NULL if(!is.null(x$logL)) x$logL<-NULL if(!is.null(attr(x,"map.order"))) attr(x,"map.order")<-NULL class(x)<-setdiff(class(x),"simmap") x } ## generic function to convert an object of class "multiSimmap" to "multiPhylo" ## written by Liam J. Revell 2016 as.multiPhylo.multiSimmap<-function(x,...){ obj<-lapply(x,as.phylo) class(obj)<-setdiff(class(x),"multiSimmap") obj } ## generic function to convert object of class "phylo" to "multiPhylo" ## written by Liam J. Revell 2016 as.multiPhylo.phylo<-function(x,...){ obj<-list(x) class(obj)<-"multiPhylo" obj } as.multiPhylo<-function(x,...){ if (identical(class(x),"multiPhylo")) return(x) UseMethod("as.multiPhylo") } ## get mapped states ## written by Liam J. Revell 2016 mapped.states<-function(tree,...){ if(!(inherits(tree,"simmap")||inherits(tree,"multiSimmap"))) stop("tree should be an object of class \"simmap\" or \"multiSimmap\".") else { if(inherits(tree,"simmap")){ if(!is.null(tree$mapped.edge)) obj<-sort(colnames(tree$mapped.edge)) else obj<-sort(unique(unlist(lapply(tree$maps,function(x) names(x))))) } else if(inherits(tree,"multiSimmap")) { obj<-sapply(tree,mapped.states,...) } } obj } ## match labels between trees (equivalent to matchNodes) ## written by Liam J. Revell 2016 matchLabels<-function(tr1,tr2){ foo<-function(x,y) if(length(obj<-which(y==x))>0) obj else NA M<-cbind(1:Ntip(tr1),sapply(tr1$tip.label,foo,y=tr2$tip.label)) colnames(M)<-c("tr1","tr2") M } ## compute the probability of states changes along edges of the tree ## written by Liam J. Revell 2015 edgeProbs<-function(trees){ if(!inherits(trees,"multiSimmap")) stop("trees should be an object of class \"multiSimmap\".") SS<-sapply(trees,getStates,"tips") states<-sort(unique(as.vector(SS))) m<-length(states) TT<-sapply(states,function(x,y) sapply(y,paste,x,sep="->"), y=states) nn<-c(TT[upper.tri(TT)],TT[lower.tri(TT)]) ## this function computes for a given edge fn<-function(edge,trees,states){ obj<-sapply(trees,function(x,e,s) if(names(x$maps[[e]])[1]== s[1]&&names(x$maps[[e]])[length(x$maps[[e]])]==s[2]) TRUE else FALSE,e=edge,s=states) sum(obj)/length(obj) } edge.probs<-matrix(0,nrow(trees[[1]]$edge),m, dimnames=list(apply(trees[[1]]$edge,1,paste,collapse=","),nn)) k<-1 for(i in 1:m) for(j in 1:m){ if(i!=j){ edge.probs[,k]<-sapply(1:nrow(trees[[1]]$edge),fn, trees=trees,states=states[c(i,j)]) k<-k+1 } } edge.probs<-cbind(edge.probs,1-rowSums(edge.probs)) colnames(edge.probs)[ncol(edge.probs)]<-"no change" edge.probs } ## get a position in the tree interactively ## written by Liam J. Revell 2015, 2016 get.treepos<-function(message=TRUE,...){ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(obj$type=="phylogram"&&obj$direction=="rightwards"){ if(message){ cat("Click on the tree position you want to capture...\n") flush.console() } if(hasArg(x)) x<-list(...)$x else x<-NULL if(hasArg(y)) y<-list(...)$y else y<-NULL if(is.null(x)||is.null(y)){ x<-unlist(locator(1)) y<-x[2] x<-x[1] } d<-pos<-c() for(i in 1:nrow(obj$edge)){ x0<-obj$xx[obj$edge[i,]] y0<-obj$yy[obj$edge[i,2]] if(xx0[2]){ d[i]<-min(dist(rbind(c(x,y),c(x0[1],y0))), dist(rbind(c(x,y),c(x0[2],y0)))) pos[i]<-if(x>x0[2]) 0 else diff(obj$xx[obj$edge[i,]]) } else { d[i]<-abs(y0-y) pos[i]<-obj$xx[obj$edge[i,2]]-x } } ii<-which(d==min(d)) list(where=obj$edge[ii,2],pos=pos[ii]) } else stop("Does not work for the plotted tree type.") } ## fastDist: uses fastHeight to compute patristic distance between a pair of species fastDist<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$edge.length)) stop("tree should have edge lengths.") if(sp1==sp2) 0 else fastHeight(tree,sp1,sp1)+fastHeight(tree,sp2,sp2)- 2*fastHeight(tree,sp1,sp2) } # function reorders simmap tree # written Liam Revell 2011, 2013, 2015 reorderSimmap<-function(tree,order="cladewise",index.only=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ii<-reorder.phylo(tree,order,index.only=TRUE,...) if(!index.only){ if(inherits(ii,"phylo")) ii<-whichorder(ii$edge[,2],tree$edge[,2]) ## bug workaround tree$edge<-tree$edge[ii,] tree$edge.length<-tree$edge.length[ii] if(!is.null(tree$maps)){ tree$maps<-tree$maps[ii] tree$mapped.edge<-tree$mapped.edge[ii,] } attr(tree,"order")<-order return(tree) } else return(ii) } ## S3 reorder method for objects of class "simmap" reorder.simmap<-function(x,...) reorderSimmap(x,...) # function whichorder # written by Liam Revell 2011, 2013, 2015 whichorder<-function(x,y) sapply(x,function(x,y) which(x==y),y=y) # function returns random state with probability given by y # written by Liam J. Revell 2013, 2015 rstate<-function(y){ if(length(y)==1) return(names(y)[1]) else { p<-y/sum(y) if(any(p<0)){ warning("Some probabilities (slightly?) < 0. Setting p < 0 to zero.") p[p<0]<-0 } return(names(which(rmultinom(1,1,p)[,1]==1))) } } ## mark the changes on a plotted "simmap" object ## written by Liam J. Revell 2015 markChanges<-function(tree,colors=NULL,cex=1,lwd=2,plot=TRUE){ states<-sort(unique(getStates(tree))) if(is.null(colors)) colors<-setNames(palette()[1:length(states)], states) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) nc<-sapply(tree$maps,length)-1 ii<-which(nc>0) nc<-nc[ii] xx<-yy<-vector() for(i in 1:length(ii)){ for(j in 1:nc[i]){ ss<-names(tree$maps[[ii[i]]])[j+1] mm<-tree$edge[ii[i],1] dd<-tree$edge[ii[i],2] x<-rep(obj$xx[mm]+cumsum(tree$maps[[ii[i]]])[j],2) y<-c(obj$yy[dd]-0.5*mean(strheight(LETTERS)*cex), obj$yy[dd]+0.5*mean(strheight(LETTERS)*cex)) if(plot) lines(x,y,lwd=lwd,col=colors[ss],lend=2) xx<-c(xx,setNames(x[1], paste(names(tree$maps[[ii[i]]])[j:(j+1)], collapse="->"))) yy<-c(yy,mean(y)) } } XY<-cbind(xx,yy) colnames(XY)<-c("x","y") invisible(XY) } ## function to label clades ## written by Liam J. Revell 2014, 2015 cladelabels<-function(tree=NULL,text,node,offset=NULL,wing.length=NULL,cex=1, orientation="vertical"){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(is.null(tree)){ wing.length<-1 if(is.null(offset)) offset<-8 tree<-list(edge=lastPP$edge, tip.label=1:lastPP$Ntip, Nnode=lastPP$Nnode) H<-matrix(lastPP$xx[tree$edge],nrow(tree$edge),2) tree$edge.length<-H[,2]-H[,1] class(tree)<-"phylo" } if(is.null(offset)) offset<-0.5 xx<-mapply(labelSubTree,node,text, MoreArgs=list(tree=tree,pp=lastPP,offset=offset,wl=wing.length,cex=cex, orientation=orientation)) } ## internal function used by cladelabels ## written by Liam J. Revell 2014, 2015 labelSubTree<-function(tree,nn,label,pp,offset,wl,cex,orientation){ if(is.null(wl)) wl<-1 tree<-reorder(tree) tips<-getDescendants(tree,nn) tips<-tips[tips<=length(tree$tip.label)] ec<-0.7 ## expansion constant sw<-pp$cex*max(strwidth(tree$tip.label[tips])) sh<-pp$cex*max(strheight(tree$tip.label)) cw<-mean(strwidth(LETTERS)*cex) h<-max(sapply(tips,function(x,tree) nodeHeights(tree)[which(tree$edge[,2]==x),2], tree=tree))+sw+offset*cw y<-range(pp$yy[tips]) lines(c(h,h),y+ec*c(-sh,sh)) lines(c(h-wl*cw,h), c(y[1]-ec*sh,y[1]-ec*sh)) lines(c(h-wl*cw,h), c(y[2]+ec*sh,y[2]+ec*sh)) text(h+cw,mean(y), label,srt=if(orientation=="horizontal") 0 else 90, adj=if(orientation=="horizontal") 0 else 0.5,cex=cex) } ## get all the extant/extinct tip names ## written by Liam J. Revell 2012, 2015 getExtant<-function(tree,tol=1e-8){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") H<-nodeHeights(tree) tl<-max(H) x<-which(H[,2]>=(tl-tol)) y<-tree$edge[x,2] y<-y[y<=length(tree$tip)] z<-tree$tip.label[y] return(z) } getExtinct<-function(tree,tol=1e-8) setdiff(tree$tip.label,getExtant(tree,tol)) # function splits tree at split # written by Liam Revell 2011, 2014, 2015 splitTree<-function(tree,split){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(split$node>length(tree$tip.label)){ # first extract the clade given by shift$node tr2<-extract.clade(tree,node=split$node) tr2$root.edge<-tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp #now remove tips in tr2 from tree tr1<-drop.clade(tree,tr2$tip.label) nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA" tr1$tip.label[which(tr1$tip.label%in%nn)]<-"NA" tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-split$bp } else { # first extract the clade given by shift$node tr2<-list(edge=matrix(c(2L,1L),1,2),tip.label=tree$tip.label[split$node],edge.length=tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp,Nnode=1L) class(tr2)<-"phylo" # now remove tip in tr2 from tree tr1<-tree tr1$edge.length[match(which(tr1$tip.label==tr2$tip.label[1]),tr1$edge[,2])]<-split$bp tr1$tip.label[which(tr1$tip.label==tr2$tip.label[1])]<-"NA" } trees<-list(tr1,tr2) class(trees)<-"multiPhylo" trees } # function drops entire clade # written by Liam Revell 2011, 2015 drop.clade<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA" tree<-drop.tip(tree,tip,trim.internal=FALSE) while(sum(tree$tip.label%in%nn)>1) tree<-drop.tip(tree,tree$tip.label[tree$tip.label%in%nn], trim.internal=FALSE) tree } ## function to re-root a phylogeny along an edge ## written by Liam J. Revell 2011-2016 reroot<-function(tree,node.number,position=NULL,interactive=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(interactive){ plotTree(tree,...) cat("Click where you would like re-root the plotted tree\n") flush.console() obj<-get.treepos(message=FALSE) node.number<-obj$where position<-tree$edge.length[which(tree$edge[,2]==node.number)]-obj$pos } if(is.null(position)) position<-tree$edge.length[which(tree$edge[,2]==node.number)] tt<-splitTree(tree,list(node=node.number,bp=position)) p<-tt[[1]] d<-tt[[2]] tip<-if(length(which(p$tip.label=="NA"))>0) "NA" else p$tip.label[which(p$tip.label%in%tree$node.label)] p<-root(p,outgroup=tip,resolve.root=T) bb<-which(p$tip.label==tip) p$tip.label[bb]<-"NA" ee<-p$edge.length[which(p$edge[,2]==bb)] p$edge.length[which(p$edge[,2]==bb)]<-0 cc<-p$edge[which(p$edge[,2]==bb),1] dd<-setdiff(p$edge[which(p$edge[,1]==cc),2],bb) p$edge.length[which(p$edge[,2]==dd)]<-p$edge.length[which(p$edge[,2]==dd)]+ee obj<-paste.tree(p,d) if(interactive) plotTree(obj,...) obj } ## function to add an arrow pointing to a tip or node in the tree ## written by Liam J. Revell 2014, 2017 add.arrow<-function(tree=NULL,tip,...){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!is.null(tree)){ if(inherits(tree,"contMap")) tree<-tree$tree else if(inherits(tree,"densityMap")) tree<-tree$tree } if(is.numeric(tip)){ ii<-tip if(!is.null(tree)&&ii<=length(tree$tip.label)) tip<-tree$tip.label[ii] else tip<-"" } else if(is.character(tip)&&!is.null(tree)) ii<-which(tree$tip.label==tip) if(hasArg(offset)) offset<-list(...)$offset else offset<-1 strw<-lastPP$cex*(strwidth(tip)+offset*mean(strwidth(c(LETTERS,letters)))) if(hasArg(arrl)) arrl<-list(...)$arrl else { if(lastPP$type=="fan") arrl<-0.3*max(lastPP$xx) else if(lastPP$type=="phylogram") arrl<-0.15*max(lastPP$xx) } if(hasArg(hedl)) hedl<-list(...)$hedl else hedl<-arrl/3 if(hasArg(angle)) angle<-list(...)$angle else angle<-45 arra<-angle*pi/180 asp<-if(lastPP$type=="fan") 1 else (par()$usr[4]-par()$usr[3])/(par()$usr[2]-par()$usr[1]) if(hasArg(col)) col<-list(...)$col else col<-"black" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(lastPP$type=="fan") theta<-atan2(lastPP$yy[ii],lastPP$xx[ii]) else if(lastPP$type=="phylogram") theta<-0 segments(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta+arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta+arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta-arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta-arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") invisible(list(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw)) } ## function to ladderize phylogeny with mapped discrete character ## written by Liam J. Revell 2014, 2015 ladderize.simmap<-function(tree,right=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") obj<-read.tree(text=write.tree(ladderize(tree,right=right))) rN<-Ntip(obj)+1 T<-cbind(1:Ntip(obj),sapply(obj$tip.label,function(x,y) which(y==x),y=tree$tip.label)) N<-matchNodes(obj,tree) M<-rbind(T,N[N[,1]!=rN,]) ii<-sapply(M[,1],function(x,y) which(y==x),y=obj$edge[,2]) jj<-sapply(M[,2],function(x,y) which(y==x),y=tree$edge[,2]) obj$maps<-vector(length=nrow(tree$edge),mode="list") obj$mapped.edge<-matrix(NA,nrow(tree$edge),ncol(tree$mapped.edge), dimnames=list(apply(tree$edge,1,paste,collapse=","), colnames(tree$mapped.edge))) if(!is.null(tree$states)) obj$states<-tree$states[sapply(obj$tip.label,function(x,y) which(y==x),y=tree$tip.label)] if(!is.null(tree$node.states)) obj$node.states<-matrix(NA,nrow(tree$edge),2) for(i in 1:length(ii)){ obj$maps[[ii[i]]]<-tree$maps[[jj[i]]] obj$mapped.edge[ii[i],]<-tree$mapped.edge[jj[i],] if(!is.null(tree$node.states)) obj$node.states[ii[i],]<-tree$node.states[jj[i],] } obj } ## for backward compatibility repPhylo<-function(tree,times) rep(tree,times) ## S3 method rep for objects of class "phylo" and "multiPhylo" ## written by Liam J. Revell 2014 rep.phylo<-function(x,...){ if(hasArg(times)) times<-list(...)$times else times<-(...)[[1]] for(i in 1:times) obj<-if(i==1) x else if(i==2) c(obj,x) else c(obj,list(x)) class(obj)<-"multiPhylo" obj } rep.multiPhylo<-function(x,...){ if(hasArg(times)) times<-list(...)$times else times<-(...)[[1]] for(i in 1:times) obj<-if(i==1) x else if(i>=2) c(obj,x) class(obj)<-"multiPhylo" obj } ## function to rescale simmap style trees ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2017 rescaleSimmap<-function(tree,...){ if(inherits(tree,"multiPhylo")){ cls<-class(tree) trees<-unclass(tree) trees<-lapply(trees,rescaleSimmap,...) class(trees)<-cls return(trees) } else if(inherits(tree,"phylo")){ if(hasArg(lambda)) lambda<-list(...)$lambda else lambda<-1 if(hasArg(totalDepth)) depth<-totalDepth<-list(...)$totalDepth else if(hasArg(depth)) depth<-totalDepth<-list(...)$depth else depth<-totalDepth<-max(nodeHeights(tree)) if(lambda!=1){ e<-lambdaTree(tree,lambda)$edge.length/tree$edge.length tree$edge.length<-tree$edge.length*e tree$maps<-mapply(function(x,y) x*y,tree$maps,e) tree$mapped.edge<-tree$mapped.edge*matrix(rep(e,ncol(tree$mapped.edge)),length(e),ncol(tree$mapped.edge)) } if(depth!=max(nodeHeights(tree))){ h<-max(nodeHeights(tree)) s<-depth/h tree$edge.length<-tree$edge.length*s tree$maps<-lapply(tree$maps,"*",s) tree$mapped.edge<-tree$mapped.edge*s } return(tree) } else message("tree should be an object of class \"phylo\" or \"multiPhylo\"") } ## function to drop one or more tips from a tree but retain all ancestral nodes as singletons ## written by Liam J. Revell 2014, 2015 drop.tip.singleton<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") N<-Ntip(tree) m<-length(tip) ii<-sapply(tip,function(x,y) which(y==x),y=tree$tip.label) tree$tip.label<-tree$tip.label[-ii] ii<-sapply(ii,function(x,y) which(y==x),y=tree$edge[,2]) tree$edge<-tree$edge[-ii,] tree$edge.length<-tree$edge.length[-ii] tree$edge[tree$edge<=N]<-as.integer(rank(tree$edge[tree$edge<=N])) tree$edge[tree$edge>N]<-tree$edge[tree$edge>N]-m N<-N-m if(any(sapply(tree$edge[tree$edge[,2]>N,2],"%in%",tree$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE while(internal){ ii<-which(sapply(tree$edge[,2],"%in%",c(1:N,tree$edge[,1]))==FALSE)[1] nn<-tree$edge[ii,2] tree$edge<-tree$edge[-ii,] tree$edge.length<-tree$edge.length[-ii] tree$edge[tree$edge>nn]<-tree$edge[tree$edge>nn]-1 tree$Nnode<-tree$Nnode-length(ii) if(any(sapply(tree$edge[tree$edge[,2]>N,2],"%in%",tree$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE } tree } ## S3 print method for object of class 'describe.simmap' ## written by Liam J. Revell 2014, 2015 print.describe.simmap<-function(x,...){ if(inherits(x$tree,"multiPhylo")){ cat(paste(length(x$tree),"trees with a mapped discrete character with states:\n",paste(colnames(x$ace),collapse=", "),"\n\n")) cat(paste("trees have",colMeans(x$count)["N"],"changes between states on average\n\n")) cat(paste("changes are of the following types:\n")) aa<-t(as.matrix(colMeans(x$count)[2:ncol(x$count)])) rownames(aa)<-"x->y" print(aa) cat(paste("\nmean total time spent in each state is:\n")) print(matrix(c(colMeans(x$times),colMeans(x$times[,1:ncol(x$times)]/x$times[,ncol(x$times)])),2,ncol(x$times),byrow=TRUE, dimnames=list(c("raw","prop"),c(colnames(x$times))))) cat("\n") } else if(inherits(x$tree,"phylo")){ cat(paste("1 tree with a mapped discrete character with states:\n",paste(colnames(x$Tr),collapse=", "),"\n\n")) cat(paste("tree has",x$N,"changes between states\n\n")) cat(paste("changes are of the following types:\n")) print(x$Tr) cat(paste("\nmean total time spent in each state is:\n")) print(x$times) cat("\n") } } ## S3 plot method for object of class 'describe.simmap' ## written by Liam J. Revell 2014, 2015 plot.describe.simmap<-function(x,...){ if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(cex)) cex<-list(...)$cex else cex<-c(0.6,0.4) if(length(cex)==1) cex<-rep(cex,2) if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(inherits(x$tree,"multiPhylo")){ states<-colnames(x$ace) if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(palette()[1:length(states)],states) plotTree(if(is.null(x$ref.tree)) x$tree[[1]] else x$ref.tree,lwd=lwd, offset=cex[2],...) nodelabels(pie=x$ace,piecol=colors[colnames(x$ace)],cex=cex[1]) if(!is.null(x$tips)) tips<-x$tips else tips<-to.matrix(getStates(x$tree[[1]],"tips"), seq=states) tiplabels(pie=tips[if(is.null(x$ref.tree)) x$tree[[1]]$tip.label else x$ref.tree$tip.label,],piecol=colors[colnames(tips)],cex=cex[2]) } else if(inherits(x$tree,"phylo")){ states<-colnames(x$Tr) if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(palette()[1:length(states)],states) plotSimmap(x$tree,lwd=lwd,colors=colors,type=type) } } # function to summarize the results of stochastic mapping # written by Liam J. Revell 2013, 2014, 2015 describe.simmap<-function(tree,...){ if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-FALSE if(hasArg(message)) message<-list(...)$message else message<-FALSE if(hasArg(ref.tree)) ref.tree<-list(...)$ref.tree else ref.tree<-NULL if(inherits(tree,"multiPhylo")){ if(check.equal){ TT<-sapply(tree,function(x,y) sapply(y,all.equal.phylo,x),y=tree) check<-all(TT) if(!check) cat("Note: Some trees are not equal.\nA \"reference\" tree will be computed if none was provided.\n\n") } else check<-TRUE YY<-getStates(tree) states<-sort(unique(as.vector(YY))) if(is.null(ref.tree)&&check) ZZ<-t(apply(YY,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,Nsim=length(tree))) else { if(is.null(ref.tree)){ cat("No reference tree provided & some trees are unequal.\nComputing majority-rule consensus tree.\n") ref.tree<-consensus(tree,p=0.5) } YYp<-matrix(NA,ref.tree$Nnode,length(tree),dimnames=list(1:ref.tree$Nnode+Ntip(ref.tree),NULL)) for(i in 1:length(tree)){ M<-matchNodes(ref.tree,tree[[i]]) jj<-sapply(M[,2],function(x,y) if(x%in%y) which(as.numeric(y)==x) else NA,y=as.numeric(rownames(YY))) YYp[,i]<-YY[jj,i] } ZZ<-t(apply(YYp,1,function(x,levels) summary(factor(x[!is.na(x)],levels))/sum(!is.na(x)),levels=states)) } XX<-countSimmap(tree,states,FALSE) XX<-XX[,-(which(as.vector(diag(-1,length(states)))==-1)+1)] AA<-t(sapply(unclass(tree),function(x) c(colSums(x$mapped.edge),sum(x$edge.length)))) colnames(AA)[ncol(AA)]<-"total" BB<-getStates(tree,type="tips") CC<-t(apply(BB,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,Nsim=length(tree))) x<-list(count=XX,times=AA,ace=ZZ,tips=CC,tree=tree,ref.tree=if(!is.null(ref.tree)) ref.tree else NULL) class(x)<-"describe.simmap" } else if(inherits(tree,"phylo")){ XX<-countSimmap(tree,message=FALSE) YY<-getStates(tree) states<-sort(unique(YY)) AA<-setNames(c(colSums(tree$mapped.edge),sum(tree$edge.length)),c(colnames(tree$mapped.edge),"total")) AA<-rbind(AA,AA/AA[length(AA)]); rownames(AA)<-c("raw","prop") x<-list(N=XX$N,Tr=XX$Tr,times=AA,states=YY,tree=tree) class(x)<-"describe.simmap" } if(message) print(x) if(plot) plot(x) x } ## function finds the height of a given node ## written by Liam Revell 2014, 2015, 2016 nodeheight<-function(tree,node,...){ if(hasArg(root.edge)) root.edge<-list(...)$root.edge else root.edge<-FALSE if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0 else ROOT<-0 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(node==(length(tree$tip.label)+1)) h<-0 else { a<-setdiff(c(getAncestors(tree,node),node),length(tree$tip.label)+1) h<-sum(tree$edge.length[sapply(a,function(x,e) which(e==x),e=tree$edge[,2])]) } h+ROOT } # fast pairwise MRCA function # written by Liam Revell 2012, 2014, 2015 fastMRCA<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-match(sp1,tree$tip.label) y<-match(sp2,tree$tip.label) a<-c(x,getAncestors(tree,x)) b<-c(y,getAncestors(tree,y)) z<-a%in%b return(a[min(which(z))]) } ## function to find the height of the MRCA of sp1 & sp2 ## written by Liam J. Revell 2014, 2015 fastHeight<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$edge.length)) stop("tree should have edge lengths.") sp1<-which(tree$tip.label==sp1) sp2<-which(tree$tip.label==sp2) a1<-c(sp1,getAncestors(tree,sp1)) a2<-c(sp2,getAncestors(tree,sp2)) a12<-intersect(a1,a2) if(length(a12)>1){ a12<-a12[2:length(a12)-1] h<-sapply(a12,function(i,tree) tree$edge.length[which(tree$edge[,2]==i)],tree=tree) return(sum(h)) } else return(0) } ## function gets ancestor node numbers, to be used internally by ## written by Liam J. Revell 2014 getAncestors<-function(tree,node,type=c("all","parent")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") type<-type[1] if(type=="all"){ aa<-vector() rt<-length(tree$tip.label)+1 currnode<-node while(currnode!=rt){ currnode<-getAncestors(tree,currnode,"parent") aa<-c(aa,currnode) } return(aa) } else if(type=="parent"){ aa<-tree$edge[which(tree$edge[,2]==node),1] return(aa) } else stop("do not recognize type") } ## function for midpoint rooting ## written by Liam J. Revell 2014 midpoint.root<-function(tree){ D<-cophenetic(tree) dd<-max(D) ii<-which(D==dd)[1] ii<-c(ceiling(ii/nrow(D)),ii%%nrow(D)) if(ii[2]==0) ii[2]<-nrow(D) spp<-rownames(D)[ii] nn<-which(tree$tip.label==spp[2]) tree<-reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)]) aa<-getAncestors(tree,which(tree$tip.label==spp[1])) D<-c(0,dist.nodes(tree)[which(tree$tip.label==spp[1]),aa]) names(D)[1]<-which(tree$tip.label==spp[1]) i<-0 while(D[i+1]<(dd/2)) i<-i+1 tree<-reroot(tree,as.numeric(names(D)[i]),D[i+1]-dd/2) tree } # function computes phylogenetic variance-covariance matrix, including for internal nodes # written by Liam J. Revell 2011, 2013, 2014, 2015 vcvPhylo<-function(tree,anc.nodes=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # get & set optional arguments if(hasArg(internal)) internal<-list(...)$internal else internal<-anc.nodes if(internal!=anc.nodes){ message(paste("arguments \"internal\" and \"anc.nodes\" are synonyms; setting internal =",anc.nodes)) internal<-anc.nodes } if(hasArg(model)) model<-list(...)$model else model<-"BM" if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 if(model=="OU"){ if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0 } if(model=="OU"&&alphalength(tree$tip.label)) H1<-nodeHeights(tree) tree$edge.length[ii]<-lambda*tree$edge.length[ii] H2<-nodeHeights(tree) tree$edge.length[-ii]<-tree$edge.length[-ii]+ H1[-ii,2]-H2[-ii,2] tree } ## di2multi method for tree with mapped state ## written by Liam J. Revell 2013, 2015, 2016 di2multi.simmap<-function(phy,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-08 if(!inherits(phy,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(phy$maps)){ cat("Warning: tree does not contain mapped state. Using di2multi.\n") return(di2multi(phy,tol)) } N<-length(phy$tip.label) n<-length(intersect(which(phy$edge.lengthN))) if(n==0) return(phy) edge<-phy$edge edge[edge>N]<--edge[edge>N]+N edge.length<-phy$edge.length maps<-phy$maps Nnode<-phy$Nnode for(i in 1:n){ ii<-intersect(which(edge.lengthn]<--edge[edge>n]+n ii<-which(edge[,2]>0) edge<-edge[-ii,] if(!is.null(tree$edge.length)){ edge.length<-tree$edge.length edge.length<-edge.length[-ii] } zz<-sapply(edge[,2],function(x,y) !(x%in%y),y=edge[,1]) if(is.null(tree$node.label)) tree$node.label<-1:tree$Nnode+n nn<-matrix(tree$node.label[-edge],nrow(edge),ncol(edge)) tip.label<-nn[zz,2] node.label<-c(nn[1,1],nn[!zz,2]) edge[zz,2]<-1:sum(zz) Nnode<-length(unique(edge[edge<0])) rr<-cbind(sort(unique(edge[edge<0]),decreasing=TRUE),1:Nnode+sum(zz)) for(i in 1:nrow(rr)) edge[edge==rr[i,1]]<-rr[i,2] tt<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=edge.length,node.label=node.label) class(tt)<-"phylo" tt<-collapse.singles(tt) if(keep.tip.labels){ for(i in 1:length(tt$tip.label)){ yy<-getDescendants(tree,node=which(tree$node.label==tt$tip.label[i])+n) tt$tip.label[i]<-paste(tree$tip.label[yy[yy<=n]],collapse=",") } } return(tt) } # function rounds the branch lengths of the tree & applies rounding to simmap tree # written by Liam J. Revell 2012, 2013, 2015 roundBranches<-function(tree,digits=0){ if(inherits(tree,"multiPhylo")){ trees<-lapply(tree,roundBranches,digits=digits) class(trees)<-"multiPhylo" return(trees) } else if(inherits(tree,"phylo")) { tree$edge.length<-round(tree$edge.length,digits) if(!is.null(tree$maps)){ for(i in 1:nrow(tree$edge)){ temp<-tree$maps[[i]]/sum(tree$maps[[i]]) tree$maps[[i]]<-temp*tree$edge.length[i] } } if(!is.null(tree$mapped.edge)){ a<-vector() for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]])) a<-unique(a) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j] } return(tree) } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") } # function to merge mapped states # written by Liam J. Revell 2013, 2015 mergeMappedStates<-function(tree,old.states,new.state){ if(inherits(tree,"multiPhylo")){ tree<-unclass(tree) tree<-lapply(tree,mergeMappedStates,old.states=old.states,new.state=new.state) class(tree)<-"multiPhylo" } else if(inherits(tree,"phylo")) { maps<-tree$maps rr<-function(map,oo,nn){ for(i in 1:length(map)) if(names(map)[i]%in%oo) names(map)[i]<-nn map } mm<-function(map){ if(length(map)>1){ new.map<-vector() j<-1 new.map[j]<-map[1] names(new.map)[j]<-names(map)[1] for(i in 2:length(map)){ if(names(map)[i]==names(map)[i-1]){ new.map[j]<-map[i]+new.map[j] names(new.map)[j]<-names(map)[i] } else { j<-j+1 new.map[j]<-map[i] names(new.map)[j]<-names(map)[i] } } map<-new.map } map } maps<-lapply(maps,rr,oo=old.states,nn=new.state) if(length(old.states)>1){ maps<-lapply(maps,mm) mapped.edge<-tree$mapped.edge mapped.edge<-cbind(rowSums(mapped.edge[,colnames(mapped.edge)%in%old.states]), mapped.edge[,setdiff(colnames(mapped.edge),old.states)]) colnames(mapped.edge)<-c(new.state,setdiff(colnames(tree$mapped.edge),old.states)) } else { mapped.edge<-tree$mapped.edge colnames(mapped.edge)[which(colnames(mapped.edge)==old.states)]<-new.state } tree$maps<-maps tree$mapped.edge<-mapped.edge } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") return(tree) } # function rotates a node or multiple nodes # written by Liam J. Revell 2013, 2015 rotateNodes<-function(tree,nodes,polytom=c(1,2),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") n<-length(tree$tip.label) if(nodes[1]=="all") nodes<-1:tree$Nnode+n for(i in 1:length(nodes)) tree<-rotate(tree,nodes[i],polytom) if(hasArg(reversible)) reversible<-list(...)$reversible else reversible<-TRUE if(reversible){ ii<-which(tree$edge[,2]<=n) jj<-tree$edge[ii,2] tree$edge[ii,2]<-1:n tree$tip.label<-tree$tip.label[jj] } return(tree) } # function simulates random sampling from xbar, xvar, with sample sizes n # written by Liam J. Revell 2012 sampleFrom<-function(xbar=0,xvar=1,n=1,randn=NULL,type="norm"){ if(length(xvar)==1&&length(xbar)!=length(xvar)) xvar<-rep(xvar,length(xbar)) if(!is.null(randn)) for(i in 1:length(xbar)) n[i]<-floor(runif(n=1,min=randn[1],max=(randn[2]+1))) x<-vector() for(i in 1:length(xbar)){ y<-rnorm(n=n[i],mean=xbar[i],sd=sqrt(xvar[i])) names(y)<-rep(names(xbar)[i],length(y)) x<-c(x,y) } return(x) } # function adds a new tip to the tree # written by Liam J. Revell 2012, 2013, 2014, 2015 bind.tip<-function(tree,tip.label,edge.length=NULL,where=NULL,position=0,interactive=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") use.edge.length<-if(is.null(tree$edge.length)) FALSE else TRUE if(use.edge.length==FALSE) tree<-compute.brlen(tree) if(interactive==TRUE){ plotTree(tree,...) cat(paste("Click where you would like to bind the tip \"",tip.label,"\"\n",sep="")) flush.console() obj<-get.treepos(message=FALSE) where<-obj$where position<-obj$pos } else if(is.null(where)) where<-length(tree$tip.label)+1 if(where<=length(tree$tip.label)&&position==0){ pp<-1e-12 if(tree$edge.length[which(tree$edge[,2]==where)]<=1e-12){ tree$edge.length[which(tree$edge[,2]==where)]<-2e-12 ff<-TRUE } else ff<-FALSE } else pp<-position if(is.null(edge.length)&&is.ultrametric(tree)){ H<-nodeHeights(tree) if(where==(length(tree$tip.label)+1)) edge.length<-max(H) else edge.length<-max(H)-H[tree$edge[,2]==where,2]+position } tip<-list(edge=matrix(c(2,1),1,2), tip.label=tip.label, edge.length=edge.length, Nnode=1) class(tip)<-"phylo" obj<-bind.tree(tree,tip,where=where,position=pp) if(where<=length(tree$tip.label)&&position==0){ nn<-obj$edge[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label)),1] obj$edge.length[which(obj$edge[,2]==nn)]<-obj$edge.length[which(obj$edge[,2]==nn)]+1e-12 obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label))]<-0 obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tree$tip.label[where]))]<-0 } root.time<-if(!is.null(obj$root.time)) obj$root.time else NULL obj<-untangle(obj,"read.tree") if(!is.null(root.time)) obj$root.time<-root.time if(interactive) plotTree(obj,...) if(!use.edge.length) obj$edge.length<-NULL obj } # function collapses the subtree descended from node to a star tree # written by Liam J. Revell 2013, 2015 collapse.to.star<-function(tree,node){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") nel<-if(is.null(tree$edge.length)) TRUE else FALSE if(nel) tree$edge.length<-rep(1,nrow(tree$edge)) tt<-splitTree(tree,split=list(node=node,bp=tree$edge.length[which(tree$edge[,2]==node)])) ss<-starTree(species=tt[[2]]$tip.label,branch.lengths=diag(vcv(tt[[2]]))) ss$root.edge<-0 tree<-paste.tree(tt[[1]],ss) if(nel) tree$edge.length<-NULL tree } ## function returns the MRCA, or its height above the root, for a set of taxa (in tips) ## written by Liam Revell 2012, 2013, 2015, 2016 findMRCA<-function(tree,tips=NULL,type=c("node","height")){ type<-type[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tips)){ X<-mrca(tree) if(type=="height"){ H<-nodeHeights(tree) X<-apply(X,c(1,2),function(x,y,z) y[which(z==x)[1]],y=H,z=tree$edge) } return(X) } else { node<-getMRCA(tree,tips) if (type == "node") return(node) else if(type=="height") return(nodeheight(tree,node)) } } # function works like extract.clade in ape but will preserve a discrete character mapping # written by Liam J. Revell 2013 extract.clade.simmap<-function(tree,node){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-getDescendants(tree,node) x<-x[x<=length(tree$tip.label)] drop.tip.simmap(tree,tree$tip.label[-x]) } # function gets all subtrees that cannot be further subdivided into two clades of >= clade.size # written by Liam J. Revell 2013, 2015 getCladesofSize<-function(tree,clade.size=2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") n<-length(tree$tip.label) nn<-1:(tree$Nnode+n) ndesc<-function(tree,node){ x<-getDescendants(tree,node) sum(x<=length(tree$tip.label)) } dd<-setNames(sapply(nn,ndesc,tree=tree),nn) aa<-n+1 # root nodes<-vector() while(length(aa)){ bb<-lapply(aa,function(x,tree) tree$edge[which(tree$edge[,1]==x),2],tree=tree) cc<-lapply(bb,function(x) dd[as.character(x)]) gg<-sapply(cc,function(x,cs) any(xy"))) } else if(inherits(tree,"phylo")) { n<-sum(sapply(tree$maps,length))-nrow(tree$edge) if(is.null(states)) states<-colnames(tree$mapped.edge) m<-length(states) TT<-matrix(NA,m,m,dimnames=list(states,states)) gg<-function(map,a,b){ if(length(map)==1) zz<-0 else { zz<-0; i<-2 while(i<=length(map)){ if(names(map)[i]==b&&names(map)[i-1]==a) zz<-zz+1 i<-i+1 } } return(zz) } for(i in 1:m) for(j in 1:m) if(i==j) TT[i,j]<-0 else TT[i,j]<-sum(sapply(tree$maps,gg,a=states[i],b=states[j])) if(!message) return(list(N=n,Tr=TT)) else return(list(N=n,Tr=TT,message=c( "N is the total number of character changes on the tree", "Tr gives the number of transitions from row state->column state"))) } } # function to match nodes between trees # written by Liam J. Revell 2012, 2013, 2015 matchNodes<-function(tr1,tr2,method=c("descendants","distances"),...){ if(!inherits(tr1,"phylo")||!inherits(tr1,"phylo")) stop("tr1 & tr2 should both be objects of class \"phylo\".") if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE method<-method[1] method<-matchType(method,c("descendants","distances")) if(method=="descendants"){ desc.tr1<-lapply(1:tr1$Nnode+length(tr1$tip),function(x) extract.clade(tr1,x)$tip.label) names(desc.tr1)<-1:tr1$Nnode+length(tr1$tip) desc.tr2<-lapply(1:tr2$Nnode+length(tr2$tip),function(x) extract.clade(tr2,x)$tip.label) names(desc.tr2)<-1:tr2$Nnode+length(tr2$tip) Nodes<-matrix(NA,length(desc.tr1),2,dimnames=list(NULL,c("tr1","tr2"))) for(i in 1:length(desc.tr1)){ Nodes[i,1]<-as.numeric(names(desc.tr1)[i]) for(j in 1:length(desc.tr2)) if(all(desc.tr1[[i]]%in%desc.tr2[[j]])&&all(desc.tr2[[j]]%in%desc.tr1[[i]])) Nodes[i,2]<-as.numeric(names(desc.tr2)[j]) } } else if(method=="distances"){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(hasArg(corr)) corr<-list(...)$corr else corr<-FALSE if(corr) tr1$edge.length<-tr1$edge.length/max(nodeHeights(tr1)) if(corr) tr2$edge.length<-tr2$edge.length/max(nodeHeights(tr2)) D1<-dist.nodes(tr1)[1:length(tr1$tip),1:tr1$Nnode+length(tr1$tip)] D2<-dist.nodes(tr2)[1:length(tr2$tip),1:tr2$Nnode+length(tr2$tip)] rownames(D1)<-tr1$tip.label rownames(D2)<-tr2$tip.label common.tips<-intersect(tr1$tip.label,tr2$tip.label) D1<-D1[common.tips,] D2<-D2[common.tips,] Nodes<-matrix(NA,tr1$Nnode,2,dimnames=list(NULL,c("tr1","tr2"))) for(i in 1:tr1$Nnode){ if(corr) z<-apply(D2,2,function(X,y) cor(X,y),y=D1[,i]) else z<-apply(D2,2,function(X,y) 1-sum(abs(X-y)),y=D1[,i]) Nodes[i,1]<-as.numeric(colnames(D1)[i]) if(any(z>=(1-tol))){ a<-as.numeric(names(which(z>=(1-tol)))) if(length(a)==1) Nodes[i,2]<-a else { Nodes[i,2]<-a[1] if(!quiet) warning("polytomy detected; some node matches may be arbitrary") } } } } return(Nodes) } # function applies the branch lengths of a reference tree to a second tree, including mappings # written by Liam J. Revell 2012, 2015 applyBranchLengths<-function(tree,edge.length){ if(inherits(tree,"multiPhylo")){ trees<-lapply(tree,applyBranchLengths,edge.length=edge.length) class(trees)<-"multiPhylo" return(trees) } else if(inherits(tree,"phylo")) { tree$edge.length<-edge.length if(!is.null(tree$maps)){ for(i in 1:nrow(tree$edge)){ temp<-tree$maps[[i]]/sum(tree$maps[[i]]) tree$maps[[i]]<-temp*tree$edge.length[i] } } if(!is.null(tree$mapped.edge)){ a<-vector() for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]])) a<-unique(a) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j] } return(tree) } } # function to compute phylogenetic VCV using joint Pagel's lambda # written by Liam Revell 2011 phyl.vcv<-function(X,C,lambda){ C<-lambda.transform(lambda,C) invC<-solve(C) a<-matrix(colSums(invC%*%X)/sum(invC),ncol(X),1) A<-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=T) V<-t(X-A)%*%invC%*%(X-A)/(nrow(C)-1) return(list(C=C,R=V,alpha=a)) } # lambda transformation of C # written by Liam Revell 2011 lambda.transform<-function(lambda,C){ if(lambda==1) return(C) else { V<-diag(diag(C)) C<-C-V C.lambda<-(V+lambda*C) return(C.lambda) } } # likelihood function for joint estimation of lambda for multiple traits # written by Liam Revell 2011/2012 likMlambda<-function(lambda,X,C){ # compute R, conditioned on lambda temp<-phyl.vcv(X,C,lambda); C<-temp$C; R<-temp$R; a<-temp$alpha # prep n<-nrow(X); m<-ncol(X); D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n1) if(length(intersect(states,ordering))n)) result$nodes<-sisters[which(sisters>n)] else if(any(sisters>n)) result$nodes<-tree$node.label[sisters[which(sisters>n)]-n] if(any(sisters<=n)) result$tips<-tree$tip.label[sisters[which(sisters<=n)]] return(result) } } # gets descendant node numbers # written by Liam Revell 2012, 2013, 2014 getDescendants<-function(tree,node,curr=NULL){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(curr)) curr<-vector() daughters<-tree$edge[which(tree$edge[,1]==node),2] curr<-c(curr,daughters) if(length(curr)==0&&node<=length(tree$tip.label)) curr<-node w<-which(daughters>length(tree$tip.label)) if(length(w)>0) for(i in 1:length(w)) curr<-getDescendants(tree,daughters[w[i]],curr) return(curr) } # function computes vcv for each state, and stores in array # written by Liam J. Revell 2011, 2012, 2016 multiC<-function(tree,internal=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!inherits(tree,"simmap")) stop("tree should be an object of class \"simmap\".") m<-ncol(tree$mapped.edge) # compute separate C for each state mC<-list() for(i in 1:m){ mtree<-list(edge=tree$edge, Nnode=tree$Nnode, tip.label=tree$tip.label, edge.length=tree$mapped.edge[,i]) class(mtree)<-"phylo" mC[[i]]<-if(internal) vcvPhylo(mtree,internal=TRUE) else vcv.phylo(mtree) } names(mC)<-colnames(tree$mapped.edge) mC } # function pastes subtree onto tip # written by Liam Revell 2011, 2015 paste.tree<-function(tr1,tr2){ if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo")) stop("tr1 & tr2 should be objects of class \"phylo\".") if(length(tr2$tip)>1){ temp<-tr2$root.edge; tr2$root.edge<-NULL tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]+temp } tr.bound<-bind.tree(tr1,tr2,where=which(tr1$tip.label=="NA")) return(tr.bound) } # match type # written by Liam J. Revell 2012 matchType<-function(type,types){ for(i in 1:length(types)) if(all(strsplit(type,split="")[[1]]==strsplit(types[i],split="")[[1]][1:length(strsplit(type,split="")[[1]])])) type=types[i] return(type) } # wraps around MatrixExp # written by Liam Revell 2011 expm<-function(Y){ Z<-MatrixExp(Y); dimnames(Z)<-dimnames(Y) return(Z) } # function 'untangles' (or attempts to untangle) a tree with crossing branches # written by Liam J. Revell 2013, 2015 untangle<-function(tree,method=c("reorder","read.tree")){ if(inherits(tree,"multiPhylo")){ tree<-lapply(tree,untangle,method=method) class(tree)<-"multiPhylo" } else { if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") obj<-attributes(tree) method<-method[1] if(method=="reorder") tree<-reorder(reorder(tree,"pruningwise")) else if(method=="read.tree"){ if(inherits(tree,"simmap")) tree<-read.simmap(text=write.simmap(tree)) else tree<-if(Ntip(tree)>1) read.tree(text=write.tree(tree)) else read.newick(text=write.tree(tree)) } ii<-!names(obj)%in%names(attributes(tree)) attributes(tree)<-c(attributes(tree),obj[ii]) } tree } phytools/R/consensus.edges.R0000644000176200001440000000242612731425027015574 0ustar liggesusers## compute consensus edge lengths from a set of trees given (or not) a consensus topology ## written by Liam J. Revell 2016 consensus.edges<-function(trees,method=c("mean.edge","least.squares"),...){ if(hasArg(consensus.tree)) consensus.tree<-list(...)$consensus.tree else consensus.tree<-consensus(trees,p=0.5) tree<-consensus.tree ## get rid of this cumbersome name if(hasArg(if.absent)) if.absent<-list(...)$if.absent else if.absent<-"zero" N<-length(trees) if(method[1]=="mean.edge"){ M<-lapply(trees,function(x,y) rbind(matchLabels(y,x),matchNodes(y,x)),y=tree) nodes<-M[[1]][,1] edge.length<-vector(mode="numeric",length=length(nodes)) for(i in 1:length(nodes)){ ii<-which(tree$edge[,2]==nodes[i]) n.absent<-0 for(j in 1:N){ edge.length[ii]<-edge.length[ii] + if(!is.na(M[[j]][i,2])) trees[[j]]$edge.length[which(trees[[j]]$edge[,2]==M[[j]][i,2])]/N else 0 if(is.na(M[[j]][i,2])) n.absent<-n.absent+1 } if(if.absent=="ignore") edge.length[ii]<-edge.length[ii]*N/(N-n.absent) } tree$edge.length<-edge.length } else if(method[1]=="least.squares"){ D<-Reduce('+',lapply(trees,function(x,t) cophenetic(x)[t,t],t=tree$tip.label))/N tree<-nnls.tree(D,tree=tree,rooted=all(sapply(trees,is.ultrametric))) } tree }phytools/R/rateshift.R0000644000176200001440000002203012754626553014464 0ustar liggesusers## find the temporal position of a rate shift using ML ## written by Liam J. Revell 2013, 2014, 2015 rateshift<-function(tree,x,nrates=1,niter=10,method="ML",...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(print)) print<-list(...)$print else print<-FALSE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(minL)) minL<-list(...)$minL else minL<--1e12 if(hasArg(fixed.shift)) fixed.shift<-list(...)$fixed.shift else fixed.shift<-FALSE fn<-if(method=="ML") brownie.lite else brownieREML if(!fixed.shift[1]){ if(print){ cat("Optimization progress:\n\n") if(nrates>1) cat(paste(c("iter",paste("shift",1:(nrates-1),sep=":"),"logL\n"),collapse="\t")) else cat("iter\ts^2(1)\tlogL\n") } else if(niter==1) { if(!quiet) cat("Optimizing. Please wait.\n\n") flush.console() } else { if(!quiet) cat("Optimization progress:\n|") flush.console() } } else { if(!quiet) cat("Estimating rates conditioned on input shift points...\n\n") nrates<-if(fixed.shift[1]!=TRUE) length(fixed.shift)+1 else 1 if(nrates>2) fixed.shift<-sort(fixed.shift) names(fixed.shift)<-NULL } lik<-function(par,tree,y,nrates,plot,print,iter,Tol,maxh,minL){ shift<-sort(c(setNames(0,1),setNames(par,2:nrates))) if((any(shift[2:length(shift)]<=0)||any(shift>=maxh))) logL<-minL else { tree<-make.era.map(tree,shift,tol=Tol/10) if(plot){ plotSimmap(tree,setNames(rainbow(nrates),1:nrates),lwd=3,ftype="off",mar=c(0.1,0.1,4.1,0.1)) title(main=paste("Optimizing rate shift(s), round",iter,"....",sep=" ")) for(i in 2:(length(shift))) lines(rep(shift[i],2),c(0,length(tree$tip.label)+1),lty="dashed") } logL<-fn(tree,y)$logL.multiple } if(print){ if(nrates>1) cat(paste(c(iter,round(shift[2:length(shift)],4),round(logL,4),"\n"),collapse="\t")) else cat(paste(c(iter,round(par,4),round(logL,4),"\n"),collapse="\t")) } -logL } h<-max(nodeHeights(tree)) N<-length(tree$tip.label) x<-x[tree$tip.label] if(!fixed.shift[1]){ fit<-list() for(i in 1:niter){ if(nrates>1) par<-sort(runif(n=nrates-1)*h) if(nrates==1){ fit[[i]]<-fn(make.era.map(tree,setNames(0,1)),x) fit[[i]]$convergence<-if(fit[[i]]$convergence=="Optimization has converged.") 0 else 1 } else suppressWarnings(fit[[i]]<-optim(par,lik,tree=tree,y=x,nrates=nrates,print=print,plot=plot, iter=i,Tol=tol,maxh=h,minL=minL)) if(!print&&niter>1){ if(!quiet) cat(".") flush.console() } } if(!print&&niter>1) if(!quiet) cat("|\nDone.\n\n") ll<-sapply(fit,function(x) if(nrates>1) x$value else -x$logL1) fit<-fit[[which(ll==min(ll))[1]]] frequency.best<-mean(ll<=(min(ll)+1e-4)) likHess<-if(method=="ML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) mC<-multiC(tree) mC<-mapply("*",mC,sig2,SIMPLIFY=FALSE) V<-Reduce("+",mC) invV<-solve(V) a<-as.numeric(colSums(invV)%*%x/sum(invV)) logL<-sum(dmnorm(y,rep(a,length(x)),V,log=TRUE)) -logL } else if(method=="REML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) tree<-scaleByMap(tree,setNames(sig2,1:nrates)) picX<-pic(y,tree,scaled=FALSE,var.contrasts=TRUE) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) -logL } mtree<-if(nrates>1) make.era.map(tree,c(0,fit$par)) else make.era.map(tree,0) obj<-fn(mtree,x) H<-optimHess(c(obj$sig2.multiple,fit$par),likHess,tree=tree,y=x,nrates=nrates,tol=tol,maxh=h) vcv<-if(nrates>1) solve(H) else 1/H if(nrates>1) rownames(vcv)<-colnames(vcv)<-c(paste("sig2(",1:nrates,")",sep=""),paste(1:(nrates-1),"<->",2:nrates,sep="")) else rownames(vcv)<-colnames(vcv)<-"sig2(1)" obj<-list(sig2=setNames(obj$sig2.multiple,1:nrates), shift=if(nrates>1) setNames(fit$par,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL, vcv=vcv,tree=mtree,logL=obj$logL.multiple,convergence=fit$convergence,message=fit$message, method=method,frequency.best=frequency.best) } else { mtree<-if(nrates>1) make.era.map(tree,c(0,fixed.shift)) else make.era.map(tree,0) fit<-fn(mtree,x) if(fit$convergence=="Optimization has converged.") fit$convergence<-0 obj<-list(sig2=setNames(fit$sig2.multiple,1:nrates), shift=if(nrates>1) setNames(fixed.shift,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL, vcv=matrix(-1,2*nrates-1,2*nrates-1),tree=mtree,logL=fit$logL.multiple,convergence=fit$convergence, method=method,message="Fitted rates from a fixed shifts",frequency.best=NA) } class(obj)<-"rateshift" if(plot) plot(obj,ftype="off") obj } ## S3 print method for object of class "rateshift" ## written by Liam J. Revell 2013 print.rateshift<-function(x,...){ sqroot<-function(x){ if(length(x)==1) if(x>=0) sqrt(x) else NaN else sapply(x,sqroot) } if(hasArg(digits)) digits<-list(...)$digits else digits<-4 x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat(paste("ML ",length(x$sig2),"-rate model:\n",sep="")) cat(paste(c("",paste("s^2(",names(x$sig2),")","\tse(",names(x$sig2),")",sep=""), "k","logL","\n"),collapse="\t")) cat(paste(paste(c("value",paste(x$sig2,round(sqroot(diag(x$vcv)[1:length(x$sig2)]),digits), sep="\t"),2*length(x$sig2),x$logL),collapse="\t"),"\n\n",sep="")) if(!is.null(x$shift)){ cat("Shift point(s) between regimes (height above root):\n") nn<-sapply(strsplit(names(x$shift),"<->"),paste,collapse="|") cat(paste(c("",paste(nn,paste("se(",nn,")",sep=""),sep="\t"),"\n"), collapse="\t")) cat(paste(paste(c("value",paste(x$shift, round(sqroot(diag(x$vcv)[1:length(x$shift)+length(x$sig2)]),digits), sep="\t")),collapse="\t"),"\n\n",sep="")) } else cat("This is a one-rate model.\n\n") if(x$method=="ML") cat("Model fit using ML.\n\n") else if(x$method=="REML") cat("Model fit using REML.\n\n") cat(paste("Frequency of best fit:",x$frequency.best,"\n\n")) if (x$convergence==0) cat(paste("R thinks it has found the",x$method,"solution.\n\n")) else cat("Optimization may not have converged.\n\n") } ## S3 logLik method for object of class "rateshift" ## written by Liam J. Revell 2013 logLik.rateshift<-function(object,...){ logLik<-object$logL class(logLik)<-"logLik" attr(logLik,"df")<-2*length(object$sig2) logLik } ## S3 plot method for object of class "rateshift" ## written by Liam J. Revell 2015 plot.rateshift<-function(x,...){ if(length(x$sig2)>1){ cols<-colorRampPalette(c("blue","purple","red"))(101) rr<-range(x$sig2) names(cols)<-seq(rr[1],rr[2],by=diff(rr)/100) ii<-sapply(x$sig2,function(x,y) order(abs(y-x))[1], y=as.numeric(names(cols))) colors<-setNames(cols[ii],names(ii)) plot(x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) nulo<-lapply(x$shift,function(x,y) lines(rep(x,2),c(1,Ntip(y)), lty="dotted",col="grey"),y=x$tree) add.color.bar(leg=0.5*max(nodeHeights(x$tree)),cols=cols, prompt=FALSE,x=0,y=-0.05*Ntip(x$tree),lims=round(rr,3), title=expression(sigma^2)) } else { colors<-setNames("blue",1) plot(x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) txt<-as.character(round(x$sig2,3)) add.simmap.legend(leg=expression(paste(sigma^2," = ",sep="")), colors="blue",prompt=FALSE,x=0,y=-0.05*Ntip(x$tree)) text(x=5.5*strwidth("W"),y=-0.05*Ntip(x$tree),round(x$sig2,3)) } } ## function to visualize the likelihood surface for 2 & 3 rate models (1 & 2 rate-shifts) ## written by Liam J. Revell 2016 likSurface.rateshift<-function(tree,x,nrates=2,shift.range=NULL, density=20,plot=TRUE,...){ h<-max(nodeHeights(tree)) if(is.null(shift.range)) shift.range<-c(0.01*h,0.99*h) shift<-seq(shift.range[1],shift.range[2],length.out=density) if(nrates==2){ cat("Computing likelihood surface for 2-rate (1 rate-shift) model....\n") flush.console() logL1<-sapply(shift,function(s,tree,x) logLik(rateshift(tree,x,fixed.shift=s, quiet=TRUE)),tree=tree,x=x) if(plot) plot(shift,logL1,type="l",lwd=2,xlab="shift point",ylab="log(L)",...) cat("Done.\n") obj<-list(shift=shift,logL=logL1) } else if(nrates==3){ cat("Computing likelihood surface for 3-rate (2 rate-shift) model....\n") flush.console() logL2<-sapply(shift,function(s1,s2,tree,x) sapply(s2,function(s2,s1,tree,x) logLik(rateshift(tree,x,fixed.shift=if(s1!=s2) c(s1,s2) else s1, quiet=TRUE)),s1=s1,tree=tree,x=x),s2=shift,tree=tree,x=x) if(plot) contour(shift,shift,logL2,nlevels=20,xlab="shift 1 (or 2)", ylab="shift 2 (or 1)",...) cat("Done.\n") obj<-list(shift=shift,logL=logL2) } else if((nrates%in%c(2,3))==FALSE){ cat("Method only available for nrates==2 and nrates==3\n") obj<-NULL } invisible(obj) } phytools/R/export.as.xml.R0000644000176200001440000000242412561714575015220 0ustar liggesusers# makes xml data and tree file for SIMMAP # written by Liam J. Revell 2012, 2015 export.as.xml<-function(file,trees,X){ if(is.vector(X)) X<-data.frame(X) if(class(X)=="DNAbin") { X<-as.character(X) datatype="nucleotide" } else datatype="standard" if(inherits(trees,"phylo")){ trees<-list(trees) class(trees)<-"multiPhylo" } ntaxa<-length(trees[[1]]$tip) nchars<-ncol(X) write("",file) write("",file,append=TRUE) write(paste("\t",sep=""),file,append=TRUE) for(i in 1:ntaxa) write(paste("\t\t",paste(X[i,],collapse=""),"",sep=""),file,append=TRUE) write("\t",file,append=TRUE) write("\t",file,append=TRUE) trans<-trees[[1]]$tip.label for(i in 1:ntaxa) write(paste("\t\t",trans[i],"",sep=""),file,append=TRUE) for(i in 1:length(trees)){ trees[[i]]$tip.label<-match(trans,trees[[i]]$tip.label) temp<-unlist(strsplit(write.tree(trees[[i]]),NULL)) temp<-paste(temp[1:(length(temp)-1)],collapse="") write(paste("\t\t",temp,"",sep=""),file,append=TRUE) } write("\t",file,append=TRUE) write("",file,append=TRUE) } phytools/R/add.everywhere.R0000644000176200001440000000137412561705251015404 0ustar liggesusers# function takes a tree and adds a tip in all possible places # returns the set of unrooted trees without branch lengths # written by Liam J. Revell 2011, 2013, 2015 add.everywhere<-function(tree,tip.name){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") tree<-unroot(tree) # unroot tree tree$edge.length<-rep(1,nrow(tree$edge)) # set all edge lengths to 1.0 # create new tip new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L) class(new.tip)<-"phylo" # add the new tip to all edges of the tree trees<-list() class(trees)<-"multiPhylo" for(i in 1:nrow(tree$edge)){ trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) trees[[i]]$edge.length<-NULL } return(trees) } phytools/R/phyl.pca.R0000644000176200001440000001334513062262203014177 0ustar liggesusers## function to perform phylogenetic principal components analysis ## multiple morphological traits in Y ## also can use lambda transformation in which lambda is optimized by ML or REML (in progress) ## written by Liam Revell 2010, 2011, 2013, 2015, 2016, 2017 ref. Revell (2009; Evolution) phyl.pca<-function(tree,Y,method="BM",mode="cov",...){ ## get optional argument if(hasArg(opt)) opt<-list(...)$opt else opt<-"ML" # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check mode if(length(strsplit(mode,split="")[[1]])<=2){ message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode<-"cov" } if(all(strsplit(mode,split="")[[1]]==strsplit("correlation", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"corr" else if(all(strsplit(mode,split="")[[1]]==strsplit("covariance", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"cov" else { message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode="cov" } # preliminaries n<-nrow(Y) m<-ncol(Y) # check and sort data if(n>Ntip(tree)) stop("number of rows in Y cannot be greater than number of taxa in your tree") Y<-as.matrix(Y) if(is.null(rownames(Y))){ if(nrow(Y)==n){ print("Y has no names. function will assume that the row order of Y matches tree$tip.label") rownames(Y)<-tree$tip.label } else stop("Y has no names and does not have the same number of rows as tips in tree") } else if(length(setdiff(rownames(Y),tree$tip.label))!=0) stop("Y has rownames, but some rownames of Y not found in tree") # analyze C<-vcv.phylo(tree)[rownames(Y),rownames(Y)] if(method=="BM"){ temp<-phyl.vcv(Y,C,1.0) V<-temp$R a<-t(temp$alpha) C<-temp$C } else if(method=="lambda"){ if(opt=="ML") temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=Y, C=C,maximum=TRUE) else if(opt=="REML") temp<-optimize(f=remlMlambda,interval=c(0,maxLambda(tree)), tree=tree,X=Y,maximum=TRUE) else if(opt=="fixed"){ if(hasArg(lambda)) lambda<-list(...)$lambda else { cat(" opt=\"fixed\" requires the user to specify lambda.\n") cat(" setting lambda to 1.0.\n") lambda<-1.0 } temp<-list(maximum=lambda,objective=likMlambda(lambda,X=Y,C=C)) } lambda<-temp$maximum logL<-as.numeric(temp$objective) temp<-phyl.vcv(Y,C,lambda) V<-temp$R a<-t(temp$alpha) C<-temp$C } invC<-solve(C) ## get inverse of C # if correlation matrix if(mode=="corr"){ Y=Y/matrix(rep(sqrt(diag(V)),n),n,m,byrow=T) # standardize Y V=V/(sqrt(diag(V))%*%t(sqrt(diag(V)))) # change V to correlation matrix a<-matrix(colSums(invC%*%Y)/sum(invC),m,1) # recalculate a } es=eigen(V) # eigenanalyze obj<-list() obj$Eval<-diag(es$values[1:min(n-1,m)]) obj$Evec<-es$vectors[,1:min(n-1,m)] dimnames(obj$Eval)<-list(paste("PC",1:min(n-1,m),sep=""), paste("PC",1:min(n-1,m),sep="")) dimnames(obj$Evec)<-list(colnames(Y),paste("PC",1:min(n-1,m),sep="")) A<-matrix(rep(a,n),n,m,byrow=T) obj$S<-(Y-A)%*%obj$Evec # compute scores in the species space Ccv<-t(Y-A)%*%invC%*%obj$S/(n-1) # compute cross covariance matrix and loadings obj$L<-matrix(,m,min(n-1,m),dimnames=list(colnames(Y),paste("PC",1:min(n-1,m),sep=""))) for(i in 1:m) for(j in 1:min(n-1,m)) obj$L[i,j]<-Ccv[i,j]/sqrt(V[i,i]*obj$Eval[j,j]) if(method=="lambda"){ obj$lambda<-lambda obj$logL.lambda<-logL } ## assign class attribute (for S3 methods) class(obj)<-"phyl.pca" # return obj obj } ## S3 method for object of class "phyl.pca ## modified from code provided by Joan Maspons ## S3 print method for "phyl.pca" ## modified from code provided by Joan Maspons print.phyl.pca<-function(x, ...){ cat("Phylogenetic pca\n") cat("Standard deviations:\n") print(sqrt(diag(x$Eval))) cat("Loads:\n") print(x$L) if("lambda" %in% names(x)){ cat("lambda:\n") print(x$lambda) } } ## S3 summary method for "phyl.pca" ## modified from code provided by Joan Maspons summary.phyl.pca<-function(object, ...){ cat("Importance of components:\n") sd<-sqrt(diag(object$Eval)) varProp<- diag(object$Eval)/sum(object$Eval) impp<-rbind("Standard deviation"=sd,"Proportion of Variance"=varProp, "Cumulative Proportion"=cumsum(varProp)) print(impp) xx<-list(sdev=sd,importance=impp) class(xx)<-"summary.phyl.pca" invisible(xx) } ## S3 biplot method for "phyl.pca" ## modified from code provided by Joan Maspons ## written by Liam J. Revell 2015, 2017 biplot.phyl.pca<-function(x,...){ to.do<-list(...) if(hasArg(choices)){ choices<-list(...)$choices to.do$choices<-NULL } else choices<-c(1,2) to.do$x<-x$S[,choices] to.do$y<-x$Evec[,choices] do.call(biplot,to.do) } ## lambdaTree for lambda="REML" ## written by Liam J. Revell 2013 lambdaTree<-function(tree,lambda){ n<-length(tree$tip.label) h1<-nodeHeights(tree) ii<-which(tree$edge[,2]>n) tree$edge.length[ii]<-lambda*tree$edge.length[ii] h2<-nodeHeights(tree) tree$edge.length[-ii]<-tree$edge.length[-ii]+h1[-ii,2]-h2[-ii,2] tree } ## REML function ## written by Liam J. Revell 2013 remlMlambda<-function(lambda,tree,X){ tt<-lambdaTree(tree,lambda) Y<-apply(X,2,pic,phy=tt) V<-t(Y)%*%Y/nrow(Y) logL<-sum(dmnorm(Y,mean=rep(0,ncol(Y)),varcov=V,log=TRUE)) ## kronRC<-kronecker(V,diag(rep(1,nrow(Y)))) ## y<-as.vector(Y) ## logL<--y%*%solve(kronRC,y)/2-length(y)*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2 ## print(V) print(c(lambda,logL)) logL } ## S3 plot method (does screeplot) plot.phyl.pca<- function(x,...){ if(hasArg(main)) main<-list(...)$main else main="screeplot" x$sdev<-sqrt(diag(x$Eval)) screeplot(x,main=main) } phytools/R/ltt.R0000644000176200001440000001520312562000360013255 0ustar liggesusers## This function computes the data for a lineage-through-time plot and ## (optionally) creates this plot the function does not require a tree ## that is ultrametric. Optionally, the function can remove extinct ## species from the phylogeny. If the input tree is an object of class ## "multiPhylo" then the function will simultaneously plot all ltts. ## written by Liam J. Revell 2010-2015 ltt<-function(tree,plot=TRUE,drop.extinct=FALSE,log.lineages=TRUE,gamma=TRUE,...){ # set tolerance tol<-1e-6 # check "phylo" object if(!inherits(tree,"phylo")&&!inherits(tree,"multiPhylo")) stop("tree must be object of class \"phylo\" or \"multiPhylo\".") if(inherits(tree,"multiPhylo")){ obj<-lapply(tree,ltt,plot=FALSE,drop.extinct=drop.extinct, log.lineages=log.lineages,gamma=gamma) class(obj)<-"multiLtt" } else { # reorder the tree tree<-reorder.phylo(tree,order="cladewise") if(!is.null(tree$node.label)){ node.names<-setNames(tree$node.label,1:tree$Nnode+Ntip(tree)) tree$node.label<-NULL } else node.names<-NULL ## check if tree is ultrametric & if yes, then make *precisely* ultrametric if(is.ultrametric(tree)){ h<-max(nodeHeights(tree)) time<-c(0,h-sort(branching.times(tree),decreasing=TRUE),h) nodes<-as.numeric(names(time)[2:(length(time)-1)]) ltt<-c(cumsum(c(1,sapply(nodes,function(x,y) sum(y==x)-1,y=tree$edge[,1]))), length(tree$tip.label)) names(ltt)<-names(time) } else { # internal functions # drop extinct tips drop.extinct.tips<-function(phy){ temp<-diag(vcv(phy)) if(length(temp[temp<(max(temp)-tol)])>0) pruned.phy<-drop.tip(phy,names(temp[temp<(max(temp)-tol)])) else pruned.phy<-phy return(pruned.phy) } # first, if drop.extinct==TRUE if(drop.extinct==TRUE) tree<-drop.extinct.tips(tree) # compute node heights root<-length(tree$tip)+1 node.height<-matrix(NA,nrow(tree$edge),2) for(i in 1:nrow(tree$edge)){ if(tree$edge[i,1]==root){ node.height[i,1]<-0.0 node.height[i,2]<-tree$edge.length[i] } else { node.height[i,1]<-node.height[match(tree$edge[i,1],tree$edge[,2]),2] node.height[i,2]<-node.height[i,1]+tree$edge.length[i] } } ltt<-vector() tree.length<-max(node.height) # tree length n.extinct<-sum(node.height[tree$edge[,2]<=length(tree$tip),2]<(tree.length-tol)) # fudge things a little bit node.height[tree$edge[,2]<=length(tree$tip),2]<-node.height[tree$edge[,2]<=length(tree$tip),2]+1.1*tol time<-c(0,node.height[,2]); names(time)<-as.character(c(root,tree$edge[,2])) temp<-vector() time<-time[order(time)] time<-time[1:(tree$Nnode+n.extinct+1)] # times # get numbers of lineages for(i in 1:(length(time)-1)){ ltt[i]<-0 for(j in 1:nrow(node.height)) ltt[i]<-ltt[i]+(time[i]>=(node.height[j,1]-tol)&&time[i]<=(node.height[j,2]-tol)) } ltt[i+1]<-0 for(j in 1:nrow(node.height)) ltt[i+1]<-ltt[i+1]+(time[i+1]<=(node.height[j,2]+tol)) # set names (these are the node indices) names(ltt)<-names(time) # append 0,1 for time 0 ltt<-c(1,ltt) time<-c(0,time) # subtract fudge factor time[length(time)]<-time[length(time)]-1.1*tol } if(!is.null(node.names)){ nn<-sapply(names(time),function(x,y) if(any(names(y)==x)) y[which(names(y)==x)] else "",y=node.names) names(ltt)<-names(time)<-nn } if(gamma==FALSE){ obj<-list(ltt=ltt,times=time,tree=tree) class(obj)<-"ltt" } else { gam<-gammatest(list(ltt=ltt,times=time)) obj<-list(ltt=ltt,times=time,gamma=gam$gamma,p=gam$p,tree=tree) class(obj)<-"ltt" } } if(plot) plot(obj,log.lineages=log.lineages,...) obj } # function computes the gamma-statistic & a two-tailed P-value # written by Liam Revell 2011 gammatest<-function(x){ n<-max(x$ltt) g<-vector() for(i in 2:(length(x$times))) g[i-1]<-x$times[i]-x$times[i-1] T<-sum((2:n)*g[2:n]) doublesum<-0 for(i in 1:(n-1)) for(k in 1:i) doublesum<-doublesum+k*g[k] gamma<-(1/(n-2)*doublesum-T/2)/(T*sqrt(1/(12*(n-2)))) p<-2*pnorm(abs(gamma),lower.tail=F) return(list(gamma=gamma,p=p)) } ## S3 print method for object of class "ltt" ## written by Liam J. Revell 2015 print.ltt<-function(x,digits=4,...){ cat("Object of class \"ltt\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree), " tips and ",x$tree$Nnode," internal nodes.\n\n",sep= "")) cat(paste("(2) Vectors containing the number of lineages (ltt) ", "and branching times (times) on the tree.\n\n",sep="")) if(!is.null(x$gamma)) cat(paste("(3) A value for Pybus & Harvey's \"gamma\"", " statistic of ",round(x$gamma,digits),", p-value = ", round(x$p,digits),".\n\n",sep="")) } ## S3 print method for object of class "multiLtt" ## written by Liam J. Revell 2015 print.multiLtt<-function(x,...){ cat(paste(length(x),"objects of class \"ltt\" in a list\n")) } ## S3 plot method for object of class "ltt" ## written by Liam J. Revell 2015 plot.ltt<-function(x,...){ args<-list(...) args$x<-x$time if(!is.null(args$log.lineages)){ logl<-args$log.lineages args$log.lineages<-NULL } else logl<-TRUE if(!is.null(args$show.tree)){ show.tree<-args$show.tree args$show.tree<-NULL } else show.tree<-FALSE if(!is.null(args$transparency)){ transparency<-args$transparency args$transparency<-NULL } else transparency<-0.3 args$y<-if(logl) log(x$ltt) else x$ltt if(is.null(args$xlab)) args$xlab<-"time" if(is.null(args$ylab)) args$ylab<-if(logl) "log(lineages)" else "lineages" if(is.null(args$type)) args$type<-"s" if(hasArg(add)){ add<-list(...)$add args$add<-NULL } else add<-FALSE if(!add) do.call(plot,args) else do.call(lines,args) if(show.tree){ tips<-if(par()$ylog) setNames(exp(1:Ntip(x$tree)),x$tree$tip.label) else setNames(1:Ntip(x$tree),x$tree$tip.label) plotTree(x$tree,color=rgb(0,0,1,transparency), ftype="off",add=TRUE,mar=par()$mar,tips=tips) } } ## S3 plot method for object of class "multiLtt" ## written by Liam J. Revell 2015 plot.multiLtt<-function(x,...){ max.lineages<-max(sapply(x,function(x) max(x$ltt))) max.time<-max(sapply(x,function(x) max(x$time))) args<-list(...) if(!is.null(args$log.lineages)) logl<-list(...)$log.lineages else logl<-TRUE if(is.null(args$xlim)) args$xlim<-c(0,max.time) if(is.null(args$ylim)) args$ylim<-if(logl) c(0,log(max.lineages)) else c(0,max.lineages) args$x<-x[[1]] do.call(plot,args) args$add<-TRUE if(!is.null(args$log)) args$log<-NULL if(length(x)>2){ for(i in 2:length(x)){ args$x<-x[[i]] do.call(plot,args) } } else { args$x<-x[[2]] do.call(plot,args) } } phytools/R/add.random.R0000644000176200001440000000247412562127030014473 0ustar liggesusers# function adds a set of tips to random positions in the tree # written by Liam J. Revell 2013, 2015 add.random<-function(tree,n=NULL,tips=NULL,edge.length=NULL,order=c("random","input")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # internal function randomPosn<-function(tree){ # sum edges cumulatively cum.edge<-cumsum(tree$edge.length) index<-tree$edge[,2] # pick random position pos<-runif(1)*sum(tree$edge.length) edge<-1; while(pos>cum.edge[edge]) edge<-edge+1 return(list(node=index[edge],posn=cum.edge[edge]-pos)) } # check if tree is ultrametric (required) if(is.ultrametric(tree)) um<-TRUE else um<-FALSE # set n and/or name tips (if not provided) if(is.null(tips)){ if(is.null(n)) n<-1 tips<-paste("t",length(tree$tip)+1:n,sep="") } else n<-length(tips) if(is.null(edge.length)) if(!um) edge.length<-runif(n=n,min=min(tree$edge.length),max=max(tree$edge.length)) # set order if(order[1]=="random"){ o<-sample(1:n) tips<-tips[o] if(!is.null(edge.length)) edge.length<-edge.length[o] } # add tips for(i in 1:n){ where<-randomPosn(tree) if(is.null(edge.length)) tree<-bind.tip(tree,tips[i],where=where$node,position=where$posn) else tree<-bind.tip(tree,tips[i],where=where$node,position=where$posn,edge.length=edge.length[i]) } return(tree) } phytools/R/mcmcLambda.R0000644000176200001440000001265412107744173014515 0ustar liggesusers# function # written by Liam J. Revell 2011, 2012, 2013 mcmcLambda<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) lambda<-1.0; max.lambda<-maxLambda(tree) a<-mean(xbar) intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T) prop<-c(0.01*sig2,0.02,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV) pr.mean<-c(1000,max.lambda/2,rep(0,n+1),1000) pr.var<-c(pr.mean[1]^2,max.lambda,rep(1000,n+1),pr.mean[length(pr.mean)]^2) # populate control list con=list(sig2=sig2,lambda=lambda,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,lambda,a,xbar,intV){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+dunif(lambda,min=con$pr.mean[2]-con$pr.var[2]/2,max=con$pr.mean[2]+con$pr.var[2]/2,log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T) return(pp) } # compute (starting values for) C C1<-vcv.phylo(tree) # used for updates of lambda C<-lambda.transform(con$lambda,C1) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; lambda<-con$lambda; a<-con$a; xbar<-con$xbar; intV<-con$intV L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV) Pr<-log.prior(sig2,lambda,a,xbar,intV) # store X<-matrix(NA,ngen/con$sample+1,n+6,dimnames=list(NULL,c("gen","sig2","lambda","a",tree$tip.label,"var","logLik"))) X[1,]<-c(0,sig2,lambda,a,xbar,intV,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(n+4) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV) Pr.prime<-log.prior(sig2.prime,lambda,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,lambda,a,xbar,intV,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j==1){ # update lambda lambda.prime<-lambda+rnorm(n=1,sd=sqrt(con$prop[j+1])) while(lambda.prime<0||lambda.prime>max.lambda){ if(lambda.prime<0) lambda.prime<--lambda.prime if(lambda.prime>max.lambda) lambda.prime<-2*max.lambda-lambda.prime } # update C with new lambda C.prime<-lambda.transform(lambda.prime,C1) invC.prime<-solve(C.prime) detC.prime<-determinant(C.prime,logarithm=TRUE)$modulus[1] L.prime<-likelihood(C.prime,invC.prime,detC.prime,x,sig2,a,xbar,intV) Pr.prime<-log.prior(sig2,lambda.prime,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda.prime,a,xbar,intV,L.prime) lambda<-lambda.prime C<-C.prime; invC<-invC.prime; detC<-detC.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j==2){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV) Pr.prime<-log.prior(sig2,lambda,a.prime,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a.prime,xbar,intV,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j>2&&j<=(n+2)) { k<-j-2 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV) Pr.prime<-log.prior(sig2,lambda,a,xbar.prime,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar.prime,intV,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j>(n+2)){ # update var intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(intV.prime<0) intV.prime<--intV.prime L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime) Pr.prime<-log.prior(sig2,lambda,a,xbar,intV.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV.prime,L.prime) intV<-intV.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/densityTree.R0000644000176200001440000000643013100410127014746 0ustar liggesusers## function to make a color (e.g., "blue") transparent with alpha level alpha make.transparent<-function(color,alpha){ RGB<-col2rgb(color)[,1]/255 rgb(RGB[1],RGB[2],RGB[3],alpha) } ## function to be used internally rescaleTree<-function(tree,scale){ tree$edge.length<-tree$edge.length/max(nodeHeights(tree))*scale tree } ## function to plot a posterior density of trees (e.g., densiTree in phangorn) ## written by Liam J. Revell 2016, 2017 densityTree<-function(trees,colors="blue",alpha=NULL,method="plotTree", fix.depth=FALSE,use.edge.length=TRUE,compute.consensus=TRUE, use.gradient=FALSE,show.axis=TRUE,...){ N<-length(trees) if(any(sapply(trees,function(x) is.null(x$edge.length)))) use.edge.length<-FALSE if(!use.edge.length){ trees<-lapply(trees,compute.brlen) class(trees)<-"multiPhylo" } h<-sapply(trees,function(x) max(nodeHeights(x))) if(fix.depth){ if(method=="plotTree"){ trees<-lapply(trees,rescaleTree,mean(h)) class(trees)<-"multiPhylo" } else if(method=="plotSimmap"){ trees<-rescaleSimmap(trees,depth=mean(h)) } h<-sapply(trees,function(x) max(nodeHeights(x))) } tips<-setNames(1:Ntip(trees[[1]]), if(compute.consensus) untangle(consensus(trees), "read.tree")$tip.label else trees[[1]]$tip.label) if(is.null(alpha)) alpha<-max(c(1/N,0.01)) args<-list(...) args$direction<-"leftwards" args$tips<-tips args$add<-FALSE if(is.null(args$nodes)) args$nodes<-"inner" if(is.null(args$mar)) args$mar<-if(show.axis) c(4.1,1.1,1.1,1.1) else rep(1.1,4) if(is.null(args$ftype)) args$ftype<-"i" if(!use.gradient){ plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar, plot=FALSE) args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] if(method=="plotTree"){ args$color<-make.transparent(colors[1],alpha) for(i in 1:length(trees)){ args$tree<-trees[[i]] do.call(plotTree,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } else if(method=="plotSimmap"){ states<-sort(unique(as.vector(mapped.states(trees)))) if(length(colors)!=length(states)){ colors<-setNames(c("grey",palette()[2:length(states)]), states) } colors<-sapply(colors,make.transparent,alpha=alpha) args$colors<-colors for(i in 1:length(trees)){ args$tree<-trees[[i]] do.call(plotSimmap,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } } else if(use.gradient){ rf<-multiRF(trees,quiet=TRUE) mds<-cmdscale(rf,k=1)[,1] trees<-trees[order(mds)] h<-h[order(mds)] args$ylim<-c(0,Ntip(trees[[1]])+1) plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar, ylim=args$ylim,plot=FALSE) args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] colors<-sapply(rainbow(n=length(trees)),make.transparent,alpha=alpha) ftype<-args$ftype for(i in 1:length(trees)){ y.shift<-(i-median(1:length(trees)))/length(trees)/2 args$tree<-trees[[i]] args$tips<-tips+y.shift args$color<-colors[i] args$ftype<-if(i==floor(median(1:length(trees)))) ftype else "off" do.call(plotTree,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } } phytools/R/writeAncestors.R0000644000176200001440000000737612562012240015502 0ustar liggesusers# function writes a "phylo" object to a Newick string with ancestor state estimates # written by Liam J. Revell 2013, 2015 writeAncestors<-function(tree,Anc=NULL,file="",digits=6,format=c("phylip","nexus"),...){ format=format[1] if(hasArg(CI)) CI<-list(...)$CI else CI<-TRUE if(is.null(Anc)){ if(hasArg(x)){ x<-list(...)$x if(inherits(tree,"multiPhylo")){ if(is.list(x)) Anc<-mapply(fastAnc,tree,x,MoreArgs=list(CI=CI),SIMPLIFY=FALSE) else Anc<-lapply(tree,fastAnc,x=x,CI=CI) } else if(inherits(tree,"phylo")){ if(is.list(x)){ Anc<-lapply(x,fastAnc,tree=tree,CI=CI) tree<-repPhylo(tree,length(x)) class(tree)<-"multiPhylo" } else Anc<-fastAnc(tree,x,CI=CI) } } else stop("must have argument 'Anc' or 'x'") } if(format=="phylip"){ if(class(tree)=="multiPhylo") XX<-mapply(writeAnc,tree,Anc,MoreArgs=list(digits=digits)) else if(class(tree)=="phylo") XX<-writeAnc(tree,Anc,digits) else stop("tree should be an object of class 'phylo' or 'multiPhylo'") write(XX,file) invisible(XX) } else if(format=="nexus"){ writeNex(tree,Anc,file,digits) } } # internal function to create a Nexus style output file # written by Liam J. Revell 2013 writeNex<-function(tree,Anc,file="",digits){ if(inherits(tree,"multiPhylo")) N<-length(tree) else { N<-1 tree<-list(tree) Anc<-list(Anc) } n<-length(tree[[1]]$tip.label) write("#NEXUS",file) write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE) write("BEGIN TAXA;",file,append=TRUE) write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE) write("\tTAXLABELS",file,append=TRUE) trans<-tree[[1]]$tip.label; trans<-sort(trans) for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) write("END;",file,append=TRUE) write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE) for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE) write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) for(i in 1:N){ tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans)) write(paste("\tTREE * UNTITLED = [&R] ",writeAnc(tree[[i]],Anc[[i]],digits),sep=""),file,append=TRUE) } write("END;",file,append=TRUE) } # internal function to write the Newick string with ancestor states # written by Liam J. Revell writeAnc<-function(tree,Anc,digits){ tree<-reorder.phylo(tree,"cladewise") n<-length(tree$tip.label) if(!is.list(Anc)) Anc<-list(ace=Anc) Anc$ace<-Anc$ace[order(names(Anc$ace))] Anc$ace<-round(Anc$ace,digits) if(!is.null(Anc$CI95)){ Anc$CI95<-round(Anc$CI95,digits) tree$node.label<-paste("[&CI={",Anc$CI95[,1],",",Anc$CI95[,2],"},ancstate={",Anc$ace,"}]",sep="") } else { Anc$CI95<-Anc$CI95[names(Anc$ace),] tree$node.label<-paste("[&ancstate={",Anc$ace,"}]",sep="") } tree$edge.length<-round(tree$edge.length,digits) string<-vector(); string[1]<-"("; j<-2 for(i in 1:nrow(tree$edge)){ if(tree$edge[i,2]<=n){ string[j]<-tree$tip.label[tree$edge[i,2]]; j<-j+1 if(!is.null(tree$edge.length)){ string[j]<-paste(c(":",tree$edge.length[i]),collapse="") j<-j+1 } v<-which(tree$edge[,1]==tree$edge[i,1]); k<-i while(length(v)>0&&k==v[length(v)]){ string[j]<-")"; j<-j+1 string[j]<-tree$node.label[tree$edge[k,1]-n]; j<-j+1 w<-which(tree$edge[,2]==tree$edge[k,1]) if(!is.null(tree$edge.length)){ string[j]<-paste(c(":",tree$edge.length[w]),collapse="") j<-j+1 } v<-which(tree$edge[,1]==tree$edge[w,1]); k<-w } string[j]<-","; j<-j+1 } else if(tree$edge[i,2]>=n){ string[j]<-"("; j<-j+1 } } if(is.null(tree$edge.length)) string<-c(string[1:(length(string)-1)],";") else string<-c(string[1:(length(string)-2)],";") string<-paste(string,collapse="") return(string) } phytools/R/collapseTree.R0000644000176200001440000002224313163012465015105 0ustar liggesusers## function to interactively expand and contract subtrees on a phylogeny ## inspired by the phylogeny interface of sharksrays.org by Gavin Naylor ## written by Liam J. Revell 2015, 2016, 2017 collapseTree<-function(tree,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-TRUE if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(drop.extinct)) drop.extinct<-list(...)$drop.extinct else drop.extinct=FALSE if(is.null(tree$edge.length)){ no.edge<-TRUE tree<-compute.brlen(tree,power=0.5) } else no.edge<-FALSE cat("Click on the nodes that you would like to collapse...\n") ## turn off locator bell (it's annoying) options(locatorBell=FALSE) ## check for node labels if(is.null(tree$node.label)) tree$node.label<-as.character(Ntip(tree)+1:tree$Nnode) else if(any(tree$node.label=="")){ tree$node.label[which(tree$node.label)==""]<- which(tree$node.label=="")+Ntip(tree) } ## remove any spaces tree$node.label<-sapply(tree$node.label,gsub,pattern=" ",replacement="_") tree$tip.label<-sapply(tree$tip.label,gsub,pattern=" ",replacement="_") ## copy original tree: otree<-tree<-reorder(tree) ## plot initial tree: if(hold) dev.hold() fan(tree,...) lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) check<-textbox(x=c(par()$usr[1],par()$usr[1]+ 0.1*(par()$usr[2]-par()$usr[1])), y=par()$usr[4],c("click to stop"),justify="c") dev.flush() x<-unlist(locator(1)) y<-x[2] x<-x[1] d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2) nn<-which(d==min(d,na.rm=TRUE)) ## collapse tree & replot: while(!(x>par()$usr[1]&&xcheck&&y(Ntip(tree)+1)){ obj<-splitTree(tree,list(node=nn, bp=tree$edge.length[which(tree$edge[,2]==nn)])) obj[[1]]$tip.label[which(obj[[1]]$tip.label=="NA")]<- tree$node.label[nn-Ntip(tree)] tips<-which(tree$tip.label%in%obj[[1]]$tip.label) theta<-atan(lastPP$yy[nn]/lastPP$xx[nn]) if(lastPP$yy[nn]>0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]>0) theta<-2*pi+theta ii<-which((c(tips,Ntip(tree)+1)-c(0,tips))>1) if(ii>1&&ii<=length(tips)) tips<-c(tips[1:(ii-1)],theta/(2*pi)*Ntip(tree),tips[ii:length(tips)]) else if(ii==1) tips<-c(theta/(2*pi)*Ntip(tree),tips) else if(ii>length(tips)) tips<-c(tips,theta/(2*pi)*Ntip(tree)) tree<-read.tree(text=write.tree(obj[[1]])) M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips)) for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M)) colnames(M)<-tree$tip.label maxY<-seq(from=sum(sapply(obj,Ntip))-length(obj)+1,to=Ntip(tree),length.out=nrow(M)) pw<-reorder(tree,"pruningwise") H<-nodeHeights(tree) for(i in 1:nrow(M)){ if(hold) dev.hold() fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim, tips=M[i,],maxY=maxY[i],...) if(nodes||i==nrow(M)){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) } dev.flush() } } else if(nn<=Ntip(tree)) { if(tree$tip.label[nn]%in%otree$node.label){ on<-which(otree$node.label==tree$tip.label[nn])+Ntip(otree) obj<-splitTree(otree,list(node=on, bp=otree$edge.length[which(otree$edge[,2]==on)])) nlabel<-tree$tip.label[nn] tree$tip.label[nn]<-"NA" if(nn==1) tips<-c(rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree)) else if(nn>1&&nn0.25&&part<=0.5){ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) y.lim<-c(0,max(R)+sw/alp) } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) xlim<-x.lim ylim<-y.lim } # plot tree if(!add) plot.new() plot.window(xlim=xlim,ylim=ylim,asp=1) # plot radial lines (edges) segments(x[,1],y[,1],x[,2],y[,2],col=colors,lwd=lwd,lend=2) # plot circular lines ii<-sapply(1:m+n,function(x,y) which(y==x),y=cw$edge) r<-sapply(1:m+n,function(x,y,R) R[match(x,y)],y=cw$edge,R=R) a1<-sapply(ii,function(x,Y) min(Y[x]),Y=Y) a2<-sapply(ii,function(x,Y) max(Y[x]),Y=Y) draw.arc(rep(0,tree$Nnode),rep(0,tree$Nnode),r,a1,a2,lwd=lwd,col=colors) # plot labels cw$tip.label<-gsub("_"," ",cw$tip.label) for(i in 1:n){ ii<-which(cw$edge[,2]==i) aa<-Y[ii,2]/(2*pi)*360 adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25) tt<-if(aa>90&&aa<270) paste(cw$tip.label[i]," ",sep="") else paste(" ", cw$tip.label[i],sep="") aa<-if(aa>90&&aa<270) 180+aa else aa if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype) } PP<-list(type="fan",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black", Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge, xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],x[1,1], if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()), yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],y[1,1], if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c())) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } phytools/R/fancyTree.R0000644000176200001440000002535013101716170014401 0ustar liggesusers# function to plot special types of phylogeny visualizations # so far the implemented types are: # "extinction" in which all branches leading to extinct taxa (or prior to the MRCA of extant species) are plotted with red dashed lines; # "traitgram3d" which creates a 3D graph projecting the tree into two-dimensional morphospace (with time as the third axis) # "droptip" creates a two panel plot with the tips to be pruned marked (panel 1) and then removed, and returns the pruned tree # "xkcd" creates an xkcd-comic style phylogeny [no longer an option] # "densitymap" maps the posterior density of a binary stochastic character mapping # "contmap" maps reconstructed trait evolution for a continuous character on the tree # "phenogram95" plots a 95% CI phenogram # "scattergram" plots a phylogenetic scatterplot matrix # written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2017 fancyTree<-function(tree,type=c("extinction","traitgram3d","droptip","densitymap","contmap","phenogram95","scattergram"),...,control=list()){ type<-matchType(type,c("extinction","traitgram3d","droptip","densitymap","contmap","phenogram95","scattergram")) if(!inherits(tree,"phylo")&&type%in%c("extinction","traitgram3d","droptip")) stop("tree should be an object of class \"phylo\".") else if(!inherits(tree,"multiPhylo")&&type=="densitymap") stop("for type='densitymap' tree should be an object of class \"multiPhylo\".") if(type=="extinction") extinctionTree(tree) else if(type=="traitgram3d") invisible(traitgram3d(tree,...,control=control)) else if(type=="droptip") return(droptipTree(tree,...)) else if(type=="densitymap") plotDensityMap(tree,...) else if(type=="contmap") plotContMap(tree,...) else if(type=="phenogram95") phenogram95(tree,...) else if(type=="scattergram") invisible(phyloScattergram(tree,...)) else stop(paste("do not recognize type = \"",type,"\"",sep="")) } ## phyloScattergram internal function ## written by Liam J. Revell 2013, 2014, 2017 phyloScattergram<-function(tree,...){ if(hasArg(X)) X<-list(...)$X else stop("phenotypic data should be provided in the matrix X") if(is.data.frame(X)) X<-as.matrix(X) if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-0.7 if(hasArg(colors)) colors<-list(...)$colors else if(!is.null(tree$maps)) colors<-setNames(palette()[1:ncol(tree$mapped.edge)], sort(colnames(tree$mapped.edge))) if(hasArg(label)) label<-list(...)$label else label<-"radial" if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE m<-ncol(X) if(hold) null<-dev.hold() if(!quiet&&hold){ cat("Computing multidimensional phylogenetic scatterplot matrix...\n") flush.console() } par(mfrow=c(m,m)) par(cex=fsize) par(mar=c(0,0,0,0)) par(oma=c(5,5,3,3)) m<-ncol(X) A<-apply(X,2,fastAnc,tree=tree) cmaps<-list() for(i in 1:m) for(j in 1:m){ if(i==j) cmaps[[i]]<-contMap(tree,X[,i], legend=FALSE,lwd=2,outline=F,fsize=fsize) else { phylomorphospace(tree,X[,c(j,i)],A=A[,c(j,i)],lwd=1, node.by.map=TRUE,axes=FALSE,node.size=c(0,1), colors=colors,label=label,xlab="",ylab="") if(i==1) axis(side=3) # top row if(i==m) axis(side=1) # first column if(j==1) axis(side=2) # bottom row if(j==m) axis(side=4) # last column } } par(cex=0.9) if(is.null(colnames(X))) colnames(X)<-paste("V",1:m,sep="") invisible(mapply(title,xlab=colnames(X), adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) invisible(mapply(title,ylab=colnames(X)[m:1], adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) if(hold) null<-dev.flush() obj<-list(tree=tree,contMaps=cmaps,X=X,A=A) class(obj)<-"phyloScattergram" obj } plot.phyloScattergram<-function(x,...){ if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-0.7 if(hasArg(colors)) colors<-list(...)$colors else if(!is.null(x$tree$maps)) colors<-setNames(palette()[1:ncol(x$tree$mapped.edge)], sort(colnames(x$tree$mapped.edge))) if(hasArg(label)) label<-list(...)$label else label<-"radial" m<-ncol(x$X) par(mfrow=c(m,m)) par(cex=fsize) par(mar=c(0,0,0,0)) par(oma=c(5,5,3,3)) for(i in 1:m) for(j in 1:m){ if(i==j) plot(x$contMaps[[i]],legend=FALSE, lwd=2,outline=FALSE,fsize=fsize) else { phylomorphospace(x$tree,x$X[,c(j,i)],A=x$A[,c(j,i)],lwd=1, node.by.map=TRUE,axes=FALSE,node.size=c(0,1), colors=colors,label=label,xlab="",ylab="") if(i==1) axis(side=3) # top row if(i==m) axis(side=1) # first column if(j==1) axis(side=2) # bottom row if(j==m) axis(side=4) # last column } } par(cex=0.9) if(is.null(colnames(x$X))) colnames(x$X)<-paste("V",1:m,sep="") invisible(mapply(title,xlab=colnames(x$X), adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) invisible(mapply(title,ylab=colnames(x$X)[m:1], adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) } print.phyloScattergram<-function(x,...) cat(paste("\nObject of class \"phyloScattergram\" for",ncol(x$X), "continuous traits.\n\n")) # phenogram95 internal function # written by Liam J. Revell 2013, 2014 phenogram95<-function(tree,...){ if(hasArg(x)) x<-list(...)$x else stop("no phenotypic data provided") if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels else spread.labels<-TRUE if(hasArg(link)) link<-list(...)$link else link<-0.05*max(nodeHeights(tree)) if(hasArg(offset)) offset<-list(...)$offset else offset<-0 if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # get ancestral states A<-fastAnc(tree,x,CI=TRUE) # compute transparencies if(hasArg(tlim)) tlim<-list(...)$tlim else tlim<-c(0,25) trans<-as.character(floor(seq(tlim[1],tlim[2],length.out=51))) trans[as.numeric(trans)<10]<-paste("0", trans[as.numeric(trans)<10],sep="") # now get the arguments for phenogram args<-list(...) args$tree<-tree args$lwd<-1 args$link<-0.05*max(nodeHeights(tree)) args$offset<-0 if(hold) null<-dev.hold() if(!quiet&&hold){ cat("Computing density traitgram...\n") flush.console() } for(i in 0:50){ p<-i/length(trans) args$add<-i>0 args$spread.labels<-if(i==0) spread.labels else FALSE args$link<-if(i==0) link else 0 args$offset<-if(i==0) offset else offset+link args$x<-c(x,(1-p)*A$CI95[,1]+p*A$ace) args$colors<-paste("#0000ff",trans[i+1],sep="") do.call(phenogram,args) args$x<-c(x,(1-p)*A$CI95[,2]+p*A$ace) args$add<-TRUE args$spread.labels<-FALSE args$link<-0 args$offset<-offset+link do.call(phenogram,args) } args$x<-c(x,A$ace) args$add<-TRUE args$colors<-"white" args$lwd<-2 args$offset<-offset+link do.call(phenogram,args) null<-dev.flush() } # extinctionTree internal function # written by Liam J. Revell 2012 extinctionTree<-function(tree){ edges<-rep(0,nrow(tree$edge)) names(edges)<-tree$edge[,2] extant<-getExtant(tree) ca<-findMRCA(tree,extant) root.node<-length(tree$tip)+1 if(ca!=root.node){ z<-setdiff(getDescendants(tree,root.node),getDescendants(tree,ca)) edges[as.character(z)]<-1 } z<-getDescendants(tree,ca) y<-lapply(z,getDescendants,tree=tree) for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%extant)) edges[as.character(z[i])]<-1 plot.phylo(tree,edge.color=edges+1,edge.lty=edges+1,edge.width=2,no.margin=TRUE) } # traitgram3d internal function # written by Liam J. Revell 2012, 2013 traitgram3d<-function(tree,...,control){ if(hasArg(X)) X<-list(...)$X else stop("no phenotypic data provided") if(!hasArg(A)){ if(is.null(control$maxit)) maxit<-2000 else maxit<-control$maxit Y<-apply(X,2,function(x,tree) anc.ML(tree,x,maxit),tree=tree) convergence<-sapply(Y,function(x) x$convergence) if(any(convergence!=0)) warning("anc.ML may not have converged; consider increasing maxit.") A<-sapply(Y,function(x) x$ace) } else { A<-list(...)$A A<-A[as.character(1:tree$Nnode+length(tree$tip)),] } if(is.null(colnames(X))) colnames(X)<-c("x","y") X<-cbind(X,diag(vcv(tree))[rownames(X)]) A<-cbind(A,nodeHeights(tree)[match(rownames(A)[1:nrow(A)],tree$edge)]) colnames(X)[3]<-colnames(A)[3]<-"time" # other optional arguments if(hasArg(method)) method<-list(...)$method else method<-"dynamic" if(hasArg(angle)) angle<-list(...)$angle else angle<-30 # done other optional arguments xx<-phylomorphospace3d(tree,X,A,control=control,method=method,angle=angle,zlim=range(nodeHeights(tree))) return(xx) } # droptipTree internal function # written by Liam J. Revell 2012 droptipTree<-function(tree,...){ if(hasArg(tip)) tip<-list(...)$tip else stop("need to provide tip or tips to drop") edges<-rep(0,nrow(tree$edge)) names(edges)<-tree$edge[,2] keep<-setdiff(tree$tip.label,tip) ca<-findMRCA(tree,keep) root.node<-length(tree$tip)+1 if(ca!=root.node){ z<-setdiff(getDescendants(tree,root.node),getDescendants(tree,ca)) edges[as.character(z)]<-1 } z<-getDescendants(tree,ca) foo<-function(x,tree){ n<-length(tree$tip.label) y<-getDescendants(tree,x) y<-y[y<=n] return(y) } y<-lapply(z,foo,tree=tree) for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%keep)) edges[as.character(z[i])]<-1 par(mfrow=c(2,1)) plot.phylo(tree,edge.color=edges+1,edge.lty=edges+1,edge.width=2,no.margin=TRUE) dtree<-drop.tip(tree,tip); dtree$root.edge<-max(nodeHeights(tree))-max(nodeHeights(dtree)) plot.phylo(dtree,edge.width=2,no.margin=TRUE,root.edge=TRUE) return(dtree) } # plotDensityMap internal function # written by Liam J. Revell 2012 plotDensityMap<-function(trees,...){ if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3 if(hasArg(check)) check<-list(...)$check else check<-FALSE if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-FALSE densityMap(trees,res,fsize,check,legend,outline) } # plotContMap internal function # written by Liam J. Revell 2012 plotContMap<-function(tree,...){ if(hasArg(x)) x<-list(...)$x else stop("need to provide vector 'x' of phenotypic trait values") if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-4 if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(lims)) lims<-list(...)$lims else lims<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-TRUE if(hasArg(sig)) sig<-list(...)$sig else sig<-3 contMap(tree,x,res,fsize,ftype,lwd,legend,lims,outline,sig) } phytools/R/pbtree.R0000644000176200001440000002053312463523714013752 0ustar liggesusers# function to simulate a pure-birth phylogenetic tree or trees # written by Liam J. Revell 2011-2015 pbtree<-function(b=1,d=0,n=NULL,t=NULL,scale=NULL,nsim=1,type=c("continuous","discrete"),...){ # get arguments if(hasArg(ape)) ape<-list(...)$ape else ape<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(extant.only)) extant.only<-list(...)$extant.only else extant.only<-FALSE if(hasArg(max.count)) max.count<-list(...)$max.count else max.count<-1e5 if(hasArg(method)) method<-list(...)$method else method<-"rejection" if(hasArg(tip.label)){ tip.label<-list(...)$tip.label if(!is.null(tip.label)){ if(is.null(n)){ tip.label<-NULL cat("Warning: tip.label not allowed for n=NULL.\n") cat(" using default labels\n") } else if(length(tip.label)==n){ if(d>0){ cat("Warning: only using labels in tip.label for extant tips.\n") cat(" extinct tips will be labeled X1, X2, etc.\n") } } else if(length(tip.label)!=n) { cat("Warning: length(tip.label) and n do not match.\n") cat(" using default labels\n") tip.label<-NULL } } } else tip.label<-NULL type<-matchType(type[1],c("continuous","discrete")) if(type=="discrete"){ if((b+d)>1){ cat("Warning:\n b + d cannot exceed 1.0 in discrete-time simulations\n") cat(paste(" setting b & d to",b/(b+d),"and",d/(b+d),"respectively\n")) b<-b/(b+d) d<-d/(b+d) } } tol<-1e-12 # done get arguments # if nsim > 1 replicate nsim times if(nsim>1){ trees<-replicate(nsim,pbtree(b,d,n,t,scale,type=type,ape=ape,quiet=quiet,extant.only=extant.only,method=method,tip.label=tip.label),simplify=FALSE) class(trees)<-"multiPhylo" return(trees) } else { if(!is.null(n)) NN<-n else NN<-NULL if(!is.null(n)&&!is.null(t)){ if(method=="rejection"){ # simulate taxa & time stop using rejection sampling to max.count if(!quiet){ cat("simulating with both taxa-stop (n) and time-stop (t) is\n") cat("performed via rejection sampling & may be slow\n\n") } N<-0; T<-0; count<--1 while((N!=n||T0&&extant.only==FALSE) length(getExtant(tree)) else length(tree$tip.label) T<-max(nodeHeights(tree)) } count<-count+1 } if(N==n&&T>=(t-tol)){ if(!quiet) cat(paste(" ",count," trees rejected before finding a tree\n\n",sep="")) } else { if(!quiet) cat(paste(" max count of ",count," reached without finding a tree\n\n",sep="")) tree<-NULL } # done simulate taxa & time stop } else if(method=="direct"){ # simulate using direct sampling (experimental) if(!quiet){ cat("simulating with both taxa-stop (n) & time-stop (t) using\n") cat("'direct' sampling. this is experimental\n") } m<-2 while(m[length(m)]!=n){ ll<-bd<-vector(); m<-2; i<-1 while(sum(ll)1) sample(p,size=1) else p if(birth){ # new edge edge[q,2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q,2]<--dead dead<-dead+1 } edge.length[p]<-edge.length[p]+l if(birth) edge.length<-c(edge.length,rep(0,2)) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) n<-sum(o) edge<-edge+n p<-which(o) edge[o,2]<-1:sum(is.na(edge[,2])) # build 'phylo' object tree<-list(edge=edge,edge.length=edge.length,tip.label=paste("t",1:n,sep=""),Nnode=n-1) class(tree)<-"phylo" # done simulate using direct sampling (experimental) } } else { if(!is.null(t)){ # simulation time stop node<-1; dead<-1 edge<-matrix(c(node,NA,node,NA),2,2,byrow=T) edge.length<-c(0,0) node<-node+1; tt<-0 while(tt=t) l<-l-tt+t else { birth<-sapply(runif(n=length(l)),function(x) if(x1) sample(p)[1:min(length(p),length(l))] else p for(i in 1:length(l)){ if(birth[i]){ # new edge edge[q[i],2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q[i],2]<--dead dead<-dead+1 } } } edge.length[p]<-edge.length[p]+l[1] edge.length<-c(edge.length,rep(0,2*length(l))) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) n<-sum(o) edge<-edge+n p<-which(o) edge[o,2]<-1:sum(is.na(edge[,2])) # done unique part of time stop } else if(!is.null(n)) { # simulate taxa stop node<-1 edge<-matrix(c(node,NA,node,NA),2,2,byrow=T) edge.length<-c(0,0) node<-node+1; dead<-1; nn<-2 while(nn1) sample(p)[1:min(length(p),length(l))] else p for(i in 1:length(l)){ if(birth[i]){ # new edge edge[q[i],2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q[i],2]<--dead dead<-dead+1 } } edge.length[p]<-edge.length[p]+l[1] edge.length<-c(edge.length,rep(0,2*length(l))) nn<-sum(is.na(edge[,2])) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) nn<-sum(o) edge<-edge+nn p<-which(o) l<-if(type=="discrete") min(rgeom(n=sum(o),prob=(b+d))+1) else rexp(n=1,sum(o)*(b+d)) edge.length[p]<-edge.length[p]+l edge[is.na(edge[,2]),2]<-1:sum(is.na(edge[,2])) if((nn-dead+1)>n&&!quiet){ # this might happen in discrete time only cat("Warning:\n due to multiple speciation events in the final time interval\n") cat(" realized n may not equal input n\n\n") if(!is.null(tip.label)){ cat("Warning: length(tip.label) and n do not match.\n") cat(" using default labels\n") tip.label<-NULL } } n<-nn # done unique part of taxa stop } # build 'phylo' object with temporary labels tree<-list(edge=edge,edge.length=edge.length,tip.label=1:n,Nnode=n-1) class(tree)<-"phylo" if(!is.null(scale)){ # rescale if scale!=NULL h<-max(nodeHeights(tree)) tree$edge.length<-scale*tree$edge.length/h } if(d>0&&extant.only){ # prune extinct tips if extant.only==TRUE if(length(getExtinct(tree))==(length(tree$tip.label)-1)){ if(!quiet) cat("Warning:\n no extant tips, tree returned as NULL\n") tree<-NULL } else tree<-drop.tip(tree,getExtinct(tree)) } # if tree!=NULL assign final tip labels if(!is.null(tree)) tree$tip.label<-paste("t",1:length(tree$tip.label),sep="") } # if ape==TRUE make sure 'phylo' is consistent with ape if(ape&&is.null(tree)==FALSE) tree<-read.tree(text=write.tree(tree)) if(!is.null(tip.label)){ th<-max(nodeHeights(tree)) if(length(getExtant(tree,tol=1e-08*th))!=NN){ # simulation must have gone extint before reaching NN tree$tip.label<-paste("X",1:length(tree$tip.label),sep="") } else { ll<-getExtant(tree,tol=1e-08*th) ii<-sapply(ll,function(x,y) which(x==y),y=tree$tip.label) tree$tip.label[ii]<-tip.label tree$tip.label[-ii]<-paste("X",1:(length(tree$tip.label)-length(ii)),sep="") } } # done return(tree) } } phytools/R/cospeciation.R0000644000176200001440000000644313006153505015144 0ustar liggesusers## cospeciation method ## written by Liam J. Revell 2016 cospeciation<-function(t1,t2,distance=c("RF","SPR"), method=c("simulation","permutation"),assoc=NULL, nsim=100,...){ distance<-distance[1] if(!distance%in%c("RF","SPR")) distance<-"RF" method<-method[1] if(!method%in%c("simulation","permutation")) method<-"simulation" if(is.null(assoc)){ ## assume exact match tips<-intersect(t1$tip.label,t2$tip.label) assoc<-cbind(tips,tips) } if(any(!t1$tip.label%in%assoc[,1])) t1<-drop.tip(t1,setdiff(t1$tip.label,assoc[,1])) if(any(!assoc[,1]%in%t1$tip.label)) assoc<-assoc[assoc[,1]%in%t1$tip.label,] if(any(!t2$tip.label%in%assoc[,2])) t2<-drop.tip(t2,setdiff(t2$tip.label,assoc[,2])) if(any(!assoc[,2]%in%t2$tip.label)) assoc<-assoc[assoc[,2]%in%t2$tip.label,] if(method=="permutation"){ perm.labels<-function(tree){ tree$tip.label<-sample(tree$tip.label) tree } tt1<-replicate(nsim,perm.labels(t1),simplify=FALSE) swap.t2<-t2 swap.t2$tip.label<-sapply(t2$tip.label,function(x,y) y[which(y[,2]==x),1],y=assoc) tt2<-replicate(nsim,perm.labels(swap.t2),simplify=FALSE) } else { tt1<-pbtree(n=Ntip(t1),tip.label=t1$tip.label, nsim=nsim) swap.t2<-t2 swap.t2$tip.label<-sapply(t2$tip.label,function(x,y) y[which(y[,2]==x),1],y=assoc) tt2<-pbtree(n=Ntip(t2),tip.label=swap.t2$tip.label, nsim=nsim) } if(distance=="SPR"){ d.null<-mapply(SPR.dist,tt1,tt2) d<-SPR.dist(t1,swap.t2) P.val<-mean(c(d,d.null)<=d) } else { d.null<-mapply(RF.dist,tt1,tt2) d<-RF.dist(t1,swap.t2) P.val<-mean(c(d,d.null)<=d) } obj<-list(d=d,d.null=d.null,P.val=P.val, distance=if(distance=="SPR") "SPR" else "RF", method=if(method=="simulation") "simulation" else "permutation") class(obj)<-"cospeciation" obj } print.cospeciation<-function(x,...){ cat(paste("\nCo-speciation test based on",x$distance, "distance.\n")) cat(paste("P-value obtained via",x$method,".\n\n")) if(x$distance=="SPR") cat(paste(" SPR distance:",x$d,"\n")) else cat(paste(" RF distance:",x$d,"\n")) cat(paste(" Mean(SD) from null: ", round(mean(x$d.null),1),"(", round(sd(x$d.null),1),")\n",sep="")) cat(paste(" P-value:",round(x$P.val,6),"\n\n")) } plot.cospeciation<-function(x,...){ if(x$distance=="RF") p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-3, max(c(x$d,x$d.null))+3,2),plot=FALSE) else if(x$distance=="SPR") p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-1.5, max(c(x$d,x$d.null))+1.5,1),plot=FALSE) plot(p$mids,p$density,xlim=c(min(c(x$d,x$d.null))-2, max(c(x$d,x$d.null))+1),ylim=c(0,1.2*max(p$density)), type="n", xlab=paste(x$distance," distance (null by ", x$method,")",sep=""),ylab="relative frequency") y2<-rep(p$density,each=2) y2<-y2[-length(y2)] x2<-rep(p$breaks[2:length(p$breaks)-1],each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=make.transparent("blue",0.3), border=FALSE) lines(p$breaks[2:length(p$breaks)-1],p$density,type="s") arrows(x$d,max(c(0.2*max(p$density), 1.1*p$density[which(p$mids==x$d)])), x$d,0,lend="round", length=0.15,lwd=2,col="black") text(x$d-diff(par()$usr[1:2])/40, 1.1*max(c(0.2*max(p$density), 1.1*p$density[which(p$mids==x$d)])), "observed distance", srt=60,pos=4) }phytools/R/ratebytree.R0000644000176200001440000007071213200717464014640 0ustar liggesusers## method to compare the rate of evolution for a character between trees ## continuous character method closely related to 'censored' approach of O'Meara et al. (2006; Evolution) ## discrete character method fits Mk model of Lewis 2001 ## diversification method fits Yule or birth-death model of Nee et al. (1994) & Stadler (2012) ## written by Liam J. Revell 2017 ratebytree<-function(trees,x,...){ if(hasArg(type)) type<-list(...)$type else if(!missing(x)&&!is.null(x)) { if(is.factor(unlist(x))||is.character(unlist(x))) type<-"discrete" else type<-"continuous" } else type<-"diversification" if(type=="continuous") obj<-rbt.cont(trees,x,...) else if(type=="discrete") obj<-rbt.disc(trees,x,...) else if(type=="diversification") obj<-rbt.div(trees,...) else { cat(paste("type =",type,"not recognized.\n")) obj<-NULL } obj } rbt.div<-function(trees,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(model)) model<-list(...)$model else model<-"birth-death" if(hasArg(rho)) rho<-list(...)$rho else rho<-rep(1,length(trees)) if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 if(hasArg(iter)) iter<-list(...)$iter else iter<-10 if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(any(!sapply(trees,is.ultrametric))){ cat("One or more trees fails check is.ultrametric.\n") cat("If you believe your tree to be ultrametric ") cat("use force.ultrametric.\n") stop() } t<-lapply(trees,function(phy) sort(branching.times(phy), decreasing=TRUE)) if(model=="birth-death"){ fit.multi<-mapply(fit.bd,tree=trees,rho=rho,iter=iter,SIMPLIFY=FALSE) logL.multi<-sum(sapply(fit.multi,logLik)) } else if(model=="equal-extinction"){ lik.eqmu<-function(theta,t,rho,trace=FALSE){ lam<-theta[1:length(t)] mu<-theta[length(t)+1] logL<-0 for(i in 1:length(t)) logL<-logL-lik.bd(c(lam[i],mu),t[[i]],rho[i]) if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep="")) -logL } init.b<-sapply(trees,qb) obj<-nlminb(c(init.b,0),lik.eqmu,t=t,rho=rho,trace=trace, lower=rep(0,length(trees)+1),upper=rep(Inf,length(trees)+1)) count<-0 while(!is.finite(obj$objective)&&countinterval[2]) 52 else 0 fit.onerate<-list(par=c(obj$minimum,0),objective=obj$objective,convergence=convergence, message=if(convergence!=0) "Estimate at may be at limits of interval." else "Probably converged.") rates.multi<-cbind(sapply(fit.multi,function(x) x$b), rep(0,length(trees))) } if(!is.null(names(trees))) rownames(rates.multi)<-names(trees) else rownames(rates.multi)<-paste("tree",1:length(trees),sep="") colnames(rates.multi)<-c("b","d") LR<-2*(logL.multi+fit.onerate$objective) km<-if(model=="birth-death") 2*length(trees) else if(model=="equal-extinction") length(trees)+1 else if(model=="equal-speciation") length(trees)+1 else if(model=="Yule") length(trees) k1<-if(model=="Yule") 1 else 2 P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) obj<-list( multi.rate.model=list( logL=logL.multi, rates=rates.multi, k=km, method=if(model=="Yule") "optimize" else "nlminb"), common.rate.model=list( logL=-fit.onerate$objective, rates=setNames(fit.onerate$par,c("b","d")), k=k1, method=if(model=="Yule") "optimize" else "nlminb"), model=model,N=length(trees), n=sapply(trees,Ntip), likelihood.ratio=LR,P.chisq=P.chisq, type="diversification") class(obj)<-"ratebytree" obj } ## used (for now) to get a starting value for optimization in type="diversification" qb<-function(tree) (log(Ntip(tree))-log(2))/max(nodeHeights(tree)) ## discrete character ratebytree rbt.disc<-function(trees,x,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(model)) model<-list(...)$model else model<-"ER" if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(!is.list(x)) stop("x should be a list of vectors.") N<-length(trees) fit.multi<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(model=model), SIMPLIFY=FALSE) logL.multi<-sum(sapply(fit.multi,logLik)) lik.onerate<-function(theta,trees,x,model,trace=FALSE){ ss<-sort(unique(unlist(x))) m<-length(ss) if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD") { k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM") { k<-m*(m-1)/2 ii<-col(rate)1){ fit.onerate<-optim(pp,lik.onerate,trees=trees,x=x,model=model) } else { fit.onerate<-optimize(lik.onerate,c(0,1000*pp),trees=trees,x=x, model=model) names(fit.onerate)<-c("par","value") } rates.multi<-t(sapply(fit.multi,function(x) x$rates)) if(is.character(model)){ m<-length(fit.multi[[1]]$states) if(model=="ER"){ rates.multi<-t(rates.multi) colnames(rates.multi)<-"q" } else if(model=="SYM"){ if(length(fit.multi[[1]]$states)==2) rates.multi<-t(rates.multi) colnames(rates.multi)<- sapply(fit.multi[[1]]$states,function(x,y) sapply(y,function(y,x) paste(x,"<->",y,sep=""),x=x), y=fit.multi[[1]]$states)[lower.tri(matrix(0,m,m))] } else if(model=="ARD"){ ii<-(upper.tri(matrix(0,m,m))+lower.tri(matrix(0,m,m))==TRUE) colnames(rates.multi)<- sapply(fit.multi[[1]]$states,function(x,y) sapply(y,function(y,x) paste(y,"->",x,sep=""),x=x), y=fit.multi[[1]]$states)[ii] } } else { k<-max(fit.multi[[1]]$index.matrix,na.rm=TRUE) if(k==1) rates.multi<-t(rates.multi) foo<-function(i,index.matrix,states){ rc<-which(index.matrix==i,arr.ind=TRUE) lab<-apply(rc,1,function(ind,ss) paste(ss[ind],collapse="->"), ss=states) if(length(lab)>1) paste(lab,collapse=",") else lab } colnames(rates.multi)<-sapply(1:k, foo,fit.multi[[1]]$index.matrix,fit.multi[[1]]$states) } if(!is.null(names(trees))) rownames(rates.multi)<-names(trees) else rownames(rates.multi)<-paste("tree",1:length(trees),sep="") LR<-2*(logL.multi+fit.onerate$value) km<-sum(sapply(fit.multi,function(x) max(x$index.matrix,na.rm=TRUE))) k1<-length(pp) P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) obj<-list( multi.rate.model=list( logL=logL.multi, rates=rates.multi, method=fit.multi[[1]]$method), common.rate.model=list( logL=-fit.onerate$value, rates=setNames(fit.onerate$par,colnames(rates.multi)), method=if(length(pp)>1) "optim" else "optimize"), index.matrix=fit.multi[[1]]$index.matrix, states=fit.multi[[1]]$states, pi=fit.multi[[1]]$pi, model=model,N=N,n=sapply(trees,Ntip), likelihood.ratio=LR,P.chisq=P.chisq, type="discrete") class(obj)<-"ratebytree" obj } ## continuous character ratebytree rbt.cont<-function(trees,x,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(maxit)) maxit<-list(...)$maxit else maxit<-500 if(hasArg(regimes)){ regimes<-list(...)$regimes if(!is.factor(regimes)) regimes<-as.factor(regimes) } else regimes<-as.factor(1:length(trees)) if(hasArg(model)) model<-list(...)$model else model<-"BM" if(!(model%in%c("BM","OU","EB"))){ cat(paste("model =",model,"not recognized. using model = \"BM\"\n")) model<-"BM" } ## check trees & x if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(!is.list(x)) stop("x should be a list of vectors.") if(hasArg(se)) se<-list(...)$se else { se<-x for(i in 1:length(x)) se[[i]][1:length(se[[i]])]<-0 } N<-length(trees) m<-length(levels(regimes)) ## reorder the trait vectors in x & SEs in se x<-mapply(function(x,t) x<-x[t$tip.label],x=x,t=trees,SIMPLIFY=FALSE) se<-mapply(function(x,t) x<-x[t$tip.label],x=se,t=trees,SIMPLIFY=FALSE) ## likelihood functions lik.multi<-function(theta,trees,y,se,model,regimes,trace=FALSE){ m<-length(unique(regimes)) ind<-setNames(lapply(levels(regimes),function(x,y) which(y==x),y=regimes), levels(regimes)) THETA<-list() for(i in 1:m){ THETA[[i]]<-c(theta[i],theta[ind[[i]]+m]) if(model%in%c("OU","EB")) THETA[[i]]<-c(THETA[[i]],theta[i+m+N]) } logL<-0 for(i in 1:m) logL<-logL-lik.onerate(THETA[[i]],trees[ind[[i]]],y[ind[[i]]],se[ind[[i]]], model=model,trace=FALSE) if(trace){ cat(paste(paste(round(theta[1:m],digits),collapse="\t"), if(model=="OU") paste(round(theta[1:m+m+N],digits),collapse="\t"), if(model=="EB") paste(round(theta[1:m+m+N],digits),collapse="\t"), round(logL,digits),"\n",sep="\t")) flush.console() } -logL } lik.onerate<-function(theta,trees,y,se,model,trace=FALSE){ n<-sapply(trees,Ntip) N<-length(trees) sig<-theta[1] a<-theta[1:N+1] if(model=="OU") alpha<-theta[N+2] if(model=="EB") r<-theta[N+2] if(model=="BM") C<-lapply(trees,vcv) else if(model=="OU") C<-lapply(trees,vcvPhylo,model="OU",alpha=alpha, anc.nodes=FALSE) else if(model=="EB") C<-lapply(trees,vcvPhylo,model="EB",r=r, anc.nodes=FALSE) E<-lapply(se,diag) V<-mapply("+",lapply(C,"*",sig),E,SIMPLIFY=FALSE) logL<-0 for(i in 1:N) logL<-logL-t(y[[i]]-a[i])%*%solve(V[[i]])%*%(y[[i]]- a[i])/2-n[i]*log(2*pi)/2-determinant(V[[i]])$modulus[1]/2 if(trace){ cat(paste(round(sig,digits), if(model=="OU") round(alpha,digits), if(model=="EB") round(r,digits), round(logL,digits),"\n",sep="\t")) flush.console() } -logL } ## first, fit multi-rate model f1<-function(tree,x){ pvcv<-phyl.vcv(as.matrix(x),vcv(tree),1) c(pvcv$R[1,1],pvcv$a[1,1]) } P<-mapply(f1,trees,x,SIMPLIFY=FALSE) PP<-list() PP[[1]]<-vector() for(i in 1:m) PP[[1]][i]<-mean(sapply(P,function(x) x[1])[which(regimes==levels(regimes)[i])]) PP[[2]]<-sapply(P,function(x) x[2]) if(model%in%c("OU","EB")) PP[[3]]<-rep(0,m) if(hasArg(init)){ init<-list(...)$init if(!is.null(init$sigm)) PP[[1]]<-init$sigm if(!is.null(init$am)) PP[[2]]<-init$am if(model=="OU") if(!is.null(init$alpham)) PP[[3]]<-init$alpham if(model=="EB") if(!is.null(init$rm)) PP[[3]]<-init$rm } p<-unlist(PP) if(trace){ if(model=="BM"){ cat("\nOptimizing multi-rate model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } else if(model=="OU"){ cat("\nOptimizing multi-regime model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"), paste("alpha[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } else if(model=="EB"){ cat("\nOptimizing multi-regime model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"), paste("r[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } } fit.multi<-optim(p,lik.multi,trees=trees,y=x,se=se,model=model, regimes=regimes,trace=trace, method="L-BFGS-B",lower=c(rep(tol,m),rep(-Inf,N), if(model%in%c("OU","EB")) rep(-Inf,m)),upper=c(rep(Inf,m),rep(Inf,N), if(model%in%c("OU","EB")) rep(Inf,m)),control=list(maxit=maxit)) ## compute covariance matrix H.multi<-hessian(lik.multi,fit.multi$par,trees=trees,y=x, se=se,model=model,regimes=regimes,trace=FALSE) Cov.multi<-if(qr(H.multi)$rank!=ncol(H.multi)) ginv(H.multi) else solve(H.multi) ## now fit single-rate model p<-c(mean(fit.multi$par[1:m]),fit.multi$par[1:N+m]) if(model%in%c("OU","EB")) p<-c(p,mean(fit.multi$par[1:m+m+N])) if(hasArg(init)){ if(!is.null(init$sigc)) p[1]<-init$sigc if(!is.null(init$ac)) p[1:N+1]<-init$ac if(model=="OU") if(!is.null(init$alphac)) p[N+2]<-init$alphac if(model=="EB") if(!is.null(init$rc)) p[N+2]<-init$rc } if(trace){ if(model=="BM"){ cat("\nOptimizing common-rate model....\n") cat(paste("sig ","logL\n",sep="\t")) } else if(model=="OU"){ cat("\nOptimizing common-regime model....\n") cat(paste("sig ","alpha ","logL\n",sep="\t")) } else if(model=="EB"){ cat("\nOptimizing common-regime mode.....\n") cat(paste("sig ","r ","logL\n",sep="\t")) } } fit.onerate<-optim(p,lik.onerate,trees=trees,y=x,se=se,model=model, trace=trace,method="L-BFGS-B", lower=c(tol,rep(-Inf,N),if(model=="OU") tol else if(model=="EB") -Inf), upper=c(Inf,rep(Inf,N),if(model%in%c("OU","EB")) Inf), control=list(maxit=maxit)) ## compute covariance matrix H.onerate<-hessian(lik.onerate,fit.onerate$par,trees=trees,y=x, se=se,model=model,trace=FALSE) Cov.onerate<-if(qr(H.onerate)$rank!=ncol(H.onerate)) ginv(H.onerate) else solve(H.onerate) ## compare models: LR<-2*(-fit.multi$value+fit.onerate$value) km<-N+m+if(model=="BM") 0 else if(model%in%c("OU","EB")) m k1<-N+if(model=="BM") 1 else if(model%in%c("OU","EB")) 2 if(test=="simulation"&&model%in%c("OU","EB")){ cat("Simulation test not yet available for chosen model. Using chi-square test.\n") test<-"chisq" } if(test=="chisq") P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) else if(test=="simulation"){ if(!quiet) cat("Generating null distribution via simulation -> |") flush.console() if(hasArg(nsim)) nsim<-list(...)$nsim else nsim<-100 X<-mapply(fastBM,tree=trees,a=as.list(fit.onerate$par[1:N+1]), MoreArgs=list(sig2=fit.onerate$par[1],nsim=nsim), SIMPLIFY=FALSE) P.sim<-1/(nsim+1) pct<-0.1 for(i in 1:nsim){ x.sim<-lapply(X,function(x,ind) x[,ind],ind=i) f2<-function(x,se) sampleFrom(xbar=x,xvar=se^2,n=rep(1,length(x))) x.sim<-mapply(f2,x=x.sim,se=se,SIMPLIFY=FALSE) fit.sim<-ratebytree(trees,x.sim,se=se) P.sim<-P.sim+(fit.sim$likelihood.ratio>=LR)/(nsim+1) if(i/nsim>=pct){ if(!quiet) cat(".") flush.console() pct<-pct+0.1 } } if(!quiet) cat(".|\nDone!\n") flush.console() } obj<-list( multi.rate.model=list(sig2=fit.multi$par[1:m], SE.sig2=sqrt(diag(Cov.multi)[1:m]), a=fit.multi$par[1:N+m], SE.a=sqrt(diag(Cov.multi)[1:N+m]), alpha=if(model=="OU") fit.multi$par[1:m+m+N] else NULL, SE.alpha=if(model=="OU") sqrt(diag(Cov.multi)[1:m+m+N]) else NULL, r=if(model=="EB") fit.multi$par[1:N+m+N] else NULL, SE.r=if(model=="EB") sqrt(diag(Cov.multi)[1:N+m+N]) else NULL, k=km, logL=-fit.multi$value, counts=fit.multi$counts,convergence=fit.multi$convergence, message=fit.multi$message), common.rate.model=list(sig2=fit.onerate$par[1], SE.sig2=sqrt(diag(Cov.onerate)[1]), a=fit.onerate$par[1:N+1], SE.a=sqrt(diag(Cov.onerate)[1:N+1]), alpha=if(model=="OU") fit.onerate$par[N+2] else NULL, SE.alpha=if(model=="OU") sqrt(diag(Cov.onerate)[N+2]) else NULL, r=if(model=="EB") fit.onerate$par[N+2] else NULL, SE.r=if(model=="EB") sqrt(diag(Cov.onerate)[N+2]) else NULL, k=k1, logL=-fit.onerate$value, counts=fit.onerate$counts,convergence=fit.onerate$convergence, message=fit.onerate$message), model=model, N=N,n=sapply(trees,Ntip),likelihood.ratio=LR, regimes=regimes,m=m, P.chisq=if(test=="chisq") P.chisq else NULL, P.sim=if(test=="simulation") P.sim else NULL, type="continuous") class(obj)<-"ratebytree" obj } ## S3 print method for ratebytree print.ratebytree<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(x$type=="continuous") prbt.cont(x,digits=digits) else if(x$type=="discrete") prbt.disc(x,digits=digits) else if(x$type=="diversification") prbt.div(x,digits=digits) else print(x) } prbt.div<-function(x,digits=digits){ cat("ML common diversification-rate model:") cat("\n\tb\td\tk\tlog(L)") cat(paste("\nvalue",round(x$common.rate.model$rates[1],digits), round(x$common.rate.model$rates[2],digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), sep="\t")) cat("\n\nML multi diversification-rate model:") cat(paste("\n",paste(paste("b[",1:x$N,"]",sep=""),collapse="\t"), paste(paste("d[",1:x$N,"]",sep=""),collapse="\t"),"k\tlog(L)", sep="\t")) cat(paste("\nvalue",paste(round(x$multi.rate.model$rates[,"b"],digits), collapse="\t"),paste(round(x$multi.rate.model$rates[,"d"],digits), collapse="\t"),x$multi.rate.model$k,round(x$multi.rate.model$logL, digits),sep="\t")) cat(paste("\n\nDiversification model was \"",x$model,"\".\n",sep="")) cat(paste("Model fitting method was \"",x$multi.rate.model$method, "\".\n",sep="")) cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n")) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) } prbt.cont<-function(x,digits=digits){ N<-x$N m<-x$m if(x$model=="BM"){ cat("ML common-rate model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), "\n\n",sep="\t")) cat("ML multi-rate model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), "\n\n",sep="\t")) } else if(x$model=="OU"){ cat("ML common-regime OU model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\talpha\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), round(x$common.rate.model$alpha,digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), round(x$common.rate.model$SE.alpha,digits), "\n\n",sep="\t")) cat("ML multi-regime OU model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t", paste(paste("alp[",levels(x$regimes),"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), paste(round(x$multi.rate.model$alpha,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.alpha,digits),collapse="\t"), "\n\n",sep="\t")) } else if(x$model=="EB"){ cat("ML common-regime EB model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tr\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), round(x$common.rate.model$r,digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), round(x$common.rate.model$SE.r,digits), "\n\n",sep="\t")) cat("ML multi-regime EB model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t", paste(paste("r[",levels(x$regimes),"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), paste(round(x$multi.rate.model$r,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.r,digits),collapse="\t"), "\n\n",sep="\t")) } cat(paste("Likelihood ratio:",round(x$likelihood.ratio,digits),"\n")) if(!is.null(x$P.chisq)) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) else if(!is.null(x$P.sim)) cat(paste("P-value (based on simulation):",round(x$P.sim,digits),"\n\n")) if(x$multi.rate.model$convergence==0&&x$common.rate.model$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("One or the other optimization may not have converged.\n\n") } prbt.disc<-function(x,digits=digits){ cat("ML common-rate model:\n") cat(paste("\t",paste(names(x$common.rate.model$rates),collapse="\t"), "\tk\tlogL\n",sep="")) cat(paste("value\t",paste(round(x$common.rate.model$rates,digits), collapse="\t"),"\t",max(x$index.matrix,na.rm=T),"\t", round(x$common.rate.model$logL,digits),"\n",sep="")) cat(paste("\nModel fitting method was \"",x$common.rate.model$method, "\".\n",sep="")) cat("\nML multi-rate model:\n") cat(paste("\t",paste(colnames(x$multi.rate.model$rates),collapse="\t"), "\tk\tlogL\n",sep="")) for(i in 1:nrow(x$multi.rate.model$rates)){ if(i>1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t", paste(round(x$multi.rate.model$rates[i,], digits),collapse="\t"),"\n",sep="")) else if(i==1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t", paste(round(x$multi.rate.model$rates[i,], digits),collapse="\t"),"\t",x$N*max(x$index.matrix,na.rm=T),"\t", round(x$multi.rate.model$logL,digits),"\n",sep="")) } cat(paste("\nModel fitting method was \"",x$multi.rate.model$method, "\".\n",sep="")) cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n")) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) } ## posthoc comparison S3 method posthoc<-function(x, ...) UseMethod("posthoc") posthoc.ratebytree<-function(x,...){ if(hasArg(p.adjust.method)) p.adjust.method<-list(...)$p.adjust.method else p.adjust.method<-"none" if(x$type!="continuous"){ cat("Sorry. No posthoc method yet implemented for this data type.\n\n") } else { if(x$model=="BM") k<-2 else if(x$model%in%c("EB","OU")) k<-3 t<-df<-P<-matrix(0,x$m,x$m) for(i in 1:x$m){ for(j in 1:x$m){ x1<-if(x$model=="BM") x$multi.rate.model$sig2[i] else if(x$model=="OU") x$multi.rate.model$alpha[i] else if(x$model=="EB") x$multi.rate.model$r[i] x2<-if(x$model=="BM") x$multi.rate.model$sig2[j] else if(x$model=="OU") x$multi.rate.model$alpha[j] else if(x$model=="EB") x$multi.rate.model$r[j] s1<-x$multi.rate.model$SE.sig2[i]^2 s2<-x$multi.rate.model$SE.sig2[j]^2 n1<-x$n[i] n2<-x$n[j] se<-sqrt(s1+s2) df[i,j]<-(s1/n1+s2/n2)^2/ ((s1/n1)^2/(n1-k)+(s2/n2)^2/(n2-k)) t[i,j]<-(x1-x2)/se P[i,j]<-2*pt(abs(t[i,j]),df[i,j],lower.tail=FALSE) } } p<-P[upper.tri(P)] p<-p.adjust(p,method=p.adjust.method) P[upper.tri(P)]<-p P[lower.tri(P)]<-p } obj<-list(t=t,df=df,P=P,model=x$model,type=x$type, p.adjust.method=p.adjust.method) class(obj)<-"posthoc.ratebytree" obj } print.posthoc.ratebytree<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 t<-x$t[upper.tri(x$t)] df<-x$df[upper.tri(x$df)] P<-x$P[upper.tri(x$P)] N<-nrow(x$P) paste("reg.",1:(N-1),"vs.",2:N) nn<-vector(mode="character",length=N*(N-1)/2) k<-1 for(i in 1:N) for(j in i:N){ if(i!=j){ nn[k]<-paste("reg.",i," vs. ",j,sep="") k<-k+1 } } X<-data.frame(t=t,df=df,P=P) rownames(X)<-nn cat(paste("\nPost-hoc test for \"",x$model,"\" model.\n",sep="")) cat(paste("(Comparison is of estimated values of", if(x$model=="BM") "sigma^2.)\n\n" else if(x$model=="OU") "alpha.)\n\n" else if(x$model=="EB") "r.)\n\n")) print(round(X,digits)) cat(paste("\nP-values adjusted using method=\"",x$p.adjust.method, "\".\n\n",sep="")) } AIC.ratebytree<-function(object,...,k=2){ aic<-data.frame(AIC=c(k*object$common.rate.model$k-2*object$common.rate.model$logL, k*object$multi.rate.model$k-2*object$multi.rate.model$logL), df=c(object$common.rate.model$k,object$multi.rate.model$k)) model.names<-if(is.null(object$model)) 1 else object$model addtl.obj<-list(...) if(length(addtl.obj)>0){ for(i in 1:length(addtl.obj)){ aic<-rbind(aic,c(k*addtl.obj[[i]]$multi.rate.model$k- 2*addtl.obj[[i]]$multi.rate.model$logL, addtl.obj[[i]]$multi.rate.model$k)) model.names<-c(model.names, if(is.null(addtl.obj[[i]]$model)) 1+i else addtl.obj[[i]]$model) } rownames(aic)<-c("common-rate",paste("multi-rate:",model.names,sep="")) } else rownames(aic)<-c("common-rate","multi-rate") aic } phytools/R/allFurcTrees.R0000644000176200001440000000326112107731037015055 0ustar liggesusers# function returns all unrooted multi & bifurcating tree topologies # written by Liam Revell 2011, 2013 allFurcTrees<-function(n,tip.label=NULL,to.plot=TRUE){ # check to see if tip labels have been provided if(is.null(tip.label)) tip.label=as.character(1:n) # now pick three species at random to start new<-list(stree(n=3,tip.label=sample(tip.label,3))) class(new)<-"multiPhylo" added<-new[[1]]$tip.label; remaining<-setdiff(tip.label,added) # loop while(length(remaining)>0){ old<-new; new<-list() new.tip<-sample(remaining,1) for(i in 1:length(old)){ temp<-add.to.branches.and.nodes(old[[i]],new.tip) new<-unlist(list(new,temp),recursive=FALSE); class(new)<-"multiPhylo" } added<-c(added,new.tip) remaining<-setdiff(tip.label,added) } if(to.plot) new<-read.tree(text=write.tree(new)) return(new) # return all trees } # function adds a tip to all branches and nodes # written by Liam Revell 2011 add.to.branches.and.nodes<-function(tree,tip.name){ n.edge<-nrow(tree$edge) tree$edge.length<-rep(1,n.edge) # set all edge lengths to 1.0 # create new tip new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L); class(new.tip)<-"phylo" # first add the tip to all edges trees<-list(); class(trees)<-"multiPhylo" for(i in 1:n.edge){ trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) # add tip to edge trees[[i]]$edge.length<-NULL } # ok, now add the tip to all internal nodes intnodes<-unique(tree$edge[,1]) for(i in 1:tree$Nnode){ trees[[i+n.edge]]<-bind.tree(tree,new.tip,where=intnodes[i]) # add tip to node trees[[i+n.edge]]$edge.length<-NULL } return(trees) } phytools/R/resolveNodes.R0000644000176200001440000000405612752433644015146 0ustar liggesusers## function to resolve nodes in a multifurcating tree ## written by Liam J. Revell 2016 resolveNode<-function(tree,node){ dd<-Children(tree,node) if(length(dd)>2){ EL<-!is.null(tree$edge.length) if(!EL) tree<-compute.brlen(tree) n<-length(dd) tt<-lapply(allTrees(n,TRUE,dd),untangle,"read.tree") ROOT<-node==(Ntip(tree)+1) SPL<-if(!ROOT) splitTree(tree,split=list(node=node, bp=tree$edge.length[which(tree$edge[,2]==node)])) else list(NULL,tree) KIDS<-Children(SPL[[2]],SPL[[2]]$edge[1,1]) KIDS<-setNames(KIDS,dd)[KIDS>Ntip(SPL[[2]])] SUBS<-list() if(length(KIDS)>0) for(i in 1:length(KIDS)) SUBS[[i]]<-extract.clade(SPL[[2]],KIDS[i]) obj<-list() for(i in 1:length(tt)){ tt[[i]]$edge.length<-rep(0,nrow(tt[[i]]$edge)) for(j in 1:Ntip(tt[[i]])) tt[[i]]$edge.length[which(tt[[i]]$edge[,2]==j)]<- tree$edge.length[which(tree$edge[,2]== as.numeric(tt[[i]]$tip.label[j]))] ind<-as.numeric(tt[[i]]$tip.label)<=Ntip(tree) tt[[i]]$tip.label[ind]<- tree$tip.label[as.numeric(tt[[i]]$tip.label[ind])] if(length(KIDS)>0) for(j in 1:length(KIDS)) tt[[i]]<-bind.tree(tt[[i]],SUBS[[j]], where=which(tt[[i]]$tip.label== names(KIDS)[j])) obj[[i]]<-if(!ROOT) bind.tree(SPL[[1]],tt[[i]], where=which(SPL[[1]]$tip.label=="NA")) else tt[[i]] if(!EL) obj[[i]]$edge.length<-NULL } class(obj)<-"multiPhylo" } else obj<-tree obj } ## function to resolve all nodes in a tree with multifurcations ## written by Liam J. Revell 2016 resolveAllNodes<-function(tree){ foo<-function(node,tree) length(Children(tree,node)) nodes<-1:tree$Nnode+Ntip(tree) ## all nodes nodes<-nodes[sapply(1:tree$Nnode+Ntip(tree),foo, tree=tree)>2] for(i in 1:length(nodes)){ if(i==1) obj<-resolveNode(tree,nodes[i]) else { for(j in 1:length(obj)){ MM<-matchNodes(tree,obj[[j]]) NODE<-MM[which(MM[,1]==nodes[i]),2] if(j==1) tmp<-resolveNode(obj[[j]],NODE) else tmp<-c(tmp,resolveNode(obj[[j]],NODE)) } obj<-tmp } } obj } phytools/R/phyl.cca.R0000644000176200001440000001054413201657102014161 0ustar liggesusers# function does phylogenetic canonical correlation analysis (Revell & Harrison 2008) # written by Liam Revell 2011, 2012, 2013, 2015 phyl.cca<-function(tree,X,Y,lambda=1.0,fixed=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # misc n<-length(tree$tip) mX<-ncol(X) mY<-ncol(Y) # compute C C<-vcv.phylo(tree) # if X & Y are data frames, convert to matrix if(is.data.frame(X)) X<-as.matrix(X) if(is.data.frame(Y)) Y<-as.matrix(Y) # check to see if X & Y have rownames if(is.null(rownames(X))){ message("X is missing rownames; assuming same order as tree$tip.label") if(nrow(X)!=length(tree$tip)) warning("X does not have the correct number of rows") else rownames(X)<-tree$tip.label } if(is.null(rownames(Y))){ message("Y is missing rownames; assuming same order as tree$tip.label") if(nrow(Y)!=length(tree$tip)) warning("Y does not have the correct number of rows") else rownames(Y)<-tree$tip.label } # reorder Y & C by tree$tip.label C<-C[tree$tip.label,tree$tip.label] # I think this is superfluous X<-as.matrix(X[tree$tip.label,]) Y<-as.matrix(Y[tree$tip.label,]) # set or optimize lambda if(fixed) logL<-likMlambda(lambda,cbind(X,Y),C) else { temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=cbind(X,Y),C=C,maximum=TRUE) logL<-temp$objective lambda<-temp$maximum } C<-lambda.transform(lambda,C) # invert C invC<-solve(C) # compute means aX<-colSums(invC%*%X)/sum(invC) aY<-colSums(invC%*%Y)/sum(invC) # compute cov & cross-cov matrices one<-as.matrix(rep(1,n)) SigXX<-t(X-one%*%aX)%*%invC%*%(X-one%*%aX)/(n-1) SigXY<-t(X-one%*%aX)%*%invC%*%(Y-one%*%aY)/(n-1) SigYX<-t(SigXY) SigYY<-t(Y-one%*%aY)%*%invC%*%(Y-one%*%aY)/(n-1) # compute canonical coefficients A<-eigen(solve(SigXX)%*%SigXY%*%solve(SigYY)%*%SigYX) B<-eigen(solve(SigYY)%*%SigYX%*%solve(SigXX)%*%SigXY) # compute canonical variables, rescale U<-X%*%A$vectors[,1:min(mX,mY)] aU<-colSums(invC%*%U)/sum(invC) vcvU<-t(U-one%*%aU)%*%invC%*%(U-one%*%aU)/(n-1) U<-(U-one%*%aU)%*%Diag(sqrt(Diag(1/vcvU))) V<-Y%*%B$vectors[,1:min(mX,mY)] aV<-colSums(invC%*%V)/sum(invC) vcvV<-t(V-one%*%aV)%*%invC%*%(V-one%*%aV)/(n-1) V<-(V-one%*%aV)%*%Diag(sqrt(Diag(1/vcvV))) # compute canonical correlations aU<-colSums(invC%*%U)/sum(invC) aV<-colSums(invC%*%V)/sum(invC) Ccv<-round(t(cbind(U,V))%*%invC%*%cbind(U,V)/(n-1),10) ccs<-Diag(Ccv[1:min(mX,mY),(1+min(mX,mY)):(2*min(mX,mY))]) if(all(Im(ccs)==0)) ccs<-Re(ccs) pos<-2*(as.numeric(ccs>0)-0.5) ccs<-ccs*pos # reorient variables, reorient & rescale coefficents U<-U*one%*%pos xcoef<-A$vectors[,1:min(mX,mY)]*matrix(1,mX,1)%*%pos%*%Diag(sqrt(Diag(1/vcvU))) ycoef<-B$vectors[,1:min(mX,mY)]%*%Diag(sqrt(Diag(1/vcvV))) # conduct hypothesis tests W_lh<-rep(1,min(mX,mY)) chiSq<-vector() df<-vector() for(i in 1:min(mX,mY)){ for(j in i:min(mX,mY)) W_lh[i]<-W_lh[i]*(1-ccs[j]^2) chiSq[i]<--((n-1)-(mX+mY+1)/2)*log(W_lh[i]) df[i]<-(mX+1-i)*(mY+1-i) } pvalues<-pchisq(chiSq,df=df,lower.tail=F) # add row & column names if(!is.null(colnames(X))) rownames(xcoef)<-colnames(X) if(!is.null(colnames(Y))) rownames(ycoef)<-colnames(Y) temp<-vector() for(i in 1:min(mX,mY)) temp[i]<-paste("CA",i,sep="") colnames(xcoef)<-temp colnames(ycoef)<-temp colnames(U)<-temp colnames(V)<-temp # return as list lambda<-c(lambda,logL); names(lambda)<-c("lambda","logL") obj<-list(cor=ccs,xcoef=xcoef,ycoef=ycoef,xscores=U,yscores=V,lambda=lambda,chisq=chiSq,p=pvalues) class(obj)<-"phyl.cca" obj } ## internal function replace Diag ## modified from a suggestion by Travis Ingram 2013 Diag<-function(X){ if(length(X)==1) X else diag(X) } ## S3 print method print.phyl.cca<-function(x,digits=6,...){ cat("\nObject of class \"phyl.cca\" from a phylogenetic canonical") cat("\n correlation analysis.\n\n") object<-data.frame(round(x$cor,digits),round(x$chisq,digits),round(x$p,digits)) colnames(object)<-c("correlation","X^2","P-value") rownames(object)<-paste("CC",1:length(x$cor),sep=":") cat("Summary of results:\n") print(object) cat("\nAssumed or estimated value of lambda:\n") print(round(x$lambda,digits)) cat("\nCanonical x coefficients:\n") print(as.data.frame(round(x$xcoef,digits))) cat("\nCanonical y coefficients:\n") print(as.data.frame(round(x$ycoef,digits))) cat("\n") } phytools/R/bd.R0000644000176200001440000000607213177726246013070 0ustar liggesusers## likelihood functions for birth-death & Yule model with incomplete sampling ## written by Liam J. Revell 2017 ## based on likelihood functions in Stadler (2012) lik.bd<-function(theta,t,rho=1,N=NULL){ lam<-theta[1] mu<-if(length(theta)==2) theta[2] else 0 if(is.null(N)) N<-length(t)+1 p0ti<-function(rho,lam,mu,t) 1-rho*(lam-mu)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t)) p1ti<-function(rho,lam,mu,t) rho*(lam-mu)^2*exp(-(lam-mu)*t)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))^2 lik<-2*log(p1ti(rho,lam,mu,t[1]))-2*log(1-p0ti(rho,lam,mu,t[1])) for(i in 2:length(t)) lik<-lik+log(lam)+log(p1ti(rho,lam,mu,t[i])) -(lik+lfactorial(N-1)) } ## model-fitting function for birth-death model fit.bd<-function(tree,b=NULL,d=NULL,rho=1,...){ if(!is.ultrametric(tree)){ cat("tree fails is.ultrametric.\n") cat("If you believe your tree actually is ultrametric ") cat("use force.ultrametric & try again.\n") stop() } init<-vector(length=2) if(hasArg(init.b)) init.b<-list(...)$init.b else init.b<-1.1*qb(tree) if(hasArg(init.d)) init.d<-list(...)$init.d else init.d<-0.1*qb(tree) if(hasArg(iter)) iter<-list(...)$iter else iter<-10 if(!is.binary.tree(tree)) tree<-multi2di(tree) T<-sort(branching.times(tree),decreasing=TRUE) fit<-nlminb(c(init.b,init.d),lik.bd,t=T,rho=rho,lower=rep(0,2), upper=rep(Inf,2)) if(!is.finite(fit$objective)){ count<-0 while(!is.finite(fit$objective)&&count1){ cat("no colors provided. using the following legend:\n") print(colors) } } # swap out "_" character for spaces (assumes _ is a place holder) tree$tip.label<-gsub("_"," ",tree$tip.label) # get margin if(is.null(mar)) mar=rep(0.1,4) if(hold) null<-dev.hold() if(type=="phylogram"){ if(direction%in%c("upwards","downwards")) updownPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,add,offset, direction,setEnv,xlim,ylim,nodes,tips,split.vertical,lend,asp,plot) else plotPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,add,offset, direction,setEnv,xlim,ylim,nodes,tips,split.vertical,lend,asp,plot) } else if(type=="fan"){ plotFan(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips, maxY,lend,plot) } else if(type=="cladogram"){ plotCladogram(tree,colors,fsize,ftype,lwd,mar,add,offset,direction,xlim,ylim, nodes,tips,lend,asp,plot) } if(hold) null<-dev.flush() } } ## function to plot simmap tree in type "phylogram" ## written by Liam J. Revell 2011-2017 updownPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot){ if(split.vertical&&!setEnv){ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n") spit.vertical<-FALSE } # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(ylim)){ pp<-par("pin")[2] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(xlim)) xlim=range(Y) if(direction=="downwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) #### if(plot){ if(!split.vertical){ for(i in 1:m) lines(Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]], H[which(cw$edge[,1]==nodes[i]),1], col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="downwards") lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x-cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="downwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0, rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0,Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(Y[cw$edge[i,2]],x, rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(Y[cw$edge[i,2]],x,cw$edge[i,2],cex=fsize) } } } if(direction=="downwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 if(direction=="upwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 for(i in 1:n){ shift<-offset*fsize*strwidth("W")*(diff(par()$usr[3:4])/diff(par()$usr[1:2])) if((direction=="downwards"&&diff(par()$usr[3:4])>0) || (direction=="upwards"&&diff(par()$usr[3:4])<0)) shift<--shift if(ftype){ text(labels=cw$tip.label[i],Y[i], H[which(cw$edge[,2]==i),2]+shift, pos=pos,offset=0,cex=fsize,font=ftype, srt=if(direction=="downwards") 270 else 90) } } } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=Y[,1],yy=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge)) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "phylogram" # written by Liam J. Revell 2011-2017 plotPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot){ if(split.vertical&&!setEnv){ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n") spit.vertical<-FALSE } # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### if(!split.vertical){ for(i in 1:m) lines(H[which(cw$edge[,1]==nodes[i]),1], Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(x,Y[cw$edge[i,2]], rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(x,Y[cw$edge[i,2]],cw$edge[i,2],cex=fsize) } } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "fan" # written by Liam J. Revell 2013-2017 plotFan<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips,maxY,lend,plot){ if(!plot) cat("plot=FALSE option is not permitted for type=\"fan\". Tree will be plotted.\n") # reorder cw<-reorder(tree) pw<-reorder(tree,"pruningwise") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # get Y coordinates on uncurved space Y<-vector(length=m+n) if(is.null(tips)) tips<-1:n if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1) else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips nodes<-unique(pw$edge[,1]) for(i in 1:m){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } if(is.null(maxY)) maxY<-max(Y) Y<-setNames(Y/maxY*2*pi,1:(n+m)) Y<-part*cbind(Y[as.character(cw$edge[,2])],Y[as.character(cw$edge[,2])]) R<-nodeHeights(cw) # now put into a circular coordinate system x<-R*cos(Y) y<-R*sin(Y) # optimize x & y limits par(mar=mar) offsetFudge<-1.37 # empirically determined offset<-0 pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*offset*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp, interval=c(0,1e6))$minimum if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp) else if(part>0.25&&part<=0.5){ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) y.lim<-c(0,max(R)+sw/alp) } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) if(is.null(xlim)) xlim<-x.lim if(is.null(ylim)) ylim<-y.lim # plot tree if(!add) plot.new() plot.window(xlim=xlim,ylim=ylim,asp=1) # plot radial lines (edges) ## first, the lines emerging from the root (if there are only two): jj<-which(cw$edge[,1]==(Ntip(cw)+1)) if(length(jj)==2){ m.left<-cumsum(cw$maps[[jj[1]]])/sum(cw$maps[[jj[1]]]) xx.left<-c(x[jj[1],1],x[jj[1],1]+(x[jj[1],2]-x[jj[1],1])*m.left) yy.left<-c(y[jj[1],1],y[jj[1],1]+(y[jj[1],2]-y[jj[1],1])*m.left) m.right<-cumsum(cw$maps[[jj[2]]])/sum(cw$maps[[jj[2]]]) xx.right<-c(x[jj[2],1],x[jj[2],1]+(x[jj[2],2]-x[jj[2],1])*m.right) yy.right<-c(y[jj[2],1],y[jj[2],1]+(y[jj[2],2]-y[jj[2],1])*m.right) xx<-c(xx.left[length(xx.left):1],xx.right[2:length(xx.right)]) yy<-c(yy.left[length(yy.left):1],yy.right[2:length(yy.right)]) col<-colors[c(names(m.left)[length(m.left):1],names(m.right))] segments(xx[2:length(xx)-1],yy[2:length(yy)-1],xx[2:length(xx)],yy[2:length(yy)], col=col,lwd=lwd,lend=lend) } else jj<-NULL for(i in 1:nrow(cw$edge)){ if(i%in%jj==FALSE){ maps<-cumsum(cw$maps[[i]])/sum(cw$maps[[i]]) xx<-c(x[i,1],x[i,1]+(x[i,2]-x[i,1])*maps) yy<-c(y[i,1],y[i,1]+(y[i,2]-y[i,1])*maps) for(i in 1:(length(xx)-1)) lines(xx[i+0:1],yy[i+0:1],col=colors[names(maps)[i]], lwd=lwd,lend=lend) } } # plot circular lines for(i in 1:m+n){ r<-R[match(i,cw$edge)] a1<-min(Y[which(cw$edge==i)]) a2<-max(Y[which(cw$edge==i)]) draw.arc(0,0,r,a1,a2,lwd=lwd,col=colors[names(cw$maps[[match(i,cw$edge[,1])]])[1]]) } # plot labels for(i in 1:n){ ii<-which(cw$edge[,2]==i) aa<-Y[ii,2]/(2*pi)*360 adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25) tt<-if(aa>90&&aa<270) paste(cw$tip.label[i]," ",sep="") else paste(" ", cw$tip.label[i],sep="") aa<-if(aa>90&&aa<270) 180+aa else aa if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype) } if(setEnv){ PP<-list(type="fan",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black", Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge, xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],x[1,1], if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()), yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],y[1,1], if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c())) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } ## internal function for slanted cladogram ## written by Liam J. Revell 2017 plotCladogram<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,mar=NULL, add=FALSE,offset=NULL,direction="rightwards",xlim=NULL,ylim=NULL, nodes="intermediate",tips=NULL,lend=2,asp=NA,plot=TRUE){ placement<-nodes # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### for(i in 1:nrow(cw$edge)){ x<-H[i,1] y<-Y[cw$edge[i,1]] m<-(Y[cw$edge[i,2]]-Y[cw$edge[i,1]])/(H[i,2]-H[i,1]) if(is.finite(m)){ for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(y,y-cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(y,y+cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] y<-y+if(direction=="leftwards") -m*cw$maps[[i]][j] else m*cw$maps[[i]][j] j<-j+1 } } else { lines(rep(x,2),Y[cw$edge[i,]],col=colors[names(cw$maps[[i]])[1]],lwd=lwd, lend=lend) } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## adds legend to an open stochastic map style plot ## written by Liam J. Revell 2013, 2016, 2017 add.simmap.legend<-function(leg=NULL,colors,prompt=TRUE,vertical=TRUE,...){ if(hasArg(shape)) shape<-list(...)$shape else shape<-"square" if(prompt){ cat("Click where you want to draw the legend\n") x<-unlist(locator(1)) y<-x[2] x<-x[1] } else { if(hasArg(x)) x<-list(...)$x else x<-0 if(hasArg(y)) y<-list(...)$y else y<-0 } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(is.null(leg)) leg<-names(colors) h<-fsize*strheight(LETTERS[1]) w<-par()$mfcol[2]*h*abs(diff(par()$usr[1:2])/diff(par()$usr[3:4])) flipped<-par()$usr[1]>par()$usr[2] if(vertical){ y<-y-0:(length(leg)-1)*1.5*h x<-rep(x+w/2,length(y)) text(x + if(flipped) -w else w,y,leg,pos=4,cex=fsize/par()$cex) } else { sp<-abs(fsize*max(strwidth(leg))) x<-x + if(flipped) w/2-0:(length(leg)-1)*1.5*(sp+w) else -w/2+0:(length(leg)-1)*1.5*(sp+w) y<-rep(y+w/2,length(x)) text(x,y,leg,pos=4,cex=fsize/par()$cex) } if(shape=="square") symbols(x,y,squares=rep(w,length(x)),bg=colors,add=TRUE,inches=FALSE) else if(shape=="circle") nulo<-mapply(draw.circle,x=x,y=y,col=colors, MoreArgs=list(nv=200,radius=w/2)) else stop(paste("shape=\"",shape,"\" is not a recognized option.",sep="")) } # function plots a tree; in the new version this is just a wrapper for plotSimmap # written by Liam Revell 2012-2017 plotTree<-function(tree,...){ if(hasArg(color)) color<-list(...)$color else color<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(pts)) pts<-list(...)$pts else pts<-FALSE if(hasArg(node.numbers)) node.numbers<-list(...)$node.numbers else node.numbers<-FALSE if(hasArg(mar)) mar<-list(...)$mar else mar<-NULL if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(setEnv)) setEnv<-list(...)$setEnv else setEnv<-TRUE if(hasArg(part)) part<-list(...)$part else part<-1.0 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-"intermediate" if(hasArg(tips)) tips<-list(...)$tips else tips<-NULL if(hasArg(maxY)) maxY<-list(...)$maxY else maxY<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(lend)) lend<-list(...)$lend else lend<-2 if(hasArg(asp)) asp<-list(...)$asp else asp<-NA if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(inherits(tree,"multiPhylo")){ par(ask=TRUE) if(!is.null(color)) names(color)<-"1" for(i in 1:length(tree)) plotTree(tree[[i]],color=color,fsize=fsize,ftype=ftype, lwd=lwd,pts=pts,node.numbers=node.numbers,mar=mar,add=add,offset=offset, direction=direction,type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim, nodes=nodes,tips=tips,maxY=maxY,hold=hold,lend=lend,asp=asp,plot=plot) } else { if(is.null(tree$edge.length)) tree<-compute.brlen(tree) tree$maps<-as.list(tree$edge.length) for(i in 1:length(tree$maps)) names(tree$maps[[i]])<-c("1") if(!is.null(color)) names(color)<-"1" plotSimmap(tree,colors=color,fsize=fsize,ftype=ftype,lwd=lwd,pts=pts, node.numbers=node.numbers,mar=mar,add=add,offset=offset,direction=direction, type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,nodes=nodes,tips=tips,maxY=maxY, hold=hold,lend=lend,asp=asp,plot=plot) } } ## S3 method for objects of class "simmap" & "multiSimmap" ## added by Liam J. Revell 2015 plot.simmap<-function(x,...) plotSimmap(x,...) plot.multiSimmap<-function(x,...) plotSimmap(x,...) ## function to split vertical plotted lines by the states of daughter edges ## written by Liam J. Revell 2015 splitEdgeColor<-function(tree,colors,lwd=2){ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:tree$Nnode+Ntip(tree)){ daughters<-tree$edge[which(tree$edge[,1]==i),2] cols<-vector() for(j in 1:length(daughters)){ jj<-which(tree$edge[,2]==daughters[j]) cols[j]<-if(tree$maps[[jj]][1]==0&&length(tree$maps[[jj]])>1) colors[names(tree$maps[[jj]])[2]] else colors[names(tree$maps[[jj]])[1]] } ii<-order(obj$yy[c(i,daughters)]) jj<-order(obj$yy[daughters]) x0<-x1<-rep(obj$xx[i],length(daughters)) y0<-obj$yy[c(i,daughters)][ii][1:length(daughters)] y1<-obj$yy[c(i,daughters)][ii][2:(length(daughters)+1)] cols<-cols[jj] for(j in 1:length(x0)) segments(x0[j],y0[j],x1[j],y1[j],col=cols[j],lwd=lwd,lend=2) } } phytools/R/ancThresh.R0000644000176200001440000003427713201322630014403 0ustar liggesusers## function performs ancestral character estimation under the threshold model ## written by Liam J. Revell 2012, 2013, 2014, 2017 ancThresh<-function(tree,x,ngen=10000,sequence=NULL,method="mcmc",model=c("BM","OU","lambda"),control=list(),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check method if(method!="mcmc") stop(paste(c("do not recognize method =",method,",quitting"))) # get model for the evolution of liability model<-model[1] # check x if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)){ X<-x[tree$tip.label,] if(is.null(sequence)){ message("**** NOTE: no sequence provided, column order in x") seq<-colnames(X) } else seq<-sequence } else if(is.vector(x)){ x<-x[tree$tip.label] if(is.null(sequence)){ message("**** NOTE: no sequence provided, using alphabetical or numerical order") seq<-sort(levels(as.factor(x))) } else seq<-sequence X<-to.matrix(x,seq) } # row scale X X<-X/apply(X,1,sum) X<-X[,seq] # order columns by seq # ok, now set starting thresholds th<-c(1:length(seq))-1; names(th)<-seq x<-to.vector(X) l<-sapply(x,function(x) runif(n=1,min=th[x]-1,max=th[x])) # set plausible starting liability if(model=="OU") alpha<-0.1*max(nodeHeights(tree)) if(model=="lambda") lambda<-1.0 # for MCMC n<-length(tree$tip) m<-length(th) npar<-if(model=="BM") tree$Nnode+n+m-2 else tree$Nnode+n+m-1 # populate control list PrA<-matrix(1/m,tree$Nnode,m,dimnames=list(1:tree$Nnode+n,seq)) if(!is.null(control$pr.anc)){ if(!is.matrix(control$pr.anc)){ message("**** NOTE: prior on ancestral states must be in matrix form; using default prior") control$pr.anc<-NULL } else { control$pr.anc<-control$pr.anc[,seq,drop=FALSE] PrA[rownames(control$pr.anc),]<-control$pr.anc control$pr.anc<-PrA } } con=list(sample=1000, propliab=0.5*max(nodeHeights(tree)), propthresh=0.05*max(nodeHeights(tree)), propalpha=0.1*max(nodeHeights(tree)), proplambda=0.01, pr.anc=PrA, pr.th=0.01, burnin=round(0.2*ngen), plot=FALSE, print=TRUE, piecol=setNames(palette()[1:length(seq)],seq), tipcol="input", quiet=FALSE) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # now set ancestral liabilities, by first picking ancestral states from their prior temp<-apply(con$pr.anc,1,rstate) # assign random liabilities consistent with the starting thresholds a<-sapply(temp,function(x) runif(n=1,min=th[x]-1,max=th[x])) # now change the upper limit of th to Inf th[length(th)]<-Inf # compute some matrices & values V<-if(model=="BM") vcvPhylo(tree) else if(model=="OU") vcvPhylo(tree,model="OU",alpha=alpha) else if(model=="lambda") vcvPhylo(tree,model="lambda",lambda=lambda) # check to make sure that V will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") invV<-solve(V) detV<-determinant(V,logarithm=TRUE)$modulus[1] lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq)) # store A<-matrix(NA,ngen/con$sample+1,tree$Nnode,dimnames=list(NULL,n+1:tree$Nnode)) B<-if(model=="BM") matrix(NA,ngen/con$sample+1,m+2,dimnames=list(NULL,c("gen",names(th),"logLik"))) else if(model=="OU") matrix(NA,ngen/con$sample+1,m+3,dimnames=list(NULL,c("gen",names(th),"alpha","logLik"))) else if(model=="lambda") matrix(NA,ngen/con$sample+1,m+3,dimnames=list(NULL,c("gen",names(th),"lambda","logLik"))) C<-matrix(NA,ngen/con$sample+1,tree$Nnode+n,dimnames=list(NULL,c(tree$tip.label,1:tree$Nnode+n))) A[1,]<-threshState(a,thresholds=th) B[1,]<-if(model=="BM") c(0,th,lik1) else if(model=="OU") c(0,th,alpha,lik1) else if(model=="lambda") c(0,th,lambda,lik1) C[1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)]) # run MCMC message("MCMC starting....") logL<-lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq)) for(i in 1:ngen){ lik1<-logL d<-i%%npar if(ngen>=1000) if(i%%1000==0) if(con$print) message(paste("gen",i)) ap<-a; lp<-l; thp<-th if(model=="OU") alphap<-alpha if(model=="lambda") lambdap<-lambda Vp<-V; invVp<-invV; detVp<-detV if(d<=tree$Nnode&&d!=0){ # update node liabilities ind<-d%%tree$Nnode; if(ind==0) ind<-tree$Nnode ap[ind]<-a[ind]+rnorm(n=1,sd=sqrt(con$propliab)) } else { if((d>tree$Nnode&&d<=(tree$Nnode+n))||(npar==(tree$Nnode+n)&&d==0)){ # update tip liabilities if(d==0) ind<-n else { ind<-(d-tree$Nnode)%%n; if(ind==0) ind<-n } lp[ind]<-l[ind]+rnorm(n=1,sd=sqrt(con$propliab)) } else if(d>(tree$Nnode+n)&&d<=(tree$Nnode+n+m-2)||(npar==(tree$Nnode+n+m-2)&&d==0)) { # update thresholds if(d) ind<-(d-tree$Nnode-n)%%m+1 else ind<-m-1 thp[ind]<-bounce(th[ind],rnorm(n=1,sd=sqrt(con$propthresh)),c(th[ind-1],th[ind+1])) } else { if(model=="OU"){ alphap<-bounce(alpha,rnorm(n=1,sd=sqrt(con$propalpha)),c(0,Inf)) Vp<-vcvPhylo(tree,model="OU",alpha=alphap) } else if(model=="lambda"){ lambdap<-bounce(lambda,rnorm(n=1,sd=sqrt(con$proplambda)),c(0,1)) Vp<-vcvPhylo(tree,model="lambda",lambda=lambdap) } invVp<-solve(Vp) detVp<-determinant(Vp,logarithm=TRUE)$modulus[1] } } lik2<-likLiab(lp,ap,Vp,invVp,detVp)+log(probMatch(X,lp,thp,seq)) p.odds<-min(c(1,exp(lik2+logPrior(threshState(ap,thresholds=thp),thp,con)-lik1-logPrior(threshState(a,thresholds=th),th,con)))) if(p.odds>runif(n=1)){ a<-ap; l<-lp; th<-thp V<-Vp; detV<-detVp; invV<-invVp if(model=="OU") alpha<-alphap if(model=="lambda") lambda<-lambdap logL<-lik2 } else logL<-lik1 if(i%%con$sample==0){ A[i/con$sample+1,]<-threshState(a,thresholds=th) B[i/con$sample+1,]<-if(model=="BM") c(i,th[colnames(B)[1+1:m]],logL) else if(model=="OU") c(i,th[colnames(B)[1+1:m]],alpha,logL) else if(model=="lambda") c(i,th[colnames(B)[1+1:m]],lambda,logL) C[i/con$sample+1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)]) } } mcmc<-as.data.frame(A) param<-as.data.frame(B) liab<-as.data.frame(C) ace<-matrix(0,tree$Nnode,m,dimnames=list(colnames(A),seq)) burnin<-which(param[,"gen"]==con$burnin) for(i in 1:tree$Nnode){ temp<-summary(mcmc[burnin:nrow(mcmc),i])/(nrow(mcmc)-burnin+1) ace[i,names(temp)]<-temp } obj<-list(ace=ace,mcmc=mcmc,par=param,liab=liab, tree=tree,x=x,model=model, seq=seq, ngen=ngen,sample=con$sample, burnin=con$burnin) class(obj)<-"ancThresh" if(con$plot) plot(obj) obj } ## some S3 methods (added in 2017) print.ancThresh<-function(x,...){ cat("\nObject containing the results from an MCMC analysis\nof the threshold model using ancThresh.\n\n") cat("List with the following components:\n") cat(paste("ace:\tmatrix with posterior probabilities assuming",x$burnin, "\n\tburn-in generations.\n")) cat("mcmc:\tposterior sample of liabilities at tips & internal\n") cat(paste("\tnodes (a matrix with",nrow(x$mcmc),"rows &",ncol(x$mcmc),"columns).\n")) cat("par:\tposterior sample of the relative positions of the\n") cat(paste("\tthresholds, the log-likelihoods, and any other\n", "\tmodel variables (a matrix with",nrow(x$par),"rows).\n\n")) cat("The MCMC was run under the following conditions:\n") cat(paste("\tseq =",paste(x$seq,collapse=" <-> "), "\n\tmodel =",x$model,"\n\tnumber of generations =",x$ngen, "\n\tsample interval=",x$sample, "\n\tburn-in =",x$burnin,"\n\n")) } plot.ancThresh<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-x$burnin args<-list(...) if(is.null(args$lwd)) args$lwd<-1 if(is.null(args$ylim)) args$ylim<-c(-0.1*Ntip(x$tree),Ntip(x$tree)) if(is.null(args$offset)) args$offset<-0.5 if(is.null(args$ftype)) args$ftype="i" args$tree<-x$tree do.call(plotTree,args) ii<-which(x$par[,1]==burnin)+1 LIAB<-as.matrix(x$liab)[ii:nrow(x$liab),] THRESH<-as.matrix(x$par)[ii:nrow(x$par),1:length(x$seq)+1] STATES<-matrix(NA,nrow(LIAB),ncol(LIAB),dimnames=dimnames(LIAB)) for(i in 1:nrow(LIAB)) STATES[i,]<-threshState(LIAB[i,],THRESH[i,]) PP<-t(apply(STATES,2,function(x,levs) summary(factor(x,levels=levs))/length(x), levs=x$seq)) if(hasArg(piecol)) piecol<-list(...)$piecol else piecol<-setNames(colorRampPalette(c("blue", "yellow"))(length(x$seq)),x$seq) if(hasArg(node.cex)) node.cex<-list(...)$node.cex else node.cex<-0.6 nodelabels(pie=PP[1:x$tree$Nnode+Ntip(x$tree),], piecol=piecol,cex=node.cex) if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex else tip.cex<-0.4 tiplabels(pie=PP[x$tree$tip.label,],piecol=piecol, cex=tip.cex) legend(x=par()$usr[1],y=par()$usr[1],legend=x$seq,pch=21,pt.bg=piecol, pt.cex=2.2,bty="n") invisible(PP) } # plots ancestral states from the threshold model # written by Liam J. Revell 2012, 2014 plotThresh<-function(tree,x,mcmc,burnin=NULL,piecol,tipcol="input",legend=TRUE,...){ if(is.logical(legend)||is.vector(legend)){ if(is.logical(legend)&&legend==TRUE) leg<-setNames(names(piecol),names(piecol)) else if(is.vector(legend)){ leg<-legend[names(piecol)] legend<-TRUE } } # plot tree par(lend=2) plotTree(tree,ftype="i",lwd=1,ylim=if(legend) c(-0.1*length(tree$tip.label),length(tree$tip.label)) else NULL,...) if(legend){ zz<-par()$cex; par(cex=0.6) for(i in 1:length(piecol)) add.simmap.legend(leg=leg[i],colors=piecol[i],prompt=FALSE,x=0.02*max(nodeHeights(tree)),y=-0.1*length(tree$tip.label),vertical=FALSE,shape="square",fsize=1) par(cex=zz) } # pull matrices from mcmc ace<-mcmc$ace liab<-mcmc$liab param<-mcmc$par # get burnin if(is.null(burnin)) burnin<-round(0.2*max(param[,"gen"])) burnin<-which(param[,"gen"]==burnin) # check x if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)) X<-x[tree$tip.label,] else if(is.vector(x)){ x<-x[tree$tip.label] X<-to.matrix(x,names(piecol)) } # row scale X X/apply(X,1,sum)->X # plot node labels nodelabels(pie=ace,piecol=piecol[colnames(ace)],cex=0.6) # plot tip labels if(tipcol=="input") tiplabels(pie=X,piecol=piecol[colnames(X)],cex=0.6) else if(tipcol=="estimated") { XX<-matrix(NA,nrow(liab),length(tree$tip),dimnames=list(rownames(liab),colnames(liab)[1:length(tree$tip)])) for(i in 1:nrow(liab)) XX[i,]<-threshState(liab[i,1:length(tree$tip)],thresholds=param[i,1:ncol(X)+1]) X<-t(apply(XX,2,function(x) summary(factor(x,levels=colnames(X))))) tiplabels(pie=X/rowSums(X),piecol=piecol[colnames(X)],cex=0.6) } } # computes DIC for threshold model # written by Liam J. Revell 2012, 2014 threshDIC<-function(tree,x,mcmc,burnin=NULL,sequence=NULL,method="pD"){ ## identify model if(any(colnames(mcmc$par)=="alpha")) model<-"OU" else if(any(colnames(mcmc$par)=="lambda")) model<-"lambda" else model<-"BM" # check x if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)){ X<-x[tree$tip.label,] if(is.null(sequence)){ message("**** NOTE: no sequence provided, column order in x") seq<-colnames(X) } else seq<-sequence } else if(is.vector(x)){ x<-x[tree$tip.label] if(is.null(sequence)){ message("**** NOTE: no sequence provided, using alphabetical or numerical order") seq<-sort(levels(as.factor(x))) } else seq<-sequence X<-to.matrix(x,seq) } # row scale X X<-X/apply(X,1,sum) X<-X[,seq] # order columns by seq # convert burnin to starting row if(is.null(burnin)) burnin<-0.2*max(mcmc$par[,"gen"]) start<-which(mcmc$par[,"gen"]==burnin)+1 # compute k<-if(model=="BM") 1 else 2 thBar<-colMeans(mcmc$par[start:nrow(mcmc$par),2:(ncol(mcmc$par)-k)]) liabBar<-colMeans(mcmc$liab[start:nrow(mcmc$liab),]) if(model=="BM") V<-vcvPhylo(tree) else if(model=="OU") V<-vcvPhylo(tree,model="OU",alpha=mean(mcmc$par[start:nrow(mcmc$par),"alpha"])) else if(model=="lambda") V<-vcvPhylo(tree,model="lambda",lambda=mean(mcmc$par[start:nrow(mcmc$par),"lambda"])) Dtheta<--2*(likLiab(liabBar[tree$tip.label],liabBar[as.character(1:tree$Nnode+length(tree$tip))],V,solve(V),determinant(V,logarithm=TRUE)$modulus[1])+log(probMatch(X[tree$tip.label,],liabBar[tree$tip.label],thBar,seq))) D<--2*mcmc$par[start:nrow(mcmc$par),"logLik"] Dbar<-mean(D) if(method=="pD"){ pD<-Dbar-Dtheta DIC<-pD+Dbar result<-setNames(c(Dbar,Dtheta,pD,DIC),c("Dbar","Dhat","pD","DIC")) } else if(method=="pV"){ pV<-var(D)/2 DIC<-pV+Dbar result<-setNames(c(Dbar,Dtheta,pV,DIC),c("Dbar","Dhat","pV","DIC")) } return(result) } # internal functions for ancThresh, plotThresh, and threshDIC ## returns a state based on position relative to thresholds ## threshStateC is a function from phangorn>=2.3.1 threshState<-if(packageVersion("phangorn")>='2.3.1'){ function(x,thresholds){ res <- names(thresholds)[threshStateC(x, thresholds)] names(res) <- names(x) res } } else function(x,thresholds){ t<-c(-Inf,thresholds,Inf) names(t)[length(t)]<-names(t)[length(t)-1] i<-1 while(x>t[i]) i<-i+1 names(t)[i] } # likelihood function for the liabilities likLiab<-function(l,a,V,invV,detV){ y<-c(l,a[2:length(a)])-a[1] logL<--y%*%invV%*%y/2-nrow(V)*log(2*pi)/2-detV/2 return(logL) } # function for the log-prior logPrior<-function(a,t,control){ # pp<-sum(log(diag(control$pr.anc[names(a),a])))+ pp<-sum(log(control$pr.anc[cbind(names(a),a)])) + if(length(t)>2) sum(dexp(t[2:(length(t)-1)],rate=control$pr.th,log=TRUE)) else 0 return(pp) } # check if the liability predictions match observed data allMatch<-function(x,l,thresholds){ result<-all(threshState(l,thresholds=thresholds)==x) if(!is.na(result)) return(result) else return(FALSE) } # check if the liability predictions match observed data & return a probability # (this allows states to be uncertain) probMatch<-function(X,l,thresholds,sequence){ Y<-to.matrix(threshState(l,thresholds=thresholds),sequence) return(prod(rowSums(X*Y))) } # bounds parameter by bouncing bounce<-function(start,step,bounds){ x<-start+step while(x>bounds[2]||xbounds[2]) x<-2*bounds[2]-x if(x=0) obj$xx[i] else max(obj$xx) dy<-obj$yy[i] x1<-x2<-dx+sw x3<-x4<-x1+x[i] y1<-y4<-dy-w/2 y2<-y3<-dy+w/2 polygon(c(x1,x2,x3,x4)-min(0,min(x)), c(y1,y2,y3,y4),col=col[i],border=border) } } else if(type=="fan"){ if(min(x)<0) h<-max(nodeHeights(tree)) sw<-if(tip.labels) fsize*(max(strwidth(tree$tip.label)))+fsize*strwidth("1") else strwidth("l") for(i in 1:length(x)){ theta<-atan(obj$yy[i]/obj$xx[i]) s<-if(obj$xx[i]>0) 1 else -1 if(min(x)>=0){ dx<-obj$xx[i]+s*cos(theta)*sw dy<-obj$yy[i]+s*sin(theta)*sw } else { dx<-s*h*cos(theta)+s*cos(theta)*sw dy<-s*h*sin(theta)+s*sin(theta)*sw } x1<-dx+(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta) y1<-dy-(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta) x2<-dx-(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta) y2<-dy+(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta) x3<-s*x[i]*cos(theta)+x2 y3<-s*x[i]*sin(theta)+y2 x4<-s*x[i]*cos(theta)+x1 y4<-s*x[i]*sin(theta)+y1 polygon(c(x1,x2,x3,x4),c(y1,y2,y3,y4),col=col[i], border=border) } } invisible(obj) } phytools/R/evol.rate.mcmc.R0000644000176200001440000004031113200731240015263 0ustar liggesusers## these functions uses a Bayesian MCMC approach to estimate heterogeneity in the evolutionary rate for a ## continuous character (Revell, Mahler, Peres-Neto, & Redelings. 2012.) ## code written by Liam J. Revell 2010, 2011, 2013, 2015, 2017 ## function for Bayesian MCMC ## written by Liam J. Revell 2010, 2011, 2017 evol.rate.mcmc<-function(tree,x,ngen=10000,control=list(),...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(is.matrix(x)) x<-x[,1] if(is.null(names(x))){ if(length(x)==length(tree$tip)){ message("x has no names; assuming x is in the same order as tree$tip.label") names(x)<-tree$tip.label } else stop("x has no names and is a different length than tree$tip.label") } if(any(is.na(match(tree$tip.label,names(x))))){ message("some species in tree are missing from data, dropping missing taxa from the tree") tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)]) } if(any(is.na(match(names(x),tree$tip.label)))){ message("some species in data are missing from tree, dropping missing taxa from the data") x<-x[tree$tip.label] } if(any(is.na(x))){ message("some data given as 'NA', dropping corresponding species from tree") tree<-drop.tip(tree,names(which(is.na(x)))) } # first, try and obtain reasonable estimates for control parameters # and starting values for the MCMC C<-vcv.phylo(tree) C<-C[names(x),names(x)] n<-nrow(C) one<-matrix(1,n,1) a<-colSums(solve(C))%*%x/sum(solve(C)) # MLE ancestral value, used to start MCMC sig1<-as.numeric(t(x-one%*%a)%*%solve(C)%*%(x-one%*%a)/n) # MLE sigma-squared, used to start MCMC sig2<-sig1 # used to start MCMC flipped=FALSE # used to start MCMC # populate control list con=list(sig1=sig1,sig2=sig2,a=as.numeric(a),sd1=0.2*sig1,sd2=0.2*sig2, sda=0.2*abs(as.numeric(a)),kloc=0.2*mean(diag(C)),sdlnr=1, rand.shift=0.05,print=100,sample=100) # also might use: sig1mu=1000,sig2mu=1000 con[(namc <- names(control))] <- control con<-con[!sapply(con,is.null)] # print control parameters to screen if(!quiet){ message("Control parameters (set by user or default):") str(con) } # now detach the starting parameter values (to be compatible with downstream code) sig1<-con$sig1 sig2<-con$sig1 a<-con$a # all internal functions start here # function to return the index of a random edge random.node<-function(phy){ # sum edges cumulatively cum.edge<-vector(mode="numeric") index<-vector(mode="numeric") for(i in 1:length(phy$edge.length)){ if(i==1) cum.edge[i]<-phy$edge.length[1] else cum.edge[i]<-cum.edge[i-1]+phy$edge.length[i] index[i]<-phy$edge[i,2] } # pick random position pos<-runif(1)*cum.edge[length(phy$edge.length)] edge<-1 while(pos>cum.edge[edge]) edge<-edge+1 return (index[edge]) } # return the indices of a vector that match a scalar match.all<-function(s,v){ result<-vector(mode="numeric") j=1 for(i in 1:length(v)){ if(s==v[i]){ result[j]=i j=j+1 } } if(j==1) result<-NA return(result) } # function to return a matrix of the descendant tips from each internal & terminal node compute.descendant.species<-function(phy){ D<-dist.nodes(phy) ntips<-length(phy$tip.label) Cii<-D[ntips+1,] C<-D C[,]<-0 counts<-vector() for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 tol<-1e-10 descendants<-matrix(0,nrow(D),ntips,dimnames=list(rownames(D))) for(i in 1:nrow(C)){ k<-0 for(j in 1:ntips){ if(C[i,j]>=(C[i,i]-tol)){ k<-k+1 descendants[i,k]<-phy$tip.label[j] } } counts[i]<-k } names(counts)<-rownames(descendants) return(descendants=list(species=descendants,counts=counts)) } # take a step on the tree (used in MCMC) tree.step<-function(phy,node,bp,step,up=NA,flip=FALSE){ if(step<0) step=-step # if user has given -step, positivize if(is.na(up)) up=(runif(1)>0.5) # if up/down is not assigned, we must be in the middle of a branch # decide to go up (1) or down (0) with equal probability if(up){ # pick a new position along the branch (or go to the end) new.bp<-min(bp+step,phy$edge.length[match(node,phy$edge[,2])]) # adjust step length to remain step step=step-(new.bp-bp) # check to see if we're done if(step<1e-6){ return(list(node=node,bp=new.bp,flip=flip)) } else { # we're going up, so get the daughters daughters<-phy$edge[match.all(node,phy$edge[,1]),2] # pick a random daughter new.node<-daughters[ceiling(runif(1)*length(daughters))] if(is.na(new.node)){ location<-tree.step(phy,node,phy$edge.length[match(node,phy$edge[,2])],step,up=FALSE,flip) # we're at a tip } else { location<-tree.step(phy,new.node,0,step,up=TRUE,flip) } } } else { # pick a new position along the branch (or go to the start) new.bp<-max(bp-step,0) # adjust step length step=step-(bp-new.bp) # check to see if we're done if(step<1e-6){ return(list(node=node,bp=new.bp,flip=flip)) } else { # we're going down so find out who the parent is parent<-phy$edge[match(node,phy$edge[,2]),][1] # find the other daughter(s) daughters<-phy$edge[match.all(parent,phy$edge[,1]),2] # don't use parent if root if(parent==(length(phy$tip.label)+1)){ parent=NULL # if at the base of the tree } # create a vector of the possible nodes: the parent, and sister(s) possible.nodes<-c(parent,daughters[-match(node,daughters)]) # now pick randomly new.node<-possible.nodes[ceiling(runif(1)*length(possible.nodes))] # if parent if(is.null(parent)==FALSE&&new.node==parent){ location<-tree.step(phy,new.node,phy$edge.length[match(new.node,phy$edge[,2])],step,up=FALSE,flip) } else { location<-tree.step(phy,new.node,0,step,up=TRUE,flip=TRUE) } } } } # log-likelihood function likelihood<-function(y,phy,C,descendants,sig1,sig2,a,loc){ C1<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C)) C2<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C)) n<-length(y) D<-matrix(1,n,1) if(loc$node>length(phy$tip.label)){ tr1<-extract.clade(phy,loc$node) tr1$root.edge<-phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp temp<-vcv.phylo(tr1)+tr1$root.edge } else { temp<-matrix(phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp,1,1,dimnames=list(c(phy$tip.label[loc$node]),c(phy$tip.label[loc$node]))) } C2[rownames(temp),colnames(temp)]<-temp C1<-C-C2 # tips<-phy$tip.label[-match(rownames(temp),phy$tip.label)] tips<-rownames(temp) V<-sig1*C1+sig2*C2 logL<-as.numeric(-t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*log(2*pi)/2-determinant(V)$modulus[1]/2) return(list(logL=logL,tips=tips)) } # prior probability function log.prior<-function(s1,s2,a,location){ # logpr<-dexp(s1,rate=1/con$sig1mu,log=TRUE)+dexp(s2,rate=1/con$sig2mu,log=TRUE) # exponential prior logpr<-dnorm(log(s1)-log(s2),mean=0,sd=con$sdlnr,log=TRUE)-log(s1*s2) # log-normal return(logpr) } # proposal on sig1 or sig2 propose.sig<-function(sig,scale){ # if normal sig.prime<-abs(sig+rnorm(n=1,sd=scale)) # normal proposal distribution # if cauchy # sig.prime<-abs(sig+rcauchy(n=1,scale=scale)) return(sig.prime) } # proposal on a propose.a<-function(a,scale){ # if normal a.prime<-a+rnorm(n=1,sd=scale) # normal proposal distribution return(a.prime) } # proposal on loc propose.loc<-function(phy,loc,k,r){ loc.prime<-list() loc.prime$flip=FALSE if(runif(1)>r){ loc.prime<-tree.step(phy,loc$node,loc$bp,step=rexp(n=1,rate=1/k)) # update node & bp by random walk: rexp() # loc.prime<-tree.step(phy,loc$node,loc$bp,step=abs(rnorm(n=1,sd=sqrt(2)/k))) # update node & bp by random walk: rnorm() } else { loc.prime$node<-random.node(phy) # pick random branch loc.prime$bp<-runif(1)*phy$edge.length[match(loc.prime$node,phy$edge[,2])] if((runif(1)>0.5)) loc.prime$flip=TRUE } return(loc.prime) } # obtain remaining starting values for the MCMC location<-list() location$node<-random.node(tree) location$bp<-runif(1)*tree$edge.length[match(location$node,tree$edge[,2])] location$flip<-FALSE descendants<-compute.descendant.species(tree) # compute descendants logL<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$logL logpr<-log.prior(sig1,sig2,a,location) # create matrix for results results<-matrix(NA,floor(ngen/con$sample)+1,7,dimnames=list(c(0,1:(ngen/con$sample)),c("state","sig1","sig2","a","node","bp","likelihood"))) curr.gen<-matrix(NA,1,7,dimnames=list("curr",c("state","sig1","sig2","a","node","bp","likelihood"))) results[1,]<-c(0,sig1,sig2,a,location$node,location$bp,logL) # populate the first row curr.gen[1,]<-results[1,] group.tips<-list() tips<-list() group.tips[[1]]<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$tips tips[[1]]<-group.tips[[1]] message("Starting MCMC run....") if(!quiet) print(results[1,]) j<-2 # now run Markov-chain for(i in 1:ngen){ if(i%%4==1) sig1.prime<-propose.sig(sig1,scale=con$sd1) # update sig1 else sig1.prime<-sig1 if(i%%4==2) sig2.prime<-propose.sig(sig2,scale=con$sd2) # update sig2 else sig2.prime<-sig2 if(i%%4==3) a.prime<-propose.a(a,scale=con$sda) # update a else a.prime<-a if(i%%4==0){ location.prime<-propose.loc(phy=tree,loc=location,k=con$kloc,r=con$rand.shift) if(location.prime$flip==TRUE){ flipped.prime<-!flipped # flip the sigmas } else flipped.prime<-flipped } else { location.prime<-location flipped.prime<-flipped } if(!flipped.prime){ temp<-likelihood(x,tree,C,descendants,sig1.prime,sig2.prime,a.prime,location.prime) logpr.prime<-log.prior(sig1.prime,sig2.prime,a.prime,location.prime) if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){ sig1<-sig1.prime sig2<-sig2.prime a<-a.prime location<-location.prime logL<-temp$logL logpr<-logpr.prime flipped<-flipped.prime group.tips[[i+1]]<-temp$tips } else group.tips[[i+1]]<-group.tips[[i]] } else { temp<-likelihood(x,tree,C,descendants,sig2.prime,sig1.prime,a.prime,location.prime) logpr.prime<-log.prior(sig2.prime,sig1.prime,a.prime,location.prime) if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){ sig1<-sig1.prime sig2<-sig2.prime a<-a.prime location<-location.prime logL<-temp$logL logpr<-logpr.prime flipped<-flipped.prime group.tips[[i+1]]<-setdiff(tree$tip.label,temp$tips) } else group.tips[[i+1]]<-group.tips[[i]] } rm(temp) curr.gen[1,]<-c(i,sig1,sig2,a,location$node,location$bp,logL) if(i%%con$print==0) if(!quiet) print(curr.gen[1,]) if(i%%con$sample==0){ results[j,]<-curr.gen tips[[j]]<-group.tips[[i+1]] j<-j+1 } } message("Done MCMC run.") # return results obj<-list(mcmc=results,tips=tips,ngen=ngen,sample=con$sample) class(obj)<-"evol.rate.mcmc" obj } ## S3 print method print.evol.rate.mcmc<-function(x, ...){ cat("\nObject of class \"evol.rate.mcmc\" containing the results from a\n") cat("the Bayesian MCMC analysis of a Brownian-motion rate-shift model.\n\n") cat(paste("MCMC was conducted for",x$ngen,"generations sampling every",x$sample,"\n")) cat("generations.\n\n") cat("The most commonly sampled rate shift(s) occurred on the edge(s)\n") pp<-table(x$mcmc[,"node"])/nrow(x$mcmc) node<-names(pp)[which(pp==max(pp))] if(length(node)==1) cat(paste("to node(s) ",node,".\n\n",sep="")) else cat(paste("leading to node(s) ",paste(node,collapse=", "),".\n\n",sep="")) cat("Use the functions posterior.evolrate and minSplit for more detailed\n") cat("analysis of the posterior sample from this analysis.\n\n") } # this function finds the split with the minimum the distance to all the other splits in the sample # written by Liam J. Revell 2010, 2015 minSplit<-function(tree,split.list,method="sum",printD=FALSE){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # determine is split.list is a list from our mcmc run, or a matrix if(class(split.list)=="list") split.list<-split.list$mcmc[,c("node","bp")] else if(class(split.list)=="matrix") split.list<-split.list[,c("node","bp")] # start by creating a matrix of the nodes of the tree with their descendant nodes D<-dist.nodes(tree) ntips<-length(tree$tip.label) Cii<-D[ntips+1,] C<-D C[,]<-0 for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 tol<-1e-10 descendants<-matrix(0,nrow(D),ncol(D),dimnames=list(rownames(D))) for(i in 1:nrow(C)){ k<-1 for(j in 1:ncol(C)){ if(C[i,j]>=(C[i,i]-tol)){ descendants[i,k]<-j k<-k+1 } } } distances<-matrix(0,nrow(split.list),nrow(split.list)) for(i in 1:nrow(split.list)){ for(j in i:nrow(split.list)){ if(i!=j){ # first, if on the same branch as current average - then just compute the difference if(split.list[i,1]==split.list[j,1]){ distances[i,j]<-abs(split.list[i,2]-split.list[j,2]) } else { distances[i,j]<-D[split.list[i,1],split.list[j,1]] # is the split j downstream if(split.list[j,1]%in%descendants[split.list[i,1],]){ # downstream distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) } else if(split.list[i,1]%in%descendants[split.list[j,1],]){ # ancestral distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) } else { # neither distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) } } distances[j,i]<-distances[i,j] } } } if(method=="sumsq") distances<-distances^2 if(method!="sumsq"&&method!="sum") message("allowable methods are 'sum' and 'sumsq' - using default method ('sum')") if(printD) print(distances) sum.dist<-colSums(distances) ind<-which.min(sum.dist) # this is the index of the minimum split # return minimum split return(list(node=split.list[ind,1],bp=split.list[ind,2])) } # function to analyze the posterior from evol.rate.mcmc() # written by Liam Revell 2011 posterior.evolrate<-function(tree,ave.shift,mcmc,tips,showTree=FALSE){ result<-matrix(NA,nrow(mcmc),7,dimnames=list(NULL,c("state","sig1","sig2","a","node","bp","likelihood"))) tree$node.label<-NULL for(i in 1:nrow(mcmc)){ shift=list(node=mcmc[i,"node"],bp=mcmc[i,"bp"]) temp<-ave.rates(tree,shift,tips[[i]],mcmc[i,"sig1"],mcmc[i,"sig2"],ave.shift,showTree=showTree) result[i,]<-c(mcmc[i,"state"],temp[[1]],temp[[2]],mcmc[i,"a"],mcmc[i,"node"],mcmc[i,"bp"],mcmc[i,"likelihood"]) } return(result) } # average the posterior rates # written by Liam Revell 2011 ave.rates<-function(tree,shift,tips,sig1,sig2,ave.shift,showTree=TRUE){ # first split and scale at shift unscaled<-splitTree(tree,shift) # now scale scaled<-unscaled if(length(setdiff(scaled[[1]]$tip.label,tips))!=1){ scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig1 scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig2 if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig2 } else { scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig2 scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig1 if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig1 } # now bind tr.scaled<-paste.tree(scaled[[1]],scaled[[2]]) if(showTree==TRUE) plot(tr.scaled) # now split tr.scaled and tree at ave.shift unscaled<-splitTree(tree,ave.shift) scaled<-splitTree(tr.scaled,ave.shift) # now compute the sig1 and sig2 to return sig1<-sum(scaled[[1]]$edge.length)/sum(unscaled[[1]]$edge.length) sig2<-sum(scaled[[2]]$edge.length)/sum(unscaled[[2]]$edge.length) return(list(sig1=sig1,sig2=sig2)) } phytools/R/mrp.supertree.R0000644000176200001440000001005112625646346015305 0ustar liggesusers# function for Matrix Representation Parsimony supertree estimation in R # uses pratchet() or optim.parsimony() from the "phangorn" package # written by Liam J. Revell 2011, 2013, 2015 compute.mr<-function(trees,type=c("phyDat","matrix")){ type<-type[1] if(inherits(trees,"phylo")){ trees<-list(trees) class(trees)<-"multiPhylo" } if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"phylo\" or \"multiPhylo\".") # compute matrix representation phylogenies X<-list() # list of bipartitions characters<-0 # number of characters for(i in 1:length(trees)){ temp<-prop.part(trees[[i]]) # find all bipartitions # create matrix representation of trees[[i]] in X[[i]] X[[i]]<-matrix(0,nrow=length(trees[[i]]$tip),ncol=length(temp)-1) for(j in 1:ncol(X[[i]])) X[[i]][c(temp[[j+1]]),j]<-1 rownames(X[[i]])<-attr(temp,"labels") # label rows if(i==1) species<-trees[[i]]$tip.label else species<-union(species,trees[[i]]$tip.label) # accumulate labels characters<-characters+ncol(X[[i]]) # count characters } XX<-matrix(data="?",nrow=length(species),ncol=characters,dimnames=list(species)) j<-1 for(i in 1:length(X)){ # copy each of X into supermatrix XX XX[rownames(X[[i]]),c(j:((j-1)+ncol(X[[i]])))]<-X[[i]][1:nrow(X[[i]]),1:ncol(X[[i]])] j<-j+ncol(X[[i]]) } if(type=="phyDat"){ # compute contrast matrix for phangorn contrast<-matrix(data=c(1,0,0,1,1,1),3,2,dimnames=list(c("0","1","?"),c("0","1")),byrow=TRUE) # convert XX to phyDat object XX<-phyDat(XX,type="USER",contrast=contrast) } XX } mrp.supertree<-function(trees,method=c("pratchet","optim.parsimony"),...){ # set method method<-method[1] # some minor error checking if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") XX<-compute.mr(trees,type="phyDat") # estimate supertree if(method=="pratchet"){ if(hasArg(start)){ start<-list(...)$start if(class(start)=="phylo"){ supertree<-pratchet(XX,all=TRUE,...) } else { if(start=="NJ") start<-NJ(dist.hamming(XX)) else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX)) else { warning("do not recognize that option for start; using random starting tree") tree<-rtree(n=length(XX),tip.label=names(XX)) } args<-list(...) args$start<-start args$data<-XX args$all<-TRUE supertree<-do.call(pratchet,args) } } else supertree<-pratchet(XX,all=TRUE,...) if(class(supertree)=="phylo") message(paste("The MRP supertree, optimized via pratchet(),\nhas a parsimony score of ", attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) else if(class(supertree)=="multiPhylo") message(paste("pratchet() found ",length(supertree)," supertrees\nwith a parsimony score of ", attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) } else if(method=="optim.parsimony"){ if(hasArg(start)){ start<-list(...)$start if(class(start)=="phylo"){ supertree<-optim.parsimony(tree=start,data=XX,...) } else { if(start=="NJ") start<-NJ(dist.hamming(XX)) else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX)) else { warning("do not recognize that option for tree; using random starting tree") start<-rtree(n=length(XX),tip.label=names(XX)) } supertree<-optim.parsimony(tree=start,data=XX,...) } } else { message("no input starting tree or option for optim.parsimony; using random starting tree") start<-rtree(n=length(XX),tip.label=names(XX)) supertree<-optim.parsimony(tree=start,data=XX,...) } if(class(supertree)=="phylo") message(paste("The MRP supertree, optimized via optim.parsimony(),\nhas a parsimony score of ", attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) else if(class(supertree)=="multiPhylo") message(paste("optim.parsimony() found ",length(supertree)," supertrees\nwith a parsimony score of ", attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) } return(supertree) } phytools/R/plotTree.errorbars.R0000644000176200001440000000351313056063506016263 0ustar liggesusers## plot tree with error bars around divergence times at nodes ## written by Liam J. Revell 2017 plotTree.errorbars<-function(tree,CI,...){ args<-list(...) if(!is.null(args$gridlines)){ gridlines<-args$gridlines args$gridlines<-NULL } else gridlines<-TRUE if(is.null(args$mar)) args$mar<-c(4.1,1.1,1.1,1.1) if(is.null(args$ftype)) args$ftype<-"i" fsize<-if(!is.null(args$fsize)) args$fsize else 1 if(is.null(args$direction)) args$direction<-"leftwards" if(!is.null(args$bar.width)){ bar.width<-args$bar.width args$bar.width<-NULL } else bar.width<-11 if(!is.null(args$cex)){ cex<-args$cex args$cex<-NULL } else cex<-1.2 if(!is.null(args$bar.col)){ bar.col<-args$bar.col args$bar.col<-NULL } else bar.col<-"blue" par(mar=args$mar) plot.new() th<-max(nodeHeights(tree)) h<-max(th,max(CI)) if(is.null(args$xlim)){ m<-min(min(nodeHeights(tree)),min(CI)) d<-diff(c(m,h)) pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches") alp<-optimize(function(a,d,sw,pp) (a*1.04*d+sw-pp)^2, d=d,sw=sw,pp=pp, interval=c(0,1e6))$minimum args$xlim<-if(args$direction=="leftwards") c(h,m-sw/alp) else c(m,h+sw/alp) } if(is.null(args$at)) at<-seq(0,h,by=h/5) else { at<-args$at args$at<-NULL } args$tree<-tree args$add<-TRUE do.call(plotTree,args=args) if(gridlines) abline(v=at,lty="dashed", col=make.transparent("grey",0.5)) axis(1,at=at,labels=signif(at,3)) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:tree$Nnode+Ntip(tree)) lines(x=c(CI[i-Ntip(tree),1],CI[i-Ntip(tree),2]), y=rep(obj$yy[i],2),lwd=bar.width,lend=0, col=make.transparent(bar.col,0.4)) points(obj$xx[1:tree$Nnode+Ntip(tree)], obj$yy[1:tree$Nnode+Ntip(tree)],pch=19,col=bar.col, cex=cex) } phytools/R/phylo.to.map.R0000644000176200001440000002243013101725255015011 0ustar liggesusers## function depends on phytools (& dependencies) and maps (& dependencies) ## written by Liam J. Revell 2013, 2017 phylo.to.map<-function(tree,coords,rotate=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # optional arguments if(hasArg(database)) database<-list(...)$database else database<-"world" if(hasArg(regions)) regions<-list(...)$regions else regions<-"." if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-180,180) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(-90,90) # create a map map<-map(database,regions,xlim=xlim,ylim=ylim,plot=FALSE,fill=TRUE,resolution=0) # if rotate if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards" if(is.data.frame(coords)) coords<-as.matrix(coords) if(rotate&&type=="phylogram") tree<-minRotate(tree,coords[,if(direction=="rightwards") 1 else 2]) x<-list(tree=tree,map=map,coords=coords) class(x)<-"phylo.to.map" if(plot) plot.phylo.to.map(x,...) invisible(x) } # function to plot object of class "phylo.to.map" # written by Liam J. Revell 2013, 2014, 2016 plot.phylo.to.map<-function(x,type=c("phylogram","direct"),...){ type<-type[1] if(class(x)=="phylo.to.map"){ tree<-x$tree map<-x$map coords<-x$coords } else stop("x should be an object of class \"phylo.to.map\"") # get optional arguments if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-map$range[1:2] if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-map$range[3:4] if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(split)) split<-list(...)$split else split<-c(0.4,0.6) if(hasArg(psize)) psize<-list(...)$psize else psize<-1.0 if(hasArg(cex.points)){ cex.points<-list(...)$cex.points if(length(cex.points)==1) cex.points<-c(0.6*cex.points,cex.points) } else cex.points<-c(0.6*psize,psize) if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0,4) if(hasArg(asp)) asp<-list(...)$asp else asp<-1.0 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype) fsize=0 if(hasArg(from.tip)) from.tip<-list(...)$from.tip else from.tip<-FALSE if(hasArg(colors)) colors<-list(...)$colors else colors<-"red" if(length(colors)==1) rep(colors[1],2)->colors if(length(colors)==2&&type=="phylogram"){ colors<-matrix(rep(colors,nrow(coords)),nrow(coords),2,byrow=TRUE) rownames(colors)<-rownames(coords) } if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards" if(hasArg(pch)) pch<-list(...)$pch else pch<-21 if(length(pch)==1) pch<-rep(pch,2) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-c(2,1) if(length(lwd)==1) lwd<-rep(lwd,2) if(hasArg(lty)) lty<-list(...)$lty else lty<-"dashed" if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE # recompute ylim or xlim to leave space for the tree if(type=="phylogram"){ if(direction=="downwards"){ if(!ftype) ylim<-c(ylim[1],ylim[2]+0.03*diff(ylim)) ylim<-c(ylim[1],ylim[2]+ split[1]/split[2]*(ylim[2]-ylim[1])) } else if(direction=="rightwards"){ if(!ftype) xlim<-c(xlim[1]-0.03*diff(xlim),xlim[2]) xlim<-c(xlim[1]-split[1]/split[2]*(xlim[2]-xlim[1]),xlim[2]) } } # open & size a new plot par(mar=mar) plot.new() plot.window(xlim=xlim,ylim=ylim,asp=asp) map(map,add=TRUE,fill=TRUE,col="gray95",mar=rep(0,4)) if(type=="phylogram"){ ## preliminaries cw<-reorder(tree,"cladewise") n<-Ntip(cw) if(direction=="downwards"){ # plot a white rectangle dx<-abs(diff(xlim)) rect(xlim[1]-1.04*dx,ylim[2]-split[1]*(ylim[2]-ylim[1]), xlim[2]+1.04*dx,ylim[2],col="white",border="white") # rescale tree so it fits in the upper half of the plot # with enough space for labels pdin<-par()$din[2] sh<-(fsize*strwidth(paste(" ",cw$tip.label,sep=""))+ 0.3*fsize*strwidth("W"))*(par()$din[1]/par()$din[2])* (diff(par()$usr[3:4])/diff(par()$usr[1:2])) cw$edge.length<-cw$edge.length/max(nodeHeights(cw))* (split[1]*(ylim[2]-ylim[1])-max(sh)) pw<-reorder(cw,"postorder") ## post-order x<-vector(length=n+cw$Nnode) x[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(xlim[2]-xlim[1])+xlim[1] nn<-unique(pw$edge[,1]) # compute horizontal position of each edge for(i in 1:length(nn)){ xx<-x[pw$edge[which(pw$edge[,1]==nn[i]),2]] x[nn[i]]<-mean(range(xx)) } # compute start & end points of each edge Y<-ylim[2]-nodeHeights(cw) # plot coordinates & linking lines coords<-coords[cw$tip.label,2:1] for(i in 1:n) lines(c(x[i],coords[i,1]), c(Y[which(cw$edge[,2]==i),2]- if(from.tip) 0 else sh[i],coords[i,2]), col=colors[cw$tip.label,][i,1],lty=lty,lwd=lwd[2]) points(coords,pch=pch,cex=cex.points[2],bg=colors[cw$tip.label,2]) # plot vertical edges for(i in 1:nrow(Y)) lines(rep(x[cw$edge[i,2]],2),Y[i,], lwd=lwd[1],lend=2) # plot horizontal relationships for(i in 1:cw$Nnode+n) lines(range(x[cw$edge[which(cw$edge[,1]==i),2]]), Y[which(cw$edge[,1]==i),1],lwd=lwd[1],lend=2) # plot tip labels for(i in 1:n){ if(ftype) text(x[i],Y[which(cw$edge[,2]==i),2], paste(" ",sub("_"," ",cw$tip.label[i]),sep=""), pos=4,offset=c(0,1), srt=-90,cex=fsize,font=ftype) if(pts) points(x[i],Y[which(cw$edge[,2]==i),2],pch=21, bg=colors[cw$tip.label,][i,2], cex=cex.points[1]) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE, label.offset=fsize*strwidth(" ")/(par()$usr[2]- par()$usr[1])*(par()$usr[4]-par()$usr[3]), x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw), Nnode=cw$Nnode,edge=cw$edge,xx=x,yy=sapply(1:(Ntip(cw)+ cw$Nnode),function(x,y,z) y[match(x,z)],y=Y,z=cw$edge)) } else { dy<-abs(diff(ylim)) rect(xlim[1],ylim[1],xlim[1]+split[1]*(xlim[2]- xlim[1]),ylim[2],col="white",border="white") sh<-fsize*strwidth(paste(" ",cw$tip.label,sep=""))+ 0.2*fsize*strwidth("W") cw$edge.length<-cw$edge.length/max(nodeHeights(cw))* (split[1]*(xlim[2]-xlim[1])-max(sh)) pw<-reorder(cw,"postorder") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(ylim[2]-ylim[1])+ylim[1] nn<-unique(pw$edge[,1]) for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } H<-nodeHeights(cw) X<-xlim[1]+H coords<-coords[cw$tip.label,2:1] for(i in 1:n) lines(c(X[which(cw$edge[,2]==i),2]+ if(from.tip) 0 else sh[i],coords[i,1]), c(y[i],coords[i,2]),col=colors[cw$tip.label,][i,1],lty=lty,lwd=lwd[2]) points(coords,pch=pch,cex=cex.points[2],bg=colors[cw$tip.label,2]) for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd[1],lend=2) for(i in 1:cw$Nnode+n) lines(X[which(cw$edge[,1]==i),1], range(y[cw$edge[which(cw$edge[,1]==i),2]]),lwd=lwd[1],lend=2) for(i in 1:n){ if(ftype) text(X[which(cw$edge[,2]==i),2],y[i], paste(" ",sub("_"," ",cw$tip.label[i]),sep=""), pos=4,offset=0.1,cex=fsize,font=ftype) if(pts) points(X[which(cw$edge[,2]==i),2],y[i], pch=21,bg=colors[cw$tip.label,][i,2],cex=cex.points[1]) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0.1, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) } assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } else if(type=="direct"){ phylomorphospace(tree,coords[,2:1],add=TRUE,label="horizontal", node.size=c(0,psize),lwd=lwd[2],control=list(col.node= setNames(rep(colors[2],max(tree$edge)),1:max(tree$edge)), col.edge=setNames(rep(colors[1],nrow(tree$edge)),tree$edge[,2])), ftype=c("off","reg","b","i","bi")[ftype+1],fsize=fsize) } } ## rotates all nodes to try and match tip an ordering ## written by Liam J. Revell 2013, 2015 minRotate<-function(tree,x,...){ if(hasArg(print)) print<-list(...)$print else print<-TRUE tree<-reorder(tree) nn<-1:tree$Nnode+Ntip(tree) x<-x[tree$tip.label] for(i in 1:tree$Nnode){ tt<-read.tree(text=write.tree(rotate(tree,nn[i]))) oo<-sum(abs(order(x[tree$tip.label])-1:length(tree$tip.label))) pp<-sum(abs(order(x[tt$tip.label])-1:length(tt$tip.label))) if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } attr(tree,"minRotate")<-min(oo,pp) return(tree) } print.phylo.to.map<-function(x,...){ cat("Object of class \"phylo.to.map\" containing:\n\n") cat(paste("(1) A phylogenetic tree with",Ntip(x$tree),"tips and",x$tree$Nnode,"internal nodes.\n\n",sep=" ")) cat("(2) A geographic map with range:\n") cat(paste(" ",paste(round(x$map$range[3:4],2),collapse="N, "),"N\n",sep="")) cat(paste(" ",paste(round(x$map$range[1:2],2),collapse="W, "),"W.\n\n",sep="")) cat(paste("(3) A table containing",nrow(x$coords),"geographic coordinates.\n\n")) } phytools/R/write.simmap.R0000644000176200001440000000550013044122633015074 0ustar liggesusers## function writes a modified "phylo" object to a simmap Newick string ## written by Liam Revell 2011, 2013, 2015, 2017 write.simmap<-function(tree,file=NULL,append=FALSE,map.order=NULL,quiet=FALSE){ if(inherits(tree,"multiPhylo")){ if(is.null(file)) obj<-vector(mode="character",length=length(tree)) for(i in 1:length(tree)){ if(is.null(file)) obj[i]<-write.simmap(tree[[i]],file,if(i==1) append else TRUE,map.order,quiet) else write.simmap(tree[[i]],file,if(i==1) append else TRUE,map.order,quiet) } if(is.null(file)) return(obj) } else { if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") if(is.null(tree$maps)) stop("tree is does not contain a stochastic character map.") if(is.null(map.order)){ if(!is.null(attr(tree,"map.order"))) map.order<-attr(tree,"map.order") else { if(!quiet) message("map order should be specified in function call or by tree attribute \"map.order\".\nAssuming right-to-left order.") map.order<-"R" } } map.order<-toupper(unlist(strsplit(map.order,NULL))[1]) if(map.order!="R"&&map.order!="L"){ if(!quiet) message("do not recognize map order. Assuming right-to-left order.") map.order<-"R" } tree<-reorderSimmap(tree,"cladewise") n<-length(tree$tip) string<-vector(); string[1]<-"("; j<-2 for(i in 1:nrow(tree$edge)){ if(tree$edge[i,2]<=n){ string[j]<-tree$tip.label[tree$edge[i,2]]; j<-j+1 string[j]<-":{"; j<-j+1 if(map.order=="L"){ for(l in 1:length(tree$maps[[i]])){ string[j]<-paste(c(names(tree$maps[[i]])[l],",",round(tree$maps[[i]][l],8)),collapse="") string[j+1]<-":"; j<-j+2 } } else { for(l in length(tree$maps[[i]]):1){ string[j]<-paste(c(names(tree$maps[[i]])[l],",",round(tree$maps[[i]][l],8)),collapse="") string[j+1]<-":"; j<-j+2 } } string[j-1]<-"}" v<-which(tree$edge[,1]==tree$edge[i,1]); k<-i while(length(v)>0&&k==v[length(v)]){ string[j]<-")"; j<-j+1 w<-which(tree$edge[,2]==tree$edge[k,1]) if(length(w)>0){ string[j]<-":{"; j<-j+1 if(map.order=="L"){ for(l in 1:length(tree$maps[[w]])){ string[j]<-paste(c(names(tree$maps[[w]])[l],",",round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-":"; j<-j+2 } } else { for(l in length(tree$maps[[w]]):1){ string[j]<-paste(c(names(tree$maps[[w]])[l],",",round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-":"; j<-j+2 } } string[j-1]<-"}" } v<-which(tree$edge[,1]==tree$edge[w,1]); k<-w } string[j]<-","; j<-j+1 } else if(tree$edge[i,2]>=n){ string[j]<-"("; j<-j+1 } } string<-c(string[1:(length(string)-1)],";") string<-paste(string,collapse="") if(is.null(file)) return(string) else write(string,file=file,append=append) } } phytools/R/mcmcBM.full.R0000644000176200001440000001022511746536333014571 0ustar liggesusers# function # written by Liam J. Revell 2011 mcmcBM.full<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) a<-mean(xbar) v<-rep(mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T),n) names(v)<-names(xbar) prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*v) pr.mean<-c(1000,rep(0,n+1),rep(1000,n)) pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[n+2+1:n]^2) # populate control list con=list(sig2=sig2,a=a,xbar=xbar,v=v,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) names(con$v)<-gsub("\\)","",gsub("var\\(","",names(con$v))) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,v){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(v[names(x)]),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,a,xbar,v){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+sum(dexp(v,rate=1/con$pr.mean[n+2+1:n],log=T)) return(pp) } # compute C C<-vcv.phylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; xbar<-con$xbar; v<-con$v L<-likelihood(C,invC,detC,x,sig2,a,xbar,v) Pr<-log.prior(sig2,a,xbar,v) # store X<-matrix(NA,ngen/con$sample+1,2*n+4,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,paste("var(",tree$tip.label,")",sep=""),"logLik"))) X[1,]<-c(0,sig2,a,xbar,v,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(2*n+2) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,v) Pr.prime<-log.prior(sig2.prime,a,xbar,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,v,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,v) Pr.prime<-log.prior(sig2,a.prime,xbar,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,v,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j>1&&j<=(n+1)) { k<-j-1 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,v) Pr.prime<-log.prior(sig2,a,xbar.prime,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,v,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j>(n+1)){ k<-j-n-1 # update var v.prime<-v v.prime[k]<-v[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(v.prime[k]<0) v.prime[k]<--v.prime[k] L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,v.prime) Pr.prime<-log.prior(sig2,a,xbar,v.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v.prime,L.prime) v<-v.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/fastBM.R0000644000176200001440000000745713116240566013654 0ustar liggesusers## Simulates BM evolution more quickly. ## A trend can be simulated by mu!=0. ## mu=0 is standard BM; mu<0 downward trend; mu>0 upward trend. ## Bounds can be simulated by bounds=c(>-Inf,0. ## Written by Liam J. Revell 2011, 2013, 2015, 2017 fastBM<-function(tree,a=0,mu=0,sig2=1,bounds=c(-Inf,Inf),internal=FALSE,nsim=1,...){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") ## order if(is.null(attr(tree,"order"))||attr(tree,"order")!="cladewise") tree<-reorder(tree) ## check to see if alpha & theta if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-NULL if(hasArg(theta)) theta<-list(...)$theta else theta<-NULL if(!is.null(alpha)&&is.null(theta)){ cat("Warning: alpha but not theta specified in OU model, setting theta to a.\n") theta<-a } ## check for OU w. trend (not permitted) if(!is.null(alpha)&&mu!=0) cat("Warning: OU with a trend not permitted. Trend parameter will be ignored.\n") ## check for OU w. bounds (not permitted) if(!is.null(alpha)&&(bounds[1]!=-Inf||bounds[2]!=Inf)) cat("Warning: OU with bounds not permitted. Bounds will be ignored.\n") ## if BM if(is.null(alpha)) x<-simBM(tree,a,mu,sig2,bounds,internal,nsim) else x<-if(nsim==1) simOU(tree,alpha,sig2,theta,a,internal) else replicate(nsim,simOU(tree,alpha,sig2,theta,a,internal)) x } ## internal function does BM simulation ## written by Liam J. Revell 2011, 2013 simBM<-function(tree,a,mu,sig2,bounds,internal,nsim){ if(bounds[2] bounds[1]. Simulating without bounds.") bounds<-c(-Inf,Inf) } if(bounds[1]==-Inf&&bounds[2]==Inf) no.bounds=TRUE else no.bounds=FALSE if(abounds[2]){ warning("a must be bounds[1] 0. Setting sig2 to 1.0.") sig2=1.0 } # function for reflection off bounds reflect<-function(yy,bounds){ while(yybounds[2]){ if(yybounds[2]) yy<-2*bounds[2]-yy } return(yy) } # how many species? n<-length(tree$tip) # first simulate changes along each branch x<-matrix(data=rnorm(n=length(tree$edge.length)*nsim,mean=rep(mu*tree$edge.length,nsim),sd=rep(sqrt(sig2*tree$edge.length),nsim)),length(tree$edge.length),nsim) # now add them up y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),nsim)) for(i in 1:nrow(x)){ if(tree$edge[i,1]==(n+1)) y[i,1,]<-a else y[i,1,]<-y[match(tree$edge[i,1],tree$edge[,2]),2,] y[i,2,]<-y[i,1,]+x[i,] if(!no.bounds) y[i,2,]<-apply(as.matrix(y[i,2,]),1,function(yy) reflect(yy,bounds)) } rm(x); x<-matrix(data=rbind(y[1,1,],as.matrix(y[,2,])),length(tree$edge.length)+1,nsim) rownames(x)<-c(n+1,tree$edge[,2]) x<-as.matrix(x[as.character(1:(n+tree$Nnode)),]) rownames(x)[1:n]<-tree$tip.label # return simulated data if(internal==TRUE) return(x[1:nrow(x),]) # include internal nodes else return(x[1:length(tree$tip.label),]) # tip nodes only } ## internal function does BM simulation ## written by Liam J. Revell 2013 simOU<-function(tree,alpha,sig2,theta,a0,internal){ tree<-reorder(tree,"cladewise") X<-matrix(0,nrow(tree$edge),ncol(tree$edge)) root<-length(tree$tip.label)+1 X[which(tree$edge[,1]==root),1]<-a0 for(i in 1:nrow(X)){ t<-tree$edge.length[i] s2<-sig2*(1-exp(-2*alpha*t))/(2*alpha) X[i,2]<-exp(-alpha*t)*X[i,1]+(1-exp(-alpha*t))*theta+rnorm(n=1,sd=sqrt(s2)) ii<-which(tree$edge[,1]==tree$edge[i,2]) if(length(ii)>0) X[ii,1]<-X[i,2] } x<-sapply(1:max(tree$edge),function(x,y,tree) y[which(tree$edge==x)[1]],y=X,tree=tree) x<-setNames(x,c(tree$tip.label,1:tree$Nnode+length(tree$tip.label))) if(internal==TRUE) return(x) # include internal nodes else return(x[1:length(tree$tip.label)]) # tip nodes only } phytools/R/exhaustiveMP.R0000644000176200001440000000560712107732706015116 0ustar liggesusers# function does branch & bound or exhaustive MP tree search # uses "phangorn (Schliep 2011) & "ape" (Paradis & Strimmer 2004) # data is a phyDat object; method can be "branch.and.bound" or "exhaustive" # written by Liam J. Revell 2011, 2013 exhaustiveMP<-function(data,tree=NULL,method="branch.and.bound"){ if(method=="branch.and.bound"){ if(length(data)>15) stop("branch and bound only allowed for n<=15") if(is.null(tree)){ if(attr(data,"type")=="DNA"){ print("no input tree; starting with NJ tree") tree<-NJ(dist.dna(as.DNAbin(data))) } else { print("no input tree; using random starting tree") tree<-rtree(n=length(data),tip.label=names(data),br=NULL,rooted=FALSE) } } trees<-branch.and.bound(data,tree) } else if(method=="exhaustive"){ if(length(data)>10) stop("exhaustive search only allowed for n<=10") if(!is.null(tree)) print("starting tree not necessary for exhaustive search") trees<-exhaustive.search(data) } if(length(trees)==1) trees<-trees[[1]] return(trees) } # function performs branch & bound search # written by Liam J. Revell 2011 branch.and.bound<-function(data,tree){ # first, compute the parsimony score on the input tree bound<-parsimony(tree,data) # now pick three species to start ################## this is new and I don't know if it helps if(is.null(tree$edge.length)){ print("starting with 3 species chosen at random") new<-list(stree(n=3,tip.label=sample(tree$tip.label,3))) } else { print("starting with 3 species chosen to maximize distance") mdSp<-names(sort(colSums(cophenetic(tree)),decreasing=TRUE))[1:3] mdSp<-c("Tarsier","Chimp","J.Macaque") print(mdSp) new<-list(stree(n=3,tip.label=mdSp)) } ################## ends here class(new)<-"multiPhylo" added<-new[[1]]$tip.label; remaining<-setdiff(tree$tip.label,added) # branch & bound while(length(remaining)>0){ old<-new; new<-list() new.tip<-sample(remaining,1) pscores<-vector() for(i in 1:length(old)){ temp<-add.everywhere(old[[i]],new.tip) score<-parsimony(temp,data) new<-c(new,temp[score<=bound]) pscores<-c(pscores,score[score<=bound]) } added<-c(added,new.tip) print(paste(length(added),"species added;",length(new),"trees retained",collapse="")) remaining<-setdiff(tree$tip.label,added) } # ok, done, now sort what needs to be returned trees<-new[pscores==min(pscores)] for(i in 1:length(trees)) attr(trees[[i]],"pscore")<-min(pscores) return(trees) # return all mp trees } # function does exhaustive tree search # written by Liam J. Revell 2011 exhaustive.search<-function(data){ all.trees<-allTrees(n=length(data),tip.label=names(data),rooted=FALSE) print(paste("searching",length(all.trees),"trees",collapse="")) all.trees = .uncompressTipLabel(all.trees) pscores<-parsimony(all.trees,data) minscore<-min(pscores); trees<-all.trees[pscores==minscore] for(i in 1:length(trees)) attr(trees[[i]],"pscore")<-min(pscores) return(trees) } phytools/R/ltt95.R0000644000176200001440000000737012562000431013440 0ustar liggesusers# 95% CI on ltts # written by Liam J. Revell 2013, 2014, 2015 ltt95<-function(trees,alpha=0.05,log=FALSE,method=c("lineages","times"),mode=c("median","mean"),...){ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") method<-method[1] mode<-mode[1] if(hasArg(res)) res<-list(...)$res else res<-100 X<-ltt(trees,plot=FALSE,gamma=FALSE) if(method=="times"){ N<-length(X) tt<-sapply(X,function(x) max(x$times)) zz<-max(tt)-tt for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i] n<-sapply(X,function(x) max(x$ltt)) if(all(n==max(n))) n<-max(n) else stop("for method=\"times\" all trees must contain the same numer of lineages") LL<-sapply(X,function(x) x$times[1:length(x$times)]) ii<-floor(alpha/2*N) jj<-ceiling((1-alpha/2)*N) low<-apply(LL,1,function(x) sort(x)[ii]) high<-apply(LL,1,function(x) sort(x)[jj]) ll<-if(mode=="median") apply(LL,1,function(x) median(x)[1]) else rowMeans(LL) obj<-cbind(c(1:n,n),low,ll,high) colnames(obj)<-c("lineages","low(time)","time","high(time)") rownames(obj)<-NULL } else if(method=="lineages"){ N<-length(X) tt<-sapply(X,function(x) max(x$times)) zz<-max(tt)-tt for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i] tt<-0:res*max(tt)/res ll<-low<-high<-vector() for(i in 1:length(tt)){ ss<-vector() for(j in 1:N){ ii<-2 while(tt[i]>X[[j]]$times[ii]&&iij should be given by Q[j,i].\n") if(!all(round(colSums(Q),10)==0)){ if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){ if(message){ cat("Detecting that rows, not columns, of Q sum to zero :\n") cat("Transposing Q for internal calculations.\n") } Q<-t(Q) } else { if(message) cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n") diag(Q)<-0 diag(Q)<--colSums(Q,na.rm=TRUE) } } # does Q have names? if(is.null(dimnames(Q))) dimnames(Q)<-list(1:nrow(Q),1:ncol(Q)) # create "multiPhylo" object mtrees<-vector(mode="list",length=nsim) class(mtrees)<-c("multiSimmap","multiPhylo") ## deal with ancestral state if(is.null(anc)) anc<-setNames(rep(1/ncol(Q),ncol(Q)),colnames(Q)) if(is.character(anc)){ anc<-colSums(to.matrix(anc,colnames(Q))) anc<-anc/sum(anc) } # now loop for(i in 1:nsim){ # set root state a<-rstate(anc) # create the map tree object mtree<-tree mtree$maps<-vector(mode="list",length=nrow(tree$edge)) # now we want to simulate the node states on the tree node.states<-matrix(NA,nrow(tree$edge),ncol(tree$edge)) node.states[which(tree$edge[,1]==(length(tree$tip)+1)),1]<-a for(j in 1:nrow(tree$edge)){ if(tree$edge.length[j]==0){ map<-vector() map[1]<-tree$edge.length[j] names(map)[1]<- node.states[which(tree$edge[,1]==tree$edge[j,2]),1]<- node.states[j,2]<-node.states[j,1] } else { time=0 state<-node.states[j,1] new.state<-state dt<-vector() map<-vector() k<-1 while(timenode.states[j,2]-> node.states[which(tree$edge[,1]==tree$edge[j,2]),1] } mtree$maps[[j]]<-map } # add a couple of elements mtree$node.states<-node.states tip.states<-node.states[tree$edge[,2]<=length(tree$tip),2] tip.states<-tip.states[order(tree$edge[tree$edge[,2]<=length(tree$tip),2])] names(tip.states)<-tree$tip.label mtree$states<-tip.states # now construct the matrix "mapped.edge" (for backward compatibility allstates<-vector() for(j in 1:nrow(mtree$edge)) allstates<-c(allstates,names(mtree$maps[[j]])) allstates<-unique(allstates) mtree$mapped.edge<-matrix(data=0,length(mtree$edge.length), length(allstates),dimnames=list(apply(mtree$edge,1, function(x) paste(x,collapse=",")),state=allstates)) for(j in 1:length(mtree$maps)) for(k in 1:length(mtree$maps[[j]])) mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<- mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]+ mtree$maps[[j]][k] class(mtree)<-c("simmap",setdiff(class(mtree),"simmap")) mtrees[[i]]<-mtree } if(nsim==1) mtrees<-mtrees[[1]] if(message) cat("Done simulation(s).\n") mtrees } ## simulate DNA sequence from a tree & model parameters ## written by Liam J. Revell 2013 genSeq<-function(tree,l=1000,Q=NULL,rate=1,format="DNAbin",...){ if(is.null(Q)){ Q<-matrix(1,4,4) rownames(Q)<-colnames(Q)<-c("a","c","g","t") diag(Q)<-0 diag(Q)<--colSums(Q) } if(length(rate)!=l){ if(length(rate)==1) rate<-rep(rate,l) else { cat("warning: length(rate) & l should match for length(rate)>1\n") cat(" rate will be recycled.\n") rate<-rep(rate,ceiling(l/length(rate)))[1:l] } } cat("simulating sequences....\n") X<-sapply(rate,function(a,b,c) sim.history(b,a*c)$states,b=tree,c=Q) if(format=="DNAbin") return(as.DNAbin(X)) else if(format=="phyDat") return(as.phyDat(X)) else if(format=="matrix") return(X) } phytools/R/evol.vcv.R0000644000176200001440000001512512730064411014223 0ustar liggesusers# this function fits the model of Revell & Collar (2009; Evolution) # written by Liam J. Revell 2010, 2011, 2013, 2014, 2015, 2016 evol.vcv<-function(tree,X,maxit=2000,vars=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") n<-nrow(X) # number of species m<-ncol(X) # number of traits if(hasArg(se)){ se<-list(...)$se se<-se[tree$tip.label] } else { se<-replicate(n,matrix(0,m,m),simplify=FALSE) names(se)<-tree$tip.label } SE<-matrix(0,n*m,n*m) for(i in 1:n){ ii<-0:(m-1)*n+i SE[ii,ii]<-se[[i]] } p<-ncol(tree$mapped.edge) # number of states D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*nmaxLambda(tree)){ message("some of the elements of 'start' are invalid, resetting to random") start<-NULL } } # done error handling if(method=="K"){ C<-vcv.phylo(tree) x<-x[rownames(C)] n<-nrow(C) if(!me){ invC<-solve(C) a<-sum(invC%*%x)/sum(invC) K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invC%*%(x-a)))/((sum(diag(C))-n/sum(invC))/(n-1)) # calculate K if(!test) return(as.numeric(K)) # return K else { P=0.0 simX<-x for(i in 1:nsim){ a<-sum(invC%*%simX)/sum(invC) simK<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invC%*%(simX-a)))/((sum(diag(C))-n/sum(invC))/(n-1)) if(simK>=K) P<-P+1/nsim # calculate P-value for randomization test simX<-sample(simX) # randomize x } return(list(K=as.numeric(K),P=P)) # return K & P } } else { likelihoodK<-function(theta,C,M,y){ Ce<-theta*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%y)/sum(invCe)) logL<--t(y-a)%*%invCe%*%(y-a)/2-n*log(2*pi)/2-determinant(Ce,logarithm=TRUE)$modulus/2 return(logL) } M<-M[rownames(C),colnames(C)] invC<-solve(C) maxSig2<-as.numeric(t(x-as.numeric(sum(invC%*%x)/sum(invC)))%*%invC%*%(x-as.numeric(sum(invC%*%x)/sum(invC)))/n) res<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=x,C=C,M=M,maximum=TRUE) # optimize sig2 sig2<-res$maximum*n/(n-1) Ce<-sig2*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%x)/sum(invCe)) K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invCe%*%(x-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1)) # calculate K if(!test) return(list(K=as.numeric(K),sig2=as.numeric(sig2),logL=res$objective[1,1])) else { P=0.0 simX<-x for(i in 1:nsim){ maxSig2<-as.numeric(t(simX-as.numeric(sum(invC%*%simX)/sum(invC)))%*%invC%*%(simX-as.numeric(sum(invC%*%simX)/sum(invC)))/n) simRes<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=simX,C=C,M=M,maximum=TRUE) # optimize sig2 simSig2<-simRes$maximum*n/(n-1) Ce<-simSig2*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%simX)/sum(invCe)) simK<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invCe%*%(simX-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1)) # calculate K if(simK>=K) P<-P+1/nsim # calculate P-value for randomization test o<-sample(1:n) simX<-x[o]; M<-diag(se[o]^2) # randomize x & errors } return(list(K=as.numeric(K),P=P,sig2=as.numeric(sig2),logL=res$objective[1,1])) # return K & P } } } else if(method=="lambda"){ # function to compute C with lambda lambda.transform<-function(C,lambda){ dC<-diag(diag(C)) C<-lambda*(C-dC)+dC return(C) } # likelihood function likelihoodLambda<-function(theta,C,y){ Cl<-lambda.transform(C,theta) invCl<-solve(Cl) n<-nrow(Cl) y<-y[rownames(Cl)] a<-as.numeric(sum(invCl%*%y)/sum(invCl)) sig2<-as.numeric(t(y-a)%*%invCl%*%(y-a)/n) logL<--t(y-a)%*%(1/sig2*invCl)%*%(y-a)/2-n*log(2*pi)/2-determinant(sig2*Cl,logarithm=TRUE)$modulus/2 return(logL) } # likelihood function with error likelihoodLambda.me<-function(theta,C,y,M){ Cl<-theta[1]*lambda.transform(C,theta[2]) V<-Cl+M invV<-solve(V) n<-nrow(Cl) y<-y[rownames(Cl)] a<-as.numeric(sum(invV%*%y)/sum(invV)) logL<--t(y-a)%*%invV%*%(y-a)/2-n*log(2*pi)/2-determinant(V,logarithm=TRUE)$modulus/2 return(-logL) } C<-vcv.phylo(tree) x<-x[rownames(C)] maxlam<-maxLambda(tree) if(!me){ res<-optimize(f=likelihoodLambda,interval=c(0,maxlam),y=x,C=C,maximum=TRUE) # optimize lambda if(!test) return(list(lambda=res$maximum,logL=res$objective[1,1])) # return lambda and log-likelihood else { logL0<-likelihoodLambda(theta=0,C=C,y=x) # compute likelihood of lambda=0 P<-as.numeric(pchisq(2*(res$objective[1,1]-logL0),df=1,lower.tail=FALSE)) # P-value return(list(lambda=res$maximum,logL=res$objective[1,1],logL0=logL0[1,1],P=P)) # return lambda, logL, and P-value } } else { M<-M[rownames(C),colnames(C)] if(is.null(start)) s<-c(0.02*runif(n=1)*mean(pic(x,multi2di(tree))^2),runif(n=1)) else s<-start res<-optim(s,likelihoodLambda.me,C=C,y=x,M=M,method="L-BFGS-B",lower=c(0,0),upper=c(Inf,maxlam),control=control) if(!test) return(list(lambda=res$par[2],sig2=res$par[1],logL=-res$value,convergence=res$convergence,message=res$message)) else { res0<-optim(c(s[1],0),likelihoodLambda.me,C=C,y=x,M=M,method="L-BFGS-B",lower=c(0,0),upper=c(Inf,1e-10),control=control) P<-as.numeric(pchisq(2*(res0$value-res$value),df=1,lower.tail=FALSE)) return(list(lambda=res$par[2],sig2=res$par[1],logL=-res$value,convergence=res$convergence,message=res$message,logL0=-res0$value,P=P)) } } } else stop(paste("do not recognize method = \"",method,"\"; methods are \"K\" and \"lambda\"",sep="")) } phytools/R/map.to.singleton.R0000644000176200001440000001203113061612026015650 0ustar liggesusers## convert stochastic map style tree to a tree with singleton nodes ## written by Liam J. Revell 2013, 2015 map.to.singleton<-function(tree){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") tree<-reorderSimmap(tree) Nedge<-nrow(tree$edge)+sum(sapply(tree$maps,length)-1) Ntips<-length(tree$tip.label) edge<-tree$edge edge[edge>Ntips]<--edge[edge>Ntips]+Ntips xx<-vector(); edge.length<-vector(); ii<-1 for(i in 1:nrow(tree$edge)){ if(length(tree$maps[[i]])==1){ xx[ii]<-names(tree$maps[[i]]) edge.length[ii]<-tree$maps[[i]] ii<-ii+1 } else { nn<-length(tree$maps[[i]]) new<-matrix(NA,nn,2) new[1,1]<-edge[ii,1] nextnode<--1+if(i>1) min(c(edge[1:(ii-1),],edge[ii,1])) else edge[ii,1] new[,2]<-nextnode-0:(nn-1) for(j in 2:nn) new[j,1]<-new[j-1,2] if(edge[ii,2]>0) new[nrow(new),2]<-edge[ii,2] if(i==nrow(tree$edge)) edge<-rbind(edge[1:(ii-1),],new) else { ee<-edge[(ii+1):nrow(edge),] ee[ee1) lines(xx,yy,lwd=2,lend=2,col=colors[which(cw$edge[,1]==i)]) } # plot points for(i in 1:nrow(X)) points(X[i,],rep(y[cw$edge[i,2]],2),pch=21,bg="gray") # plot tip labels for(i in 1:n) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=0.3) PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=TRUE,show.node.label=FALSE, font=par()$font,cex=par()$cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.3, x.lim=xlim,y.lim=c(1,max(y)), direction="rightward",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## function to reorder the edges of the tree for postorder traversal should *only* be used internally to ## plotTree.singletons (i.e., is not designed for general use). ## written by Liam J. Revell 2013 reorderPhylo<-function(x,order="pruningwise",index.only=FALSE,...){ if(index.only) stop("index.only=TRUE not permitted") if(order!="pruningwise") stop("function only returns trees in modified pruningwise format for plotTree.singletons") if(attr(x,"order")!="cladewise") stop("input tree should be in cladewise order.") aa<-lapply(x$edge[,1],getDescendants,tree=x) ll<-sapply(aa,length) ii<-order(ll) x$edge<-x$edge[ii,] x$edge.length<-x$edge.length[ii] attr(x,"order")<-"pruningwise" return(x) } ## function converts a tree with a root edge to a tree with a singleton node instead ## written by Liam J. Revell 2016 rootedge.to.singleton<-function(tree){ cw<-reorder(tree,"cladewise") root.edge<-if(!is.null(cw$root.edge)) cw$root.edge else 0 cw$edge[which(cw$edge>Ntip(cw))]<-cw$edge[which(cw$edge>Ntip(cw))]+1 cw$edge<-rbind(Ntip(cw)+c(1,2),cw$edge) cw$Nnode<-cw$Nnode+1 cw$edge.length<-c(root.edge,cw$edge.length) cw } phytools/R/threshBayes.R0000644000176200001440000001661413201127126014743 0ustar liggesusers## Function fits the threshold model for two characters using Bayesian MCMC. ## All characters should be provided either in the form of a numeric matrix, X, or as ## a data frame in which the discrete character is coded as a factor ## Row names of X should match the species names of the tree. ## types=c("discrete","discrete"), c("discrete","continuous"), c("cont","disc") etc. should ## be used to indicate the data type of each column in X ## written by Liam J. Revell 2012, 2014, 2017 threshBayes<-function(tree,X,types=NULL,ngen=10000,control=list(),...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-round(0.2*ngen) if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # likelihood function for the liabilities lik<-function(a,V,invV,detV,D,Y){ y<-as.vector(Y) logL<--t(y-D%*%a)%*%invV%*%(y-D%*%a)/2-n*m*log(2*pi)/2-detV/2 return(logL) } # function for the log-prior (presently returns 0, i.e. a flat prior) logPrior<-function(sig2,a,r,Yp){ pp<-dexp(sig2[1],rate=1/con$pr.mean[1],log=T)+ dexp(sig2[2],rate=1/con$pr.mean[2],log=T)+ dnorm(a[1],mean=con$pr.mean[3],sd=sqrt(con$pr.var[3]),log=T)+ dnorm(a[2],mean=con$pr.mean[4],sd=sqrt(con$pr.var[4]),log=T)+ dunif(r,min=con$pr.mean[5]-0.5*sqrt(12*con$pr.var[5]), max=con$pr.mean[5]+0.5*sqrt(12*con$pr.var[5]),log=T) return(pp) } # function to crop the first 4 characters from a vector of strings crop<-function(x){ for(i in 1:length(x)) x[i]<-paste(strsplit(x[i],"")[[1]][1:4],collapse="") return(x) } ## bookkeeping C<-vcv.phylo(tree) n<-nrow(X) m<-ncol(X) if(is.null(types)){ types<-rep("cont",m) if(is.data.frame(X)){ ii<-which(sapply(X,is.factor)) if(length(ii)>0) types[ii]<-"disc" } else if(is.matrix(X)){ ii<-which(apply(X,2,function(x) all(x%in%c(0,1)))) if(length(ii)>0) types[ii]<-"disc" } } X<-X[tree$tip.label,] levels<-as.list(rep(NA,m)) if(is.data.frame(X)){ ii<-sapply(X,is.character) if(any(ii)) X[,ii]<-sapply(X[,ii],as.factor) ii<-sapply(X,is.factor) if(any(ii)){ d<-which(ii) for(i in 1:length(d)) levels[[d[i]]]<-levels(X[,d[i]]) X[,ii]<-sapply(X[,ii],as.numeric)-1 } X<-as.matrix(X) } else { d<-which(crop(types)=="disc") for(i in 1:length(d)) levels[[d[i]]]<-as.character(0:1) } if(m!=2) stop("number of traits must equal 2") npar<-n*m+5 # or npar<-n*m+1 # design matrix D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n0]<-1 Vp<-V invVp<-invV detVp<-detV # for storing the posterior sample Z<-matrix(NA,ngen/con$sample+1,7,dimnames=list(NULL,c("gen","sig1","sig2", "a1","a2","r","logL"))) Z[1,]<-c(0,sig2,a,r,lik(a,V,invV,detV,D,Y)) L<-matrix(NA,ngen/con$sample+1,m*length(tree$tip)+1,dimnames=list(NULL,c("gen", as.vector(apply(matrix(colnames(Y)),1,paste,".",tree$tip.label,sep=""))))) L[1,]<-c(0,as.vector(Y)) # start MCMC cat("Starting MCMC....\n") for(i in 1:ngen){ lik1<-lik(a,V,invV,detV,D,Y)+log(all(P[,disc]==X[,disc])) d<-i%%npar if(ngen>=1000) if(i%%1000==0) if(!con$quiet) cat(paste("gen ",i,"\n",sep="")) Yp<-Y sig2p<-sig2 ap<-a rp<-r if(d<=length(Y[,disc])&&d>0){ # update liabilities ind<-c(d%%n,disc[ceiling(d/n)]) if(ind[1]==0) ind[1]<-n Yp[ind[1],ind[2]]<-Y[ind[1],ind[2]]+rnorm(n=1,sd=sqrt(con$propliab)) } else { if((d-length(Y[,disc]))==1||(d-length(Y[,disc]))==2){ # update sig2 if(!((d-length(Y[,disc]))%in%disc)){ j<-d-length(Y[,disc]) sig2p[j]<-sig2[j]+rnorm(n=1,sd=sqrt(con$propvar[j])) if(sig2p[j]<0) sig2p[j]=-sig2p[j] R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]), rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2) Vp<-kronecker(R,C) invVp<-solve(Vp) detVp<-determinant(Vp)$modulus[1] } } else if((d-length(Y[,disc]))==3||(d-length(Y[,disc]))==4){ # update a j<-d-length(Y[,disc]) ap[j-2]<-a[j-2]+rnorm(n=1,sd=sqrt(con$propvar[j])) } else if(d==0) { # update r rp<-r+rnorm(n=1,sd=sqrt(con$propvar[5])) while(rp>1||rp< -1){ if(rp>1) rp<-2-rp if(rp< -1) rp<--2-rp } R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]), rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2) Vp<-kronecker(R,C) invVp<-solve(Vp) detVp<-determinant(Vp)$modulus[1] } } Pp[Yp<0]<-0 Pp[Yp>0]<-1 lik2<-lik(ap,Vp,invVp,detVp,D,Yp)+log(all(Pp[,disc]==X[,disc])) p.odds<-min(c(1,exp(lik2+logPrior(sig2p,ap,rp,Yp)-lik1- logPrior(sig2,a,r,Yp)))) if(p.odds>runif(n=1)){ Y<-Yp sig2<-sig2p a<-ap r<-rp V<-Vp invV<-invVp detV<-detVp logL<-lik2 } else logL<-lik1 if(i%%con$sample==0){ Z[i/con$sample+1,]<-c(i,sig2,a,r,logL) L[i/con$sample+1,]<-c(i,Y[,1],Y[,2]) } } cat("Done MCMC.\n") obj<-list(par=as.data.frame(Z),liab=as.data.frame(L), burnin=burnin,levels=levels,types=types) class(obj)<-"threshBayes" obj } ## S3 methods for the object class print.threshBayes<-function(x,...){ cat("\nObject of class \"threshBayes\" consisting of a matrix (L) of\n") cat("sampled liabilities for the tips of the tree & a second matrix\n") cat("(par) with the sample model parameters & correlation.\n") cat(paste("\nMean correlation (r) from the posterior sample is: ", round(mean(x$par[,"r"]),5),".\n",sep="")) if(any(x$types=="disc")){ cat("\nOrdination of discrete traits:\n\n") for(i in 1:length(x$types)){ if(x$types[i]=="disc") cat(paste("\tTrait ",i,": ",x$levels[[i]][1]," <-> ", x$levels[[i]][2],"\n",sep="")) } } cat("\n") } plot.threshBayes<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-x$burnin if(hasArg(bw)) bw<-list(...)$bw else bw<-0.05 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-1,1) ii<-which(((x$par$gen-burnin)^2)==min((x$par$gen-burnin)^2))[1]+1 d<-density(x$par$r[ii:nrow(x$par)],bw=bw) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0,1.2*max(d$y)) plot(d,xlim=xlim,ylim=ylim,col="blue",xlab="Posterior sample of r", ylab="Density",main="") polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0), col=make.transparent("blue",0.2)) r<-mean(x$par$r[ii:nrow(x$par)]) lines(rep(r,2),c(0,par()$usr[4]),col="blue",lty="dashed", lwd=2) text(r,0.95*par()$usr[4],"mean post-burnin\nvalue of r",cex=0.7, pos=if(r>0) 2 else 4) }phytools/R/fitDiversityModel.R0000644000176200001440000000777512561716036016154 0ustar liggesusers# this function fits a "diversity-dependent-evolutionary-diversification" model (similar to Mahler et al. 2010) # written by Liam Revell, 2010/2011/2012 fitDiversityModel<-function(tree,x,d=NULL,showTree=TRUE,tol=1e-6){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)) x<-x[,1] if(is.null(names(x))){ if(length(x)==length(tree$tip)){ message("x has no names; assuming x is in the same order as tree$tip.label") names(x)<-tree$tip.label } else stop("x has no names and is a different length than tree$tip.label") } if(any(is.na(match(tree$tip.label,names(x))))){ message("some species in tree are missing from data, dropping missing taxa from the tree") tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)]) } if(any(is.na(match(names(x),tree$tip.label)))){ message("some species in data are missing from tree, dropping missing taxa from the data") x<-x[tree$tip.label] } if(any(is.na(x))){ message("some data given as 'NA', dropping corresponding species from tree") tree<-drop.tip(tree,names(which(is.na(x)))) } if(!is.null(d)){ if(is.data.frame(d)) d<-as.matrix(d) if(is.matrix(d)) d<-d[,1] if(is.null(names(d))){ if(length(d)==tree$Nnode){ message("d has no names; assuming d is in node number order of the resolved tree") names(d)<-c(length(tree$tip)+tol:tree$Nnode) } else stop("d has no names and is a different length than tree$Nnode for the resolved tree") } } else { message("no values for lineage density provided; computing assuming single biogeographic region") # compute lineage diversity at each node ages<-branching.times(tree) d<-vector() for(i in 1:length(ages)) d[i]<-sum(ages>ages[i]) names(d)<-names(ages) } maxd<-max(d) d<-d/(maxd+tol) # likelihood function lik<-function(theta,y,phy,diversity){ scaled.psi<-theta for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi+vi*scaled.psi*diversity[as.character(phy$edge[i,1])] } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D)) Dinv<-Dinv/sig0; D<-D*sig0 logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-determinant(D)$modulus[1]/2-length(y)*log(2*pi)/2) if(showTree) plot(phy) return(logL) } # optimize res<-optimize(lik,c(-1,1),y=x,phy=tree,diversity=d,maximum=TRUE) # compute condition sig0 compute_sig0<-function(scaled.psi,y,phy,diversity){ for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi+vi*scaled.psi*diversity[as.character(phy$edge[i,1])] } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D)) return(sig0) } sig0=compute_sig0(res$maximum,x,tree,d) # compute the Hessian compute_Hessian<-function(scaled.psi,sig0,y,phy,d,maxd){ psi<-scaled.psi*sig0/(maxd+tol) likHessian<-function(theta,y,phy,d,maxd){ sig0<-theta[1] psi<-theta[2] for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi*(sig0+psi*d[as.character(phy$edge[i,1])]*(maxd+tol)) } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-determinant(D)$modulus[1]/2-length(y)*log(2*pi)/2) return(logL) } H<-hessian(likHessian,c(sig0,psi),y=y,phy=phy,d=d,maxd=maxd) return(H) } H<-compute_Hessian(res$maximum,sig0,x,tree,d,maxd) # return results to user if(var(d)>0) return(list(logL=res$objective,sig0=sig0,psi=sig0*res$maximum/(maxd+tol),vcv=matrix(solve(-H),2,2,dimnames=list(c("sig0","psi"),c("sig0","psi"))))) else { message("psi not estimable because diversity is constant through time.") return(list(logL=res$objective,sig0=sig0,vcv=matrix(-1/H[1,1],1,1,dimnames=list(c("sig0"),c("sig0"))))) } } phytools/R/fitPagel.R0000644000176200001440000002520612722715737014234 0ustar liggesusers## function fits Pagel '94 model of correlated evolution of two binary characters ## uses fitMk, ape::ace, or geiger::fitDiscrete internally ## written by Liam J. Revell 2014, 2015, 2016 fitPagel<-function(tree,x,y,method="fitMk",model="ARD",dep.var="xy",...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(dep.var%in%c("x","y","xy")==FALSE){ cat(" Invalid option for argument \"dep.var\".\n") cat(" Setting dep.var=\"xy\" (x depends on y & vice versa)\n\n") dep.var<-"xy" } if(model%in%c("ER","SYM","ARD")==FALSE){ cat(" Invalid model. Setting model=\"ARD\"\n\n") model<-"ARD" } if(method=="fitDiscrete"){ chk<-.check.pkg("geiger") if(!chk){ cat(" method = \"fitDiscrete\" requires the package \"geiger\"\n") cat(" Defaulting to method = \"fitMk\"\n\n") method<-"fitMk" fitDiscrete<-function(...) NULL } } if(method%in%c("fitDiscrete","ace","fitMk")==FALSE){ cat(paste(" method = \"",method,"\" not found.\n",sep="")) cat(" Defaulting to method = \"fitMk\"\n\n") method<-"fitMk" } if(!is.factor(x)) x<-as.factor(x) levels.x<-levels(x) if(!is.factor(y)) y<-as.factor(y) levels.y<-levels(y) y<-y[names(x)] if(length(levels.x)!=2||length(levels.y)!=2) stop("Only binary characters for x & y currently permitted.") xy<-setNames(factor(paste(x,y,sep="|"), levels=sapply(levels.x,paste,levels.y,sep="|")), names(x)) ## fit independent dep.var iQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,1,0,4,3,0),4,4,byrow=TRUE) if(model%in%c("ER","SYM")) iQ<-make.sym(iQ) k.iQ<-length(unique(as.vector(iQ)))-1 rownames(iQ)<-colnames(iQ)<-levels(xy) fit.iQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=iQ,...) else if(method=="ace") ace(xy,tree,type="discrete",model=iQ,...) else fitMk(tree,to.matrix(xy,levels(xy)),model=iQ,...) ## fit dependendent model if(dep.var=="xy") dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,6,0,7,8,0),4,4,byrow=TRUE) else if(dep.var=="x") dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,1,0,6,3,0),4,4,byrow=TRUE) else if(dep.var=="y") dQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,5,0,4,6,0),4,4,byrow=TRUE) if(model%in%c("ER","SYM")) dQ<-make.sym(dQ) k.dQ<-length(unique(as.vector(dQ)))-1 rownames(dQ)<-colnames(dQ)<-levels(xy) fit.dQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=dQ,...) else if(method=="ace") ace(xy,tree,type="discrete",model=dQ,...) else fitMk(tree,to.matrix(xy,levels(xy)),model=dQ,...) ## back translate independent model if(method=="fitDiscrete") iQ<-.Qmatrix.from.gfit(fit.iQ) else { I<-fit.iQ$index.matrix I[I==0]<-NA iQ<-apply(I,2,function(i,x) x[i],x=fit.iQ$rates) iQ[is.na(iQ)]<-0 diag(iQ)<--rowSums(iQ) rownames(iQ)<-colnames(iQ) } ## dependent model if(method=="fitDiscrete") dQ<-.Qmatrix.from.gfit(fit.dQ) else { I<-fit.dQ$index.matrix I[I==0]<-NA dQ<-apply(I,2,function(i,x) x[i],x=fit.dQ$rates) dQ[is.na(dQ)]<-0 diag(dQ)<--rowSums(dQ) rownames(dQ)<-colnames(dQ) } ## assemble object to return obj<-list(independent.Q=iQ, dependent.Q=dQ, independent.logL=logLik(fit.iQ), dependent.logL=logLik(fit.dQ), independent.AIC=2*k.iQ-2*logLik(fit.iQ), dependent.AIC=2*k.dQ-2*logLik(fit.dQ), lik.ratio=2*(logLik(fit.dQ)-logLik(fit.iQ)), P=pchisq(2*(logLik(fit.dQ)-logLik(fit.iQ)), df=k.dQ-k.iQ, lower.tail=FALSE), method=method, dep.var=dep.var, model=model) class(obj)<-"fitPagel" obj } ## print method for objects of class "fitPagel" ## written by Liam J. Revell 2014, 2016 print.fitPagel<-function(x,...){ cat("\nPagel's binary character correlation test:\n") cat(paste("\nAssumes \"",x$model, "\" substitution model for both characters\n",sep="")) cat("\nIndependent model rate matrix:\n") print(x$independent.Q) tmp<-if(x$dep.var=="xy") "x & y" else if(x$dep.var=="x") "x only" else if(x$dep.var=="y") "y only" cat(paste("\nDependent (",tmp,") model rate matrix:\n",sep="")) print(x$dependent.Q) cat("\nModel fit:\n") obj<-matrix(c(x$independent.logL,x$dependent.logL, x$independent.AIC,x$dependent.AIC),2,2) rownames(obj)<-c("independent","dependent") colnames(obj)<-c("log-likelihood","AIC") print(obj) cat("\nHypothesis test result:\n") cat(paste(" likelihood-ratio: ",signif(x$lik.ratio,7),"\n")) cat(paste(" p-value: ",signif(x$P,7),"\n")) cat(paste("\nModel fitting method used was",x$method,"\n\n")) } ## function borrowed from geiger to pull the Q-matrix from a fit returned by ## fitDiscrete .Qmatrix.from.gfit<-function(x){ if(!.check.pkg("geiger")) argn<-function(...) NULL lik=x$lik numberize=function(x){ y=gsub("q","",x) sp=(nn<-nchar(y))/2 as.numeric(c(substring(y,1,sp),substring(y,sp+1, nn))) } att=attributes(lik) att$k=length(att$levels) Qmat=matrix(0,att$k,att$k) nms=att$argn[att$trns] other=att$argn[!att$trns] if("constrained"%in%class(lik)){ cpars=x$opt[argn(lik)] apars=names(lik(unlist(cpars),pars.only=TRUE)) nms=apars[!apars%in%other] } trns=x$opt[nms] for(i in 1:length(trns)){ nm=names(trns)[i] idx=numberize(nm) Qmat[idx[1],idx[2]]=trns[[i]] } diag(Qmat)=-rowSums(Qmat) rownames(Qmat)<-colnames(Qmat)<-levels(lik) Qmat } ## make the model matrix symmetric make.sym<-function(X){ for(i in 1:nrow(X)) for(j in i:nrow(X)) X[j,i]<-X[i,j] X } ## S3 plot method for objects of class "fitPagel ## written by Liam J. Revell 2016 plot.fitPagel<-function(x,...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-3 if(hasArg(main)) main<-list(...)$main else main<-NULL if(!is.null(main)&&length(main)==1) main<-rep(main,2) if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.sub)) cex.sub<-list(...)$cex.sub else cex.sub<-1 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-0.9 if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates else cex.rates<-0.8 if(hasArg(lwd.by.rate)) lwd.by.rate<-list(...)$lwd.by.rate else lwd.by.rate<-FALSE if(lwd.by.rate){ rates<-c(x$independent.Q[x$independent.Q>0],x$dependent.Q[x$dependent.Q>0]) LWD.ind<-round(x$independent.Q/min(rates)) LWD.dep<-round(x$dependent.Q/min(rates)) if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd else max.lwd<-10 LWD.ind[LWD.ind>max.lwd]<-max.lwd LWD.dep[LWD.dep>max.lwd]<-max.lwd } else LWD.ind<-LWD.dep<-matrix(2,nrow(x$dependent.Q), ncol(x$dependent.Q)) par(mfrow=c(2,1)) ## INDEPENDENT MODEL plot.new() par(mar=c(1.1,2.1,3.1,2.1)) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[1] else "a) Independent model", side=3,adj=0,line=1.2,cex=cex.main) ## trait 1 text(x=0.15,y=1,"Trait 1:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.ind[3,1],1), lty=if(LWD.ind[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.ind[1,3],1), lty=if(LWD.ind[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=0.525,y=0.95,namesplit(rownames(x$dependent.Q)[1])[1], cex=cex.traits) text(x=0.525,y=0.05,namesplit(rownames(x$dependent.Q)[3])[1], cex=cex.traits) text(x=0.60,y=0.5,round(x$independent.Q[1,3],signif),cex=cex.rates,srt=90) text(x=0.45,y=0.5,round(x$independent.Q[3,1],signif),cex=cex.rates,srt=90) ## trait 2 text(x=1.3,y=1,"Trait 2:",cex=cex.sub) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.ind[2,1],1), lty=if(LWD.ind[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.70,y0=0.85,x1=1.70,y1=0.15, lwd=max(LWD.ind[1,2],1), lty=if(LWD.ind[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=1.675,y=0.95,namesplit(rownames(x$dependent.Q)[1])[2], cex=cex.traits) text(x=1.675,y=0.05,namesplit(rownames(x$dependent.Q)[2])[2], cex=cex.traits) text(x=1.75,y=0.5,round(x$independent.Q[1,2],signif),cex=cex.rates,srt=90) text(x=1.60,y=0.5,round(x$independent.Q[2,1],signif),cex=cex.rates,srt=90) ## DEPENDENT MODEL collapse<- if(any(sapply(strsplit(rownames(x$dependent.Q),""),length)>6)) ",\n" else ", " plot.new() par(mar=c(1.1,2.1,3.1,2.1)) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[2] else "b) Dependent model", side=3,adj=0,line=1.2,cex=cex.main) text(x=0.15,y=0.95,"Trait 1,\nTrait 2:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.dep[3,1],1), lty=if(LWD.dep[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.dep[1,3],1), lty=if(LWD.dep[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.05,x1=0.75,y1=0.05, lwd=max(LWD.dep[4,3],1), lty=if(LWD.dep[4,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.1,x1=1.45,y1=0.1, lwd=max(LWD.dep[3,4],1), lty=if(LWD.dep[3,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.dep[4,2],1), lty=if(LWD.dep[4,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.7,y0=0.85,x1=1.7,y1=0.15, lwd=max(LWD.dep[2,4],1), lty=if(LWD.dep[2,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.9,x1=0.75,y1=0.9, lwd=max(LWD.dep[2,1],1), lty=if(LWD.dep[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.95,x1=1.45,y1=0.95, lwd=max(LWD.dep[1,2],1), lty=if(LWD.dep[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) ## add states text(x=0.525,y=0.95, paste(namesplit(rownames(x$dependent.Q)[1]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.95, paste(namesplit(rownames(x$dependent.Q)[2]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.05, paste(namesplit(rownames(x$dependent.Q)[4]), collapse=collapse),cex=cex.traits) text(x=0.525,y=0.05, paste(namesplit(rownames(x$dependent.Q)[3]), collapse=collapse),cex=cex.traits) ## add rates text(x=1.1,y=1,round(x$dependent.Q[1,2],signif), cex=cex.rates) text(x=1.1,y=0.85,round(x$dependent.Q[2,1],signif), cex=cex.rates) text(x=1.6,y=0.5,round(x$dependent.Q[4,2],signif), cex=cex.rates,srt=90) text(x=1.75,y=0.5,round(x$dependent.Q[2,4],signif), cex=cex.rates,srt=90) text(x=1.1,y=0,round(x$dependent.Q[4,3],signif), cex=cex.rates) text(x=1.1,y=0.15,round(x$dependent.Q[3,4],signif), cex=cex.rates) text(x=0.45,y=0.5,round(x$dependent.Q[3,1],signif), cex=cex.rates,srt=90) text(x=0.6,y=0.5,round(x$dependent.Q[1,3],signif), cex=cex.rates,srt=90) } namesplit<-function(x){ tmp<-strsplit(x,"")[[1]] ii<-which(tmp=="|") c(paste(tmp[1:(ii-1)],collapse=""), paste(tmp[(ii+1):length(tmp)],collapse="")) }phytools/R/treeSlice.R0000644000176200001440000000567313072304210014401 0ustar liggesusers## function slices a tree at slice and returns all subtrees ## it uses extract.clade(), if trivial==FALSE subtrees with length than 2 taxa are ignored ## for orientation="rootwards" it will return the tree rootward of the slice point ## written by Liam J. Revell 2011, 2012, 2015, 2017 treeSlice<-function(tree,slice=NULL,trivial=FALSE,prompt=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(orientation)) orientation<-list(...)$orientation else orientation<-"tipwards" if(prompt){ cat("Inside prompt.\n") plotTree(tree,mar=c(3.1,rep(0.1,3)),...) axis(1) cat("Click at the tree height where cutting is desired...\n") flush.console() xy<-unlist(locator(1)) slice<-xy[1] cat(paste("Slice height is ",signif(slice,6),". Thank you!\n",sep="")) flush.console() lines(rep(slice,2),par()$usr[3:4],lty="dashed") obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) X<-cbind(obj$xx[obj$edge[,1]],obj$xx[obj$edge[,2]]) y<-obj$yy[obj$edge[,2]] if(trivial){ for(i in 1:nrow(X)) if(X[i,1]slice) points(slice,y[i],pch=19) } else { for(i in 1:nrow(X)) if(X[i,1]slice&&obj$edge[i,2]>Ntip(tree)) points(slice,y[i],pch=19) } } tree<-reorder(tree) # reorder cladewise H<-nodeHeights(tree) edges<-which(H[,2]>slice&H[,1]length(tree$tip)] trees<-list() class(trees)<-"multiPhylo" for(i in 1:length(nodes)){ if(nodes[i]>Ntip(tree)){ trees[[i]]<-extract.clade(tree,node=nodes[i]) trees[[i]]$root.edge<-H[which(tree$edge[,2]==nodes[i]),2]-slice } else { z<-list(edge=matrix(c(2,1),1,2), edge.length=H[which(tree$edge[,2]==nodes[i]),2]-slice, tip.label=tree$tip.label[nodes[i]],Nnode=1L) class(z)<-"phylo" trees[[i]]<-z } } return(trees) } else if(orientation=="rootwards"){ obj<-tree obj$node.label<-1:obj$Nnode+Ntip(obj) if(any(nodes<=Ntip(obj))){ tips<-nodes[nodes<=Ntip(obj)] tips<-obj$tip.label[tips] nodes<-nodes[nodes>Ntip(obj)] } else tips<-NULL if(length(nodes)>0){ for(i in 1:length(nodes)){ nn<-which(obj$node.label==nodes[i])+Ntip(obj) parent<-getParent(obj,nn) bp<-slice-nodeheight(obj,parent) obj<-splitTree(obj,list(node=nn,bp=bp))[[1]] obj$tip.label[obj$tip.label=="NA"]<-nodes[i] } } if(!is.null(tips[1])){ for(i in 1:length(tips)){ nn<-which(obj$tip.label==tips[i]) parent<-getParent(obj,nn) obj$edge.length[which(obj$edge[,2]==nn)]<-slice-nodeheight(obj,parent) } } return(obj) } } ## function returns the parent of node or NULL if node is the root getParent<-function(tree,node){ ind<-which(tree$edge[,2]==node) if(length(ind)>0) pp<-tree$edge[which(tree$edge[,2]==node),1] else { pp<-NULL cat("node is the root. returning NULL\n") } pp } phytools/R/phylomorphospace3d.R0000644000176200001440000000703313027776666016331 0ustar liggesusers## phylomorphospace3d: projection of a tree into three dimensional morphospace ## written by Liam J. Revell 2012, 2013, 2014, 2016 phylomorphospace3d<-function(tree,X,A=NULL,label=TRUE,control=list(),method=c("dynamic","static"),...){ method<-method[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # control list con=list(spin=TRUE,axes=TRUE,box=TRUE,simple.axes=FALSE,lwd=1,ftype="reg", col.edge=rep("black",nrow(tree$edge))) con[(namc<-names(control))]<-control if(con$simple.axes) con$box<-con$axes<-FALSE con$ftype<-which(c("off","reg","b","i","bi")==con$ftype)-1 if(is.null(A)) A<-apply(X,2,function(x,tree) fastAnc(tree,x),tree=tree) else A<-A[as.character(1:tree$Nnode+length(tree$tip)),] x<-y<-z<-matrix(NA,nrow(tree$edge),2) X<-X[tree$tip.label,] for(i in 1:length(tree$tip)){ x[tree$edge[,2]==i,2]<-X[i,1] y[tree$edge[,2]==i,2]<-X[i,2] z[tree$edge[,2]==i,2]<-X[i,3] } for(i in length(tree$tip)+1:tree$Nnode){ x[tree$edge[,1]==i,1]<-x[tree$edge[,2]==i,2]<-A[as.character(i),1] y[tree$edge[,1]==i,1]<-y[tree$edge[,2]==i,2]<-A[as.character(i),2] z[tree$edge[,1]==i,1]<-z[tree$edge[,2]==i,2]<-A[as.character(i),3] } if(is.null(colnames(X))) colnames(X)<-c("x","y","z") if(method=="dynamic"){ chk<-.check.pkg("rgl") if(!chk){ cat(" method = \"dynamic\" requires the package \"rgl\"\n Defaulting to method = \"static\"\n\n") method<-"static" lines3d<-play3d<-plot3d<-segments3d<-spheres3d<-spin3d<-text3d<-function(...) NULL } } if(method=="dynamic"){ params<-get("r3dDefaults") plot3d(rbind(X,A),xlab=colnames(X)[1],ylab=colnames(X)[2],zlab=colnames(X)[3], axes=con$axes,box=con$box,params=params) spheres3d(X,radius=0.02*mean(apply(X,2,max)-apply(X,2,min))) for(i in 1:nrow(tree$edge)) segments3d(x[i,],y[i,],z[i,],lwd=con$lwd, col=con$col.edge[i]) ms<-colMeans(X) rs<-apply(rbind(X,A),2,range) if(con$simple.axes){ lines3d(x=rs[,1],y=c(rs[1,2],rs[1,2]),z=c(rs[1,3],rs[1,3])) lines3d(x=c(rs[1,1],rs[1,1]),y=rs[,2],z=c(rs[1,3],rs[1,3])) lines3d(x=c(rs[1,1],rs[1,1]),y=c(rs[1,2],rs[1,2]),z=rs[,3]) } rs<-rs[2,]-rs[1,] for(i in 1:length(tree$tip)){ adj<-0.03*rs*(2*(X[i,]>ms)-1) if(con$ftype) text3d(X[i,]+adj,texts=tree$tip.label[i],font=con$ftype) } if(con$spin){ xx<-spin3d(axis=c(0,0,1),rpm=10) play3d(xx,duration=5) invisible(xx) } else invisible(NULL) } else if(method=="static"){ if(hasArg(angle)) angle<-list(...)$angle else angle<-30 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(zlim)) zlim<-list(...)$zlim else zlim=NULL xx<-scatterplot3d(X,xlab=colnames(X)[1],zlab=colnames(X)[3],pch=19,angle=angle, ylab=colnames(X)[2],asp=1,cex.symbols=1.3,xlim=xlim,ylim=ylim,zlim=zlim) aa<-xx$xyz.convert(A) points(aa$x,aa$y,pch=19,cex=0.8) for(i in 1:nrow(tree$edge)){ aa<-xx$xyz.convert(x[i,],y[i,],z[i,]) lines(aa$x,aa$y,lwd=2,col=con$col.edge[i]) } for(i in 1:length(tree$tip.label)){ aa<-xx$xyz.convert(x[which(tree$edge[,2]==i),2],y[which(tree$edge[,2]==i),2], z[which(tree$edge[,2]==i),2]) if(con$ftype) text(tree$tip.label[i],x=aa$x,y=aa$y,pos=2,font=con$ftype) } invisible(xx) } } ## check for a package (modified from 'geiger') ## primarily used for rgl ## written by Liam J. Revell 2014 .check.pkg<-function(pkg){ if(pkg%in%rownames(installed.packages())){ require(pkg,character.only=TRUE) return(TRUE) } else return(FALSE) } phytools/R/evolvcv.lite.R0000644000176200001440000001452313072507741015112 0ustar liggesusers# function is simplified version of evol.vcv # written by Liam J. Revell 2011, 2012, 2013, 2017 evolvcv.lite<-function(tree,X,maxit=2000,tol=1e-10){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # model 1: common variances & correlation lik1<-function(theta,C,D,y){ v<-theta[1:2]; r<-theta[3] R<-matrix(c(v[1],r*sqrt(v[1]*v[2]),r*sqrt(v[1]*v[2]),v[2]),2,2) V<-kronecker(R,C) a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } # model 2: different variances, same correlation lik2<-function(theta,C,D,y){ p<-(length(theta)-1)/2 v<-matrix(theta[1:(2*p)],p,2,byrow=T); r<-theta[length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } # model 3: same variances, different correlation lik3<-function(theta,C,D,y){ p<-length(theta)-2 v<-theta[1:2]; r<-theta[3:length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[1],r[i]*sqrt(v[1]*v[2]),r[i]*sqrt(v[1]*v[2]),v[2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } # model 4: everything different lik4<-function(theta,C,D,y){ p<-length(theta)/3 v<-matrix(theta[1:(2*p)],p,2,byrow=T); r<-theta[(2*p+1):length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } # done internal functions # bookkeeping X<-as.matrix(X) X<-X[tree$tip.label,] n<-nrow(X) # number of species m<-ncol(X) # number of traits if(m!=2) stop("number of traits must equal 2") p<-ncol(tree$mapped.edge) # number of states D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*nrunif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,y,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,y) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a.prime,y) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,y,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else { k<-j-1 # update node k y.prime<-y y.prime[k]<-y[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,y.prime) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a,y.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y.prime,L.prime) y<-y.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } } # done MCMC message("Done MCMC.") obj<-list(mcmc=as.data.frame(X),tree=tree) class(obj)<-"anc.Bayes" obj } ## S3 methods print.anc.Bayes<-function(x,digits=6,printlen=NULL,...){ cat("\nObject of class \"anc.Bayes\" consisting of a posterior") cat("\n sample from a Bayesian ancestral state analysis:\n") if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-0.2*max(x$mcmc$gen) ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2)) Nnode<-x$tree$Nnode cat("\nMean ancestral states from posterior distribution:\n") ace<-colMeans(x$mcmc[ii:nrow(x$mcmc),as.character(1:Nnode+Ntip(x$tree))]) if(is.null(printlen)||printlen>=Nnode) print(round(ace,digits)) else printDotDot(ace,digits,printlen) cat(paste("\nBased on a burn-in of ",burnin," generations.\n\n",sep="")) invisible(ace) } plot.anc.Bayes<-function(x,...){ args<-list(...) if(is.null(args$what)) what<-"logLik" else { what<-args$what args$what<-NULL } if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen) else { burnin<-args$burnin args$burnin<-NULL } if(what=="logLik"){ args$x<-x$mcmc$gen args$y<-x$mcmc$logLik if(is.null(args$xlab)) args$xlab<-"generation" if(is.null(args$ylab)) args$ylab<-"log(L)" if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-make.transparent("blue",0.5) do.call(plot,args) } }phytools/R/multiRF.R0000644000176200001440000000217113100216241014030 0ustar liggesusers## functions computes Robinson-Foulds distance between all trees in a list of class "multiPhylo" ## works only for unrooted trees (if trees are rooted, them will be unrooted) ## written by Liam J. Revell 2013, 2015, 2017 multiRF<-function(trees,quiet=FALSE,multi2di=FALSE){ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") N<-length(trees) RF<-matrix(0,N,N) if(any(sapply(unclass(trees),is.rooted))){ if(!quiet) cat("Some trees are rooted. Unrooting all trees.\n") trees<-lapply(unclass(trees),unroot) } if(any(sapply(unclass(trees),function(x) !is.binary.tree(x)))){ if(multi2di){ if(!quiet) cat("some trees are not binary. Using multi2di to render bifurcating.\n") trees<-lapply(trees,multi2di) class(trees)<-"multiPhylo" } else stop("Some trees are not binary. This implementation only works for binary trees.") } foo<-function(pp) lapply(pp,function(x,pp) sort(attr(pp,"labels")[x]),pp=pp) xx<-lapply(unclass(trees),function(x) foo(prop.part(x))[2:x$Nnode]) for(i in 1:(N-1)) for(j in (i+1):N) RF[i,j]<-RF[j,i]<-2*sum(!xx[[i]]%in%xx[[j]]) RF } phytools/R/branching.diffusion.R0000644000176200001440000000314212517441667016414 0ustar liggesusers# function animates branching random diffusion # written by Liam Revell 2011, 2013, 2015 branching.diffusion<-function(sig2=1,b=0.0023,time.stop=1000,ylim=NULL,smooth=TRUE,pause=0.02,record=NULL,path=NULL){ N<-1 Y<-matrix(0,1,N) if(is.null(ylim)) ylim<-c(-2*sqrt(sig2*time.stop),2*sqrt(sig2*time.stop)) par(bg="white") plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",main="branching diffusion") chk<-.check.pkg("animation") if(!chk){ cat(" record != NULL requires the package \"animation\"\n") cat(" Animation will play but not record\n\n") record<-NULL } if(!is.null(record)){ if(is.null(path)) path="C:/Program Files/ffmpeg/bin/ffmpeg.exe" tmp<-strsplit(path,"/")[[1]] ll<-list.files(paste(tmp[2:length(tmp)-1],collapse="/")) if(length(grep(tmp[length(tmp)],ll))>0){ ani.options(interval=0.01,ffmpeg=path,outdir=getwd()) ani.record(reset=TRUE) } else { cat(" record != NULL requires correct path supplied to video renderer\n") cat(" Animation will play but not record\n\n") record<-NULL } } for(i in 2:time.stop){ time<-1:i Y<-rbind(Y,Y[i-1,]) for(j in 1:N){ if(b>runif(n=1)){ Y<-cbind(Y,Y[,j]) N<-N+1 Y[i,N]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2)) } Y[i,j]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2)) } dev.hold() plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",main="branching diffusion") apply(Y,2,lines) dev.flush() if(!is.null(record)) ani.record() Sys.sleep(pause) } if(!is.null(record)) saveVideo(ani.replay(),video.name=record,other.opts="-b 300k",clean=TRUE) } phytools/R/read.simmap.R0000644000176200001440000002223312564236166014674 0ustar liggesusers# function reads SIMMAP v1.0 & v1.5 style trees into file # written by Liam J. Revell 2011-2015 read.simmap<-function(file="",text,format="nexus",rev.order=TRUE,version=1.0){ if(file!=""){ trans<-NULL if(format=="nexus"){ XX<-readNexusData(file,version) text<-XX$text trans<-XX$trans Ntree<-XX$Ntree } else if(format=="phylip"){ text<-scan(file,sep="\n",what="character") Ntree<-length(text) } } else { trans<-NULL Ntree<-length(text) } tree<-lapply(text,text_to_tree,version,rev.order,trans) class(tree)<-c("multiSimmap","multiPhylo") if(length(tree)==1) tree<-tree[[1]] return(tree) } # function gets branch length # written by Liam J. Revell 2011-2013 getBranch<-function(text,start,version){ if(version<=1.0){ i<-start+1 l<-1 if(text[i]=="{"){ maps<-vector() i<-i+1 while(text[i]!="}"){ temp<-vector() m<-1 while(text[i]!=","){ temp[m]<-text[i] i<-i+1 m<-m+1 } state<-paste(temp,collapse="") i<-i+1 temp<-vector() m<-1 while(text[i]!=":"&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } length<-as.numeric(paste(temp,collapse="")) maps[l]<-length names(maps)[l]<-as.character(state) l<-l+1 if(text[i]==":") i<-i+1 } } edge.length<-sum(maps) # create branch length i<-i+1 } else if(version>1.0){ i<-start+1 l<-1 if(text[i]=="["){ maps<-vector() i<-i+7 while(text[i]!="}"){ temp<-vector() m<-1 while(text[i]!=","&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } state<-paste(temp,collapse="") if(text[i]!="}"){ i<-i+1 temp<-vector() m<-1 while(text[i]!=","&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } ll<-as.numeric(paste(temp,collapse="")) maps[l]<-ll names(maps)[l]<-as.character(state) l<-l+1 if(text[i]==",") i<-i+1 } } temp<-vector() m<-1 i<-i+2 while(is.na(match(text[i],c(",",")")))){ temp[m]<-text[i] i<-i+1 m<-m+1 } maps[l]<-as.numeric(paste(temp,collapse=""))-sum(maps) names(maps)[l]<-as.character(state) } edge.length<-sum(maps) } return(list(maps=maps,edge.length=edge.length,end=i)) } # make a mapped edge matrix # written by Liam J. Revell 2013 makeMappedEdge<-function(edge,maps){ st<-sort(unique(unlist(sapply(maps,function(x) names(x))))) mapped.edge<-matrix(0,nrow(edge),length(st)) rownames(mapped.edge)<-apply(edge,1,function(x) paste(x,collapse=",")) colnames(mapped.edge)<-st for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] return(mapped.edge) } # function translates text-string to tree # written by Liam J. Revell 2011-2015 text_to_tree<-function(text,version,rev.order,trans){ text<-unlist(strsplit(text, NULL)) tip.label<-vector(mode="character") edge<-matrix(c(1,NA),1,2) edge.length<-vector() maps<-list() currnode<-1 Nnode<-currnode i<-j<-k<-1 while(text[i]!=";"){ if(text[i]=="("){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) maps[[j]]<-temp$maps edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to new internal node } j<-j+1 } else if(text[i]==")"){ i<-i+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) ii<-match(currnode,edge[,2]) maps[[ii]]<-temp$maps edge.length[ii]<-temp$edge.length i<-temp$end } currnode<-edge[match(currnode,edge[,2]),1] # move down the tree } else if(text[i]==","){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) maps[[j]]<-temp$maps edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to internal node } j<-j+1 } } Ntip<-k-1 edge[edge>0]<-edge[edge>0]+Ntip edge[edge<0]<--edge[edge<0] mapped.edge<-makeMappedEdge(edge,maps) maps<-if(rev.order) lapply(maps,function(x) x<-x[length(x):1]) else maps if(!is.null(trans))tip.label<-trans[tip.label] # assemble into modified "phylo" object tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,edge.length=edge.length,maps=maps,mapped.edge=mapped.edge) class(tree)<-c("simmap","phylo") attr(tree,"map.order")<-if(rev.order) "right-to-left" else "left-to-right" return(tree) } # function reads Nexus taxa block in SIMMAP format trees # modified from ape:read.nexus # written by Liam J. Revell 2011-2013 readNexusData<-function(file,version){ # read modified nexus block # this function is adapted from ape:read.nexus (Paradis et al. 2004) if(version<=1.0){ X<-scan(file=file,what="",sep="\n",quiet=TRUE) left<-grep("\\[",X) right<-grep("\\]",X) if(length(left)){ w<-left==right if(any(w)){ s<-left[w] X[s]<-gsub("\\[[^]]*\\]","",X[s]) } w<-!w if(any(w)){ s<-left[w] X[s]<-gsub("\\[.*","",X[s]) sb<-right[w] X[sb]<-gsub(".*\\]","",X[sb]) if(any(si1) TRUE else FALSE if(translation){ end<-semico[semico>i2][1] x<-X[(i2+1):end] x<-unlist(strsplit(x,"[,;\t]")) x<-unlist(strsplit(x," ")) # this is an addition x<-x[nzchar(x)] trans<-matrix(x,ncol=2,byrow=TRUE) trans[,2]<-gsub("['\"]","",trans[,2]) n<-dim(trans)[1] } start<-if(translation) semico[semico>i2][1]+1 else semico[semico>i1][1] end<-endblock[endblock>i1][1]-1 tree<-X[start:end] tree<-gsub("^.*= *","",tree) tree<-tree[tree!=""] semico<-grep(";",tree) Ntree<-length(semico) if(Ntree==1&&length(tree)>1){ STRING<-paste(tree,collapse="") } else { if(any(diff(semico)!=1)){ STRING<-character(Ntree) s<-c(1,semico[-Ntree]+1) j<-mapply(":",s,semico) if(is.list(j)){ for(i in 1:Ntree) STRING[i]<-paste(tree[j[[i]]],collapse="") } else { for(i in 1:Ntree) STRING[i]<-paste(tree[j[,i]],collapse="") } } else STRING<-tree } text<-STRING if(translation==TRUE){ rownames(trans)<-trans[,1] trans<-trans[,2] return(list(text=text,trans=trans,Ntree=Ntree)) } else return(list(text=text,Ntree=Ntree)) } else if(version>1.0){ X<-scan(file=file,what="",sep="\n",quiet=TRUE) left<-grep("\\[",X) right<-grep("\\]",X) skip<-if(version<=2.0) grep("\\&map",X) else if(version>2.0) grep("\\&prob",X) left<-setdiff(left,skip) right<-setdiff(right,skip) if(length(left)){ w<-left==right if(any(w)){ s<-left[w] X[s]<-gsub("\\[[^]]*\\]","",X[s]) } w<-!w if(any(w)){ s<-left[w] X[s]<-gsub("\\[.*","",X[s]) sb<-right[w] X[sb]<-gsub(".*\\]","",X[sb]) if(any(si1) TRUE else FALSE if(translation){ end<-semico[semico>i2][1] x<-X[(i2+1):end] x<-unlist(strsplit(x,"[,;\t]")) x<-unlist(strsplit(x," ")) # this is an addition x<-x[nzchar(x)] trans<-matrix(x,ncol=2,byrow=TRUE) trans[,2]<-gsub("['\"]","",trans[,2]) n<-dim(trans)[1] } start<-if(translation) semico[semico>i2][1]+1 else semico[semico>i1][1] end<-endblock[endblock>i1][1]-1 tree<-X[start:end] tree<-sub(".* = *","",tree) tree<-tree[tree!=""] semico<-grep(";",tree) Ntree<-length(semico) if(Ntree==1&&length(tree)>1){ STRING<-paste(tree,collapse="") } else { if(any(diff(semico)!=1)){ STRING<-character(Ntree) s<-c(1,semico[-Ntree]+1) j<-mapply(":",s,semico) if(is.list(j)){ for(i in 1:Ntree) STRING[i]<-paste(tree[j[[i]]],collapse="") } else { for(i in 1:Ntree) STRING[i]<-paste(tree[j[,i]],collapse="") } } else STRING<-tree } text<-STRING if(translation==TRUE){ rownames(trans)<-trans[,1] trans<-trans[,2] return(list(text=text,trans=trans,Ntree=Ntree)) } else return(list(text=text,Ntree=Ntree)) } } phytools/R/map.overlap.R0000644000176200001440000000616012704702630014707 0ustar liggesusers## function computes the fractional (i.e., 0->1) overlap between the ## stochastic maps of two trees ## written by Liam Revell 2011, 2015, 2016 Map.Overlap<-function(tree1,tree2,tol=1e-06,standardize=TRUE,...){ if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-TRUE if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo")) stop("Both input trees should be objects of class \"phylo\".") if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol)) stop("Mapped trees must have the same underlying structure.") if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap")) stop("Both input trees should be objects of class \"simmap\".") s1<-mapped.states(tree1) s2<-mapped.states(tree2) R<-matrix(0,length(s1),length(s2),dimnames=list(s1,s2)) for(i in 1:nrow(tree1$edge)){ XX<-matrix(0,length(tree1$maps[[i]]),2, dimnames=list(names(tree1$maps[[i]]),c("start","end"))) XX[1,2]<-tree1$maps[[i]][1] if(length(tree1$maps[[i]])>1){ for(j in 2:length(tree1$maps[[i]])){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+tree1$maps[[i]][j] } } YY<-matrix(0,length(tree2$maps[[i]]),2, dimnames=list(names(tree2$maps[[i]]),c("start","end"))) YY[1,2]<-tree2$maps[[i]][1] if(length(tree2$maps[[i]])>1){ for(j in 2:length(tree2$maps[[i]])){ YY[j,1]<-YY[j-1,2] YY[j,2]<-YY[j,1]+tree2$maps[[i]][j] } } for(j in 1:nrow(XX)){ lower<-max(which(YY[,1]<=XX[j,1])) upper<-which(YY[,2]>=(XX[j,2]-tol))[1] for(k in lower:upper){ R[rownames(XX)[j],rownames(YY)[k]]<- R[rownames(XX)[j],rownames(YY)[k]]+ min(YY[k,2],XX[j,2])-max(YY[k,1],XX[j,1]) } } } if(standardize) R/sum(R) else R } map.overlap<-function(tree1,tree2,tol=1e-6,...){ if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-TRUE if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo")) stop("Both input trees should be objects of class \"phylo\".") if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol)) stop("Mapped trees must have the same underlying structure.") if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap")) stop("Both input trees should be objects of class \"simmap\".") overlap<-0 for(i in 1:nrow(tree1$edge)){ XX<-matrix(0,length(tree1$maps[[i]]),2, dimnames=list(names(tree1$maps[[i]]),c("start","end"))) XX[1,2]<-tree1$maps[[i]][1] if(length(tree1$maps[[i]])>1){ for(j in 2:length(tree1$maps[[i]])){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+tree1$maps[[i]][j] } } YY<-matrix(0,length(tree2$maps[[i]]),2, dimnames=list(names(tree2$maps[[i]]),c("start","end"))) YY[1,2]<-tree2$maps[[i]][1] if(length(tree2$maps[[i]])>1){ for(j in 2:length(tree2$maps[[i]])){ YY[j,1]<-YY[j-1,2] YY[j,2]<-YY[j,1]+tree2$maps[[i]][j] } } for(j in 1:nrow(XX)){ lower<-which(YY[,1]<=XX[j,1]) lower<-lower[length(lower)] upper<-which(YY[,2]>=(XX[j,2]-tol))[1] for(k in lower:upper){ if(rownames(XX)[j]==rownames(YY)[k]) overlap<-overlap+min(YY[k,2],XX[j,2])- max(YY[k,1],XX[j,1]) } } } overlap/sum(tree1$edge.length) } phytools/R/skewers.R0000644000176200001440000000240512235062700014140 0ustar liggesusers## this function does random skewers following Cheverud & Marroig (2007) ## for is.null(method)==FALSE uses clusterGeneration::genPositiveDefMat ## written by Liam J. Revell 2013 skewers<-function(X,Y,nsim=100,method=NULL){ m<-nrow(X) if(!all(sapply(c(dim(X),dim(Y)),"==",m))) stop("X & Y should be square matrices of equal dimension") S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m) S<-S/matrix(sqrt(rowSums(S^2)),nsim,m) Sx<-apply(S,1,"%*%",X) Sy<-apply(S,1,"%*%",Y) R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2)) r<-mean(R) ## get null distribution foo<-function(m,method,rangeVar){ if(is.null(method)){ x<-runif(m,min=-1,max=1) x<-x/sqrt(sum(x^2)) y<-runif(m) y<-y/sqrt(sum(y^2)) r<-mean(x*y)/sqrt(mean(x^2)*mean(y^2)) } else { X<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma Y<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m) S<-S/matrix(sqrt(rowSums(S^2)),nsim,m) Sx<-apply(S,1,"%*%",X) Sy<-apply(S,1,"%*%",Y) R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2)) r<-mean(R) } r } Rnull<-replicate(nsim,foo(m,method=method,rangeVar=range(c(diag(X),diag(Y))))) return(list(r=r,p=mean(Rnull>=r))) }phytools/R/phyl.RMA.R0000644000176200001440000000602213073265705014061 0ustar liggesusers## this function computes a phylogenetic reduced major axis (RMA) regression ## written by Liam Revell 2010, 2011, 2012, 2015, 2016, 2017 phyl.RMA<-function(x,y,tree,method="BM",lambda=NULL,fixed=FALSE,h0=1.0){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-x[tree$tip.label]; y<-y[tree$tip.label] # bind the x & y into columns X<-cbind(x,y) if(method=="lambda") if(fixed==FALSE) result<-optimize(f=likMlambda,interval=c(0,1),X=X,C=vcv(tree), maximum=TRUE) else result<-list(objective=likMlambda(lambda,X,vcv(tree)),maximum=lambda) else if(method=="BM") result<-list(objective=likMlambda(1.0,X,vcv(tree)),maximum=1.0) else stop("do not recognize method") est.lambda<-result$maximum # estimated lambda C<-vcv(tree) C<-lambda.transform(est.lambda,C) temp<-phyl.vcv(X,vcv(tree),lambda=est.lambda) beta1<-sign(temp$R[1,2])*sqrt(temp$R[2,2]/temp$R[1,1]) beta0<-temp$a[2]-beta1*temp$a[1] r<-y-(beta0+beta1*x) r2<-temp$R[1,2]^2/(temp$R[1,1]*temp$R[2,2]) if(sign(beta1)!=sign(h0)){ warning("b & h0 have different signs; hypothesis test invalid") T<-0 } else T<-abs(log(abs(beta1))-log(abs(h0)))/sqrt((1-r2)/(Ntip(tree)-2)) df<-2+(Ntip(tree)-2)/(1+0.5*r2) P<-2*pt(T,df=df,lower.tail=FALSE) test<-c(r2,T,df,P); names(test)<-c("r2","T","df","P") object<-list(RMA.beta=c(beta0,beta1),V=temp$R,lambda=est.lambda, logL=as.numeric(result$objective),test=test,h0=h0,model=method, resid=as.matrix(r),data=cbind(x,y),tree=tree) class(object)<-"phyl.RMA" object } ## S3 methods for "phyl.RMA" object class print.phyl.RMA<-function(x,...){ cat("\nCoefficients:\n") print(coef(x)) cat("\nVCV matrix:\n") print(x$V) cat("\n") if(x$model=="BM") cat("Model for the covariance structure of the error is \"BM\"\n") else cat("Model for the covariance structure of the error is \"lambda\"\n") cat("\nEstimates (or set values):\n") print(setNames(c(x$lambda,x$logL),c("lambda","log(L)"))) cat("\n") cat("Hypothesis test based on Clarke (1980; Biometrika):\n") print(round(x$test,6)) cat(paste("\nNote that the null hypothesis test is h0 =",x$h0, "\n\n")) } coef.phyl.RMA<-function(object,...){ val<-setNames(object$RMA.beta,c("(Intercept)","x")) val } residuals.phyl.RMA<-function(object,...) object$resid[,1] plot.phyl.RMA<-function(x,...){ phylomorphospace(x$tree,x$data,node.size=c(0,0),ftype="off") points(x$data,cex=1.2,pch=21,bg="grey") x0<-ace(x$data[,1],x$tree,method="pic")$ace[1] y0<-ace(x$data[,2],x$tree,method="pic")$ace[1] a0<-y0-x$h0*x0 abline(a=a0,b=x$h0,lwd=2,col="grey",lty="dashed") abline(a=coef(x)[1],b=coef(x)[2],lwd=2,col="red") tmp<-legend(x=0,y=0,legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2),plot=FALSE) legend(x=if(x$h0>0) par()$usr[1] else par()$usr[2]-tmp$rect$w, y=par()$usr[4],col=c("red","grey"), legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2), bg=make.transparent("white",0.75)) } phytools/R/drop.tip.simmap.R0000644000176200001440000000567012564235520015517 0ustar liggesusers# function drops tip or tips from a SIMMAP style tree created by read.simmap, make.simmap, or sim.history # written by Liam Revell 2012, 2015 drop.tip.simmap<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") tip<-which(tree$tip.label%in%tip) edges<-match(tip,tree$edge[,2]) z<-setdiff(1:nrow(tree$edge),edges) tree$edge<-tree$edge[z,] tree$edge.length<-tree$edge.length[z] tree$maps<-tree$maps[z] z<-setdiff(tree$edge[,2],tree$edge[,1]) z<-z[z>length(tree$tip)] while(length(z)>0){ edges<-match(z,tree$edge[,2]) y<-setdiff(1:nrow(tree$edge),edges) tree$edge<-tree$edge[y,] tree$edge.length<-tree$edge.length[y] tree$maps<-tree$maps[y] z<-setdiff(tree$edge[,2],tree$edge[,1]) z<-z[z>length(tree$tip)] } z<-setdiff(tree$edge[,2],tree$edge[,1]) tree$tip.label<-tree$tip.label[z] tree$edge[which(tree$edge[,2]%in%z),2]<-1:length(tree$tip) while(sum(tree$edge[1,1]==tree$edge[,1])==1){ tree$edge<-tree$edge[2:nrow(tree$edge),] tree$edge.length<-tree$edge.length[2:length(tree$edge.length)] tree$maps<-tree$maps[2:length(tree$maps)] } i<-1 while(i1) tree$maps[[i]]<-c(tree$maps[[i]],tree$maps[[z]][2:length(tree$maps[[z]])]) } y<-setdiff(1:nrow(tree$edge),z) tree$edge<-tree$edge[y,] tree$edge.length<-tree$edge.length[y] tree$maps<-tree$maps[y] single<-sum(tree$edge[i,2]==tree$edge[,1])==1 } i<-i+1 } z<-unique(as.vector(tree$edge)) z<-z[z>length(tree$tip)] y<-order(z)+length(tree$tip) for(i in 1:nrow(tree$edge)) for(j in 1:2) if(tree$edge[i,j]%in%z) tree$edge[i,j]<-y[which(tree$edge[i,j]==z)] tree$Nnode<-max(tree$edge)-length(tree$tip) tree$node.states<-matrix(NA,nrow(tree$edge),2) for(i in 1:nrow(tree$edge)) tree$node.states[i,]<-c(names(tree$maps[[i]])[1],names(tree$maps[[i]])[length(tree$maps[[i]])]) if(!is.null(tree$states)) tree$states<-tree$states[tree$tip.label] allstates<-vector() for(i in 1:nrow(tree$edge)) allstates<-c(allstates,names(tree$maps[[i]])) allstates<-unique(allstates) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(allstates),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=allstates)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j] class(tree)<-c("simmap",setdiff(class(tree),"simmap")) return(tree) } phytools/R/phenogram.R0000644000176200001440000001635213160246164014451 0ustar liggesusers## function creates a phenogram (i.e., 'traitgram') ## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016 phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FALSE,...){ ## get optional arguments if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(log)) log<-list(...)$log else log<-"" if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(sub)) sub<-list(...)$sub else sub<-NULL if(hasArg(xlab)) xlab<-list(...)$xlab else xlab<-"time" if(hasArg(ylab)) ylab<-list(...)$ylab else ylab<-"phenotype" if(hasArg(asp)) asp<-list(...)$asp else asp<-NA if(hasArg(type)) type<-list(...)$type else type<-"l" if(hasArg(lty)) lty<-list(...)$lty else lty<-1 if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(offset)) offset<-list(...)$offset else offset<-0.2 if(hasArg(offsetFudge)) offsetFudge<-list(...)$offsetFudge else offsetFudge<-1.37 if(hasArg(digits)) digits<-list(...)$digits else digits<-2 if(hasArg(nticks)) nticks<-list(...)$nticks else nticks<-5 if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels else spread.labels<-TRUE if(ftype=="off") spread.labels<-FALSE if(hasArg(spread.cost)) spread.cost<-list(...)$spread.cost else spread.cost<-c(1,0.4) if(hasArg(spread.range)) spread.range<-list(...)$spread.range else spread.range<-range(x) if(hasArg(link)) link<-list(...)$link else link<-if(spread.labels) 0.1*max(nodeHeights(tree)) else 0 if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(label.pos)) label.pos<-list(...)$label.pos else label.pos<-NULL ## end optional arguments # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check font ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype&&!add) fsize=0 H<-nodeHeights(tree) if(length(x)<(length(tree$tip)+tree$Nnode)) x<-c(x,fastAnc(tree,x)) else x<-c(x[tree$tip.label],x[as.character(length(tree$tip)+1:tree$Nnode)]) x[1:length(tree$tip)]<-x[tree$tip.label] names(x)[1:length(tree$tip)]<-1:length(tree$tip) X<-matrix(x[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge)) # legacy 'axes' argument trumps ylim & xlim from optional (...) if(is.null(axes$trait)&&is.null(ylim)) ylim<-c(min(x),max(x)) else if(!is.null(axes$trait)) ylim<-axes$trait if(!is.null(axes$time)) xlim<-axes$time if(!add&&is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+offsetFudge*offset*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,link,sw,pp) (a*1.04*(max(H)+link)+sw-pp)^2,H=H,link=link,sw=sw,pp=pp,interval=c(0,1e6))$minimum xlim<-c(min(H),max(H)+link+sw/alp) } if(!quiet&&Ntip(tree)>=40&&spread.labels){ cat("Optimizing the positions of the tip labels...\n") flush.console() } ## matrix for tip coordinates tip.coords<-matrix(NA,Ntip(tree),2,dimnames=list(tree$tip.label,c("x","y"))) if(hold) null<-dev.hold() if(is.null(tree$maps)){ if(is.null(colors)) colors<-"black" if(!add){ plot(H[1,],X[1,],type=type,lwd=lwd,lty=lty,col=colors,xlim=xlim,ylim=ylim,log=log,asp=asp,xlab="",ylab="",frame=FALSE, axes=FALSE) if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost,range=spread.range,label.pos=label.pos) else tt<-x[1:length(tree$tip)] if(tree$edge[1,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[1,2]]),x=H[1,2]+link,y=tt[tree$edge[1,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[1,2]],]<-c(H[1,2]+link,tt[tree$edge[1,2]]) if(link>0) lines(x=c(H[1,2],H[1,2]+link),y=c(X[1,2],tt[tree$edge[1,2]]),lty=3) } } s<-2 } else s<-1 for(i in s:nrow(H)){ lines(H[i,],X[i,],type=type,lwd=lwd,lty=lty,col=colors) if(tree$edge[i,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,tt[tree$edge[i,2]]) if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],tt[tree$edge[i,2]]),lty=3) } } } } else { if(is.null(colors)){ nn<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes")))) colors<-setNames(palette()[1:length(nn)],nn) } for(i in 1:nrow(H)){ y<-H[i,1] m<-diff(X[i,])/diff(H[i,]) for(j in 1:length(tree$maps[[i]])){ a<-c(y,y+tree$maps[[i]][j]) b<-m*(a-H[i,1])+X[i,1] if(i==1&&j==1&&!add) { plot(a,b,col=colors[names(tree$maps[[i]])[j]],type=type,lwd=lwd,lty=lty,xlim=xlim,ylim=ylim,log=log,asp=asp,axes=FALSE,xlab="",ylab="") if(spread.labels) tt<-spreadlabels(tree,x[1:length(tree$tip)],fsize=fsize,cost=spread.cost,range=spread.range) else tt<-x[1:length(tree$tip)] print(tt) } else lines(a,b,col=colors[names(tree$maps[[i]])[j]],lwd=lwd,lty=lty,type=type) y<-a[2] } if(tree$edge[i,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,tt[tree$edge[i,2]]) if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],tt[tree$edge[i,2]]),lty=3) } } } } if(!add){ at<-round(0:(nticks-1)*max(H)/(nticks-1),digits) axis(1,at=at); axis(2); title(xlab=xlab,ylab=ylab,main=main,sub=sub) } if(hold) null<-dev.flush() xx<-setNames(c(H[1,1],H[,2]),c(tree$edge[1,1],tree$edge[,2])) xx<-xx[order(as.numeric(names(xx)))] yy<-setNames(c(X[1,1],X[,2]),c(tree$edge[1,1],tree$edge[,2])) yy<-yy[order(as.numeric(names(yy)))] PP<-list(type="phenogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=NULL,no.margin=FALSE,label.offset=offset, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode, edge=tree$edge,xx=xx,yy=yy) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) invisible(tip.coords) } ## function to spread labels ## written by Liam J. Revell 2013, 2014, 2016 spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL){ if(!is.null(label.pos)) return(label.pos[tree$tip.label]) else { if(is.null(range)) range<-range(x) yy<-x[1:Ntip(tree)] zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+range(yy)[1],names(yy)) mm<-max(fsize*strheight(tree$tip.label)) ff<-function(zz,yy,cost,mo=1,ms=1){ ZZ<-cbind(zz-mm/2,zz+mm/2) ZZ<-ZZ[order(zz),] oo<-0 for(i in 2:nrow(ZZ)) oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo pp<-sum((zz-yy)^2) oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp oo/mo*cost[1]+pp/ms*cost[2] } mo<-ff(yy,zz,cost=c(1,0)) ms<-ff(yy,zz,cost=c(0,1)) if(mo==0&&ms==0) return(yy) else { rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B",lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy))) return(rr$par) } } } phytools/R/dotTree.R0000644000176200001440000001712513135423550014074 0ustar liggesusers## function to plot a tree with dots/circles for a plotted phenotype ## written by Liam J. Revell 2016, 2017 dotTree<-function(tree,x,legend=TRUE,method="plotTree",standardize=FALSE,...){ if(is.data.frame(x)) x<-as.matrix(x) if(hasArg(data.type)) data.type<-list(...)$data.type else { ## try to detect type if(is.numeric(x)) data.type<-"continuous" else data.type<-"discrete" } if(data.type=="continuous"){ if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" dotTree.continuous(tree,x,colors[1],legend,method,standardize,...) } else if(data.type=="discrete"){ if(hasArg(colors)) colors<-list(...)$colors else { ss<-unique(as.vector(x)) colors<-setNames(palette()[1:length(ss)],ss) } dotTree.discrete(tree,x,colors,legend,method,...) } } dotTree.continuous<-function(tree,x,color,legend,method,standardize,...){ if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 if(hasArg(k)) k<-list(...)$k else k<-0.8 ## reorder tree tree<-reorder(tree,"cladewise") ## if standardize==TRUE if(standardize){ if(is.matrix(x)){ sd<-apply(x,2,function(x) sqrt(var(x))) x<-(x-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(x))/ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd) } else if(is.vector(x)) x<-(x-mean(x))/sqrt(var(x)) } ## in case any x<0 min.x<-min(x) max.x<-max(x) if(any(x<0)) x<-x-min(x) if(method=="plotTree"){ x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-Ntip(tree)/25, Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, radius=rr,MoreArgs=list(nv=200,col=color)) ## add legend if(legend){ h<-dot.legend(x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=0,min.x,max.x,Ntip=Ntip(tree), method="plotTree",...) if(standardize) text(h,0.1*(1+par()$usr[3]),"(SD units)",pos=4) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] ## plot tree plot.new() par(mar=rep(0.1,4)) plot.window(xlim=c(-0.5,0.55+x.space*ncol(x)+x.space/2), ylim=c(if(legend) -0.1 else 0,1)) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/ (Ntip(tree)-1) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,radius=rr[,i],MoreArgs=list(nv=200,col=color)) ## draw.circle(x.tip+1.2*strwidth("W")+x.space*(i-1),y.tip, ## nv=200,radius=rr[,i],col=color) } ## add legend if(legend){ h<-dot.legend(x=-0.45,y=-0.04,min.x,max.x,Ntip=Ntip(tree), method="phylogram",...) if(standardize) text(h,-0.04,"(SD units)",pos=4) } } } dotTree.discrete<-function(tree,x,color,legend,method,...){ if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 ## reorder tree tree<-reorder(tree,"cladewise") if(method=="plotTree"){ x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-1/25*Ntip(tree), Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]), strwidth("W")*fsize/2) nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, col=color[as.character(x)],MoreArgs=list(nv=200,radius=r)) if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle", x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=-1/25*Ntip(tree)) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] ## plot tree plot.new() par(mar=rep(0.1,4)) plot.window(xlim=c(-0.5,0.55+x.space*ncol(x)+x.space/2), ylim=c(if(legend) -0.06 else 0,1)) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip(tree)-1), strwidth("W")*fsize/2) for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,col=color[as.character(x[,i])],MoreArgs=list(nv=20, radius=r)) ## draw.circle(x.tip+1.2*strwidth("W")+x.space*(i-1),y.tip, ## nv=200,radius=r,col=color[as.character(x[,i])]) } ## add legend if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle",x=-0.45,y=-0.06) } } } ## dot legend ## written by Liam J. Revell 2016 dot.legend<-function(x,y,min,max,Ntip,length=5,prompt=FALSE, method="plotTree",...){ if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" if(hasArg(leg.space)) leg.space<-list(...)$leg.space else leg.space<-0.2 if(hasArg(k)) k<-list(...)$k else k<-0.8 if(prompt){ obj<-locator(1) x<-obj$x y<-obj$y } if(method=="plotTree"){ text(x,y-0.5*(Ntip/25),round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/min(max,max+min)+0.1)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr, MoreArgs=list(nv=200,col=colors)) ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors) text(max(x+temp),y-0.5*(Ntip/25),round(max,2),pos=1,cex=cex) y1<-0.1/25*Ntip lines(c(x,max(x+temp)),rep(y-0.5*(Ntip/25)-y1,2)) lines(c(x,x),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) } else if(method=="phylogram"){ text(x,y-0.04,round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/(min(max,max+min))+0.1)/2* diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr, MoreArgs=list(nv=200,col=colors)) ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors) text(max(x+temp),y-0.04,round(max,2),pos=1,cex=cex) y1<-0.01 lines(c(x,max(x+temp)),rep(y-0.02-y1,2)) lines(c(x,x),y-c(y1+0.02,2*y1+0.02)) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.02,2*y1+0.02)) } invisible(max(x+temp)+0.5*max(rr)) }phytools/R/writeNexus.R0000644000176200001440000000213312562012303014625 0ustar liggesusers# function # written by Liam J. Revell 2012, 2015 writeNexus<-function(tree,file=""){ if(inherits(tree,"multiPhylo")) N<-length(tree) else { N<-1 tree<-list(tree) } n<-length(tree[[1]]$tip.label) write("#NEXUS",file) write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE) write("BEGIN TAXA;",file,append=TRUE) write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE) write("\tTAXLABELS",file,append=TRUE) trans<-tree[[1]]$tip.label; trans<-sort(trans) for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) write("END;",file,append=TRUE) write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE) for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE) write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) for(i in 1:N){ tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans)) write(paste("\tTREE * UNTITLED = [&R] ",write.tree(tree[[i]]),sep=""),file,append=TRUE) } write("END;",file,append=TRUE) } phytools/R/brownieREML.R0000644000176200001440000000620712601007775014616 0ustar liggesusers# This function is a simplified REML version of brownie.lite() # written by Liam J. Revell 2011, 2013 brownieREML<-function(tree,x,maxit=2000,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ## optional arguments if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 # bookkeeping if(!is.binary.tree(tree)) tree<-multi2di(tree) x<-x[tree$tip.label] # order in tip.label order n<-length(x) # number of species p<-ncol(tree$mapped.edge) # number of states # fit the single rate model lik1<-function(sig1,tree,x){ tt<-scaleByMap(tree,setNames(rep(sig1,p),colnames(tree$mapped.edge))) picX<-pic(x,tt,scaled=FALSE,var.contrasts=TRUE) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) return(-logL) } sig1<-mean(pic(x,tree)^2) logL1<--lik1(sig1,tree,x) H<-optimHess(sig1,lik1,tree=tree,x=x) v1<-1/H # fit the multiple rate model lik2<-function(sig2,tree,x){ tt<-scaleByMap(tree,sig2) picX<-pic(x,tt,scaled=F,var.contrasts=T) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) return(-logL) } YY<-optim(setNames(rep(1,p)*runif(n=p),colnames(tree$mapped.edge)),lik2,tree=tree,x=x,method="L-BFGS-B",lower=rep(1e-8,p)) sig2<-YY$par obj<-optimHess(sig2,lik2,tree=tree,x=x) if(any(diag(obj)0) H<-obj[ii,ii] v2<-matrix(Inf,nrow(obj),ncol(obj)) v2[ii,ii]<-if(length(H)>1) solve(H) else 1/H } else v2<-if(length(sig2)>1) solve(obj) else 1/obj logL2<--YY$value if(YY$convergence==0) converged<-"Optimization has converged." else converged<-"Optimization may not have converged. Consider increasing maxit." convergence=(YY$convergence==0) obj<-list(sig2.single=sig1,var.single=v1,logL1=logL1,k1=1,sig2.multiple=sig2,vcv.multiple=v2,logL.multiple=logL2, k2=length(sig2),convergence=converged) class(obj)<-"brownieREML" obj } # This function scales a mapped tree by sig2 # written by Liam J. Revell 2011 scaleByMap<-function(mtree,sig2){ edge.length<-if(length(sig2)>1) mtree$mapped.edge[,names(sig2)]%*%sig2 else mtree$mapped.edge*sig2 tree<-list(Nnode=mtree$Nnode,edge=mtree$edge,tip.label=mtree$tip.label,edge.length=edge.length[,1]) class(tree)<-"phylo" return(tree) } ## S3 print method for "brownieREML" ## S3 print method for object of class "brownie.lite" ## written by Liam J. Revell 2013 print.brownieREML<-function(x, ...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat("REML single-rate model:\n") cat("\ts^2\tse\tk\tlogL\n") cat(paste("value",x$sig2.single,round(sqrt(x$var.single),digits),x$k1,x$logL1,"\n\n",sep="\t")) cat("REML multi-rate model:\n") cat(paste(c("",paste("s^2(",names(x$sig2.multiple),")","\tse(",names(x$sig2.multiple),")",sep=""), "k","logL","\n"),collapse="\t")) cat(paste(paste(c("value",paste(x$sig2.multiple,round(sqrt(diag(x$vcv.multiple)),digits),sep="\t"),x$k2, x$logL.multiple),collapse="\t"),"\n\n",sep="")) if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the REML solution.\n\n") else cat("Optimization may not have converged.\n\n") } phytools/R/strahlerNumber.R0000644000176200001440000000352612561737207015474 0ustar liggesusers# function computes the Strahler number at each node # written by Liam J. Revell 2013, 2015 strahlerNumber<-function(tree,plot=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") pw<-reorder(tree,"pruningwise") oo<-sapply(tree$edge[,2],function(x,y) which(x==y),y=pw$edge[,2]) SS<-matrix(0,nrow(pw$edge),2) SS[pw$edge[,2]<=length(pw$tip.label),2]<-1 nn<-unique(pw$edge[,1]) for(i in 1:pw$Nnode){ jj<-which(pw$edge[,1]==nn[i]) s<-sort(SS[jj,2],decreasing=TRUE) SS[jj,1]<-if(all(sapply(s[2:length(s)],"<",s[1]))) s[1] else s[1]+1 SS[which(pw$edge[,2]==pw$edge[jj[1],1]),2]<-SS[jj[1],1] } ss<-setNames(c(SS[oo,][1,1],SS[oo,2]),c(tree$edge[1,1],tree$edge[,2])) ss<-ss[order(as.numeric(names(ss)))] names(ss)[1:length(tree$tip.label)]<-tree$tip.label if(plot){ plotTree(tree) nodelabels(ss[1:tree$Nnode+length(tree$tip.label)]) } return(ss) } # extracts all the most inclusive clades with Strahler number i from tree # written by Liam J. Revell 2013, 2015 extract.strahlerNumber<-function(tree,i,plot=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") sn<-strahlerNumber(tree) sn<-sn[sn==i] # get descendant tip numbers for all clades ll<-lapply(as.numeric(names(sn)),getDescendants,tree=tree) # figure out which ones are most inclusive ff<-function(x,y) !all(sapply(x,"%in%",y)) GG<-sapply(ll,function(x,y) sapply(y,ff,x=x),y=ll) ii<-which(colSums(GG)==(ncol(GG)-1)) # extract these clades trees<-lapply(as.numeric(names(sn))[ii],extract.clade,phy=tree) if(plot){ nplots<-2*ceiling(length(trees)/2) layout(matrix(1:nplots,ceiling(nplots/2),min(c(length(trees),2)),byrow=TRUE)) sNN<-lapply(trees,strahlerNumber,plot=TRUE) } if(length(trees)>1) class(trees)<-"multiPhylo" else trees<-trees[[1]] return(trees) } phytools/R/sim.corrs.R0000644000176200001440000000257512561736726014426 0ustar liggesusers# sim.corrs # written by Liam J. Revell 2012, 2013, 2015 sim.corrs<-function(tree,vcv,anc=NULL,internal=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!is.list(vcv)){ p<-nrow(vcv) if(is.null(anc)) anc<-rep(0,p) cholvcv<-chol(vcv) X<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$edge.length),p)),nrow(tree$edge),p) X<-X%*%cholvcv } else { p<-nrow(vcv[[1]]) if(is.null(anc)) anc<-rep(0,p) if(is.null(names(vcv))){ names(vcv)<-colnames(tree$mapped.edge) message("names absent from vcv: assuming same order as $mapped.edge") } vcv<-vcv[colnames(tree$mapped.edge)] cholvcv<-lapply(vcv,chol) X<-matrix(0,nrow(tree$edge),p) for(i in 1:length(vcv)){ Y<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$mapped.edge[,i]),p)),nrow(tree$edge),p) X<-X+Y%*%cholvcv[[i]] } } Y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),p)) n<-length(tree$tip) for(i in 1:nrow(X)){ if(tree$edge[i,1]==(n+1)) Y[i,1,]<-anc else Y[i,1,]<-Y[match(tree$edge[i,1],tree$edge[,2]),2,] Y[i,2,]<-Y[i,1,]+X[i,] } X<-matrix(data=rbind(Y[1,1,],as.matrix(Y[,2,])),length(tree$edge.length)+1,p) rownames(X)<-c(n+1,tree$edge[,2]) X<-as.matrix(X[as.character(1:(n+tree$Nnode)),]) rownames(X)[1:n]<-tree$tip.label if(internal==TRUE) return(X) else return(X[1:length(tree$tip.label),]) } phytools/R/roundPhylogram.R0000644000176200001440000000613112727074156015505 0ustar liggesusers## function plots a round phylogram ## written by Liam J. Revell 2014, 2015, 2016 roundPhylogram<-function(tree,fsize=1.0,ftype="reg",lwd=2,mar=NULL,offset=NULL, direction="rightwards",type="phylogram",xlim=NULL,ylim=NULL,...){ if(inherits(tree,"multiPhylo")){ par(ask=TRUE) tt<-lapply(tree,roundPhylogram,fsize=fsize,ftype=ftype,lwd=lwd,mar=mar,offset=offset, direction=direction,type=type,xlim=xlim,ylim=ylim) } else { if(hasArg(lty)) lty<-list(...)$lty else lty<-"solid" if(length(lty)!=nrow(tree$edge)) lty<-rep(lty,ceiling(nrow(tree$edge)/length(lty))) if(length(lwd)!=nrow(tree$edge)) lwd<-rep(lwd,ceiling(nrow(tree$edge)/length(lwd))) if(type=="cladogram"||is.null(tree$edge.length)) tree<-compute.brlen(tree) ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # swap out "_" character for spaces (assumes _ is a place holder) tree$tip.label<-gsub("_"," ",tree$tip.label) if(is.null(mar)) mar=rep(0.1,4) n<-length(tree$tip.label) # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") io<-reorder(tree,index.only=TRUE) lwd<-lwd[io] lty<-lty[io] y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-1:n # reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) # compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } # compute start & end points of each edge X<-nodeHeights(cw) if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum xlim<-c(min(X),max(X)+sw/alp) } if(is.null(ylim)) ylim=c(1,max(y)) ## end preliminaries # open & size a new plot plot.new() par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 plot.window(xlim=xlim,ylim=ylim) # plot edges for(i in 1:nrow(X)){ x<-NULL b<-y[cw$edge[i,1]] c<-X[i,1] d<-if(y[cw$edge[i,2]]>y[cw$edge[i,1]]) 1 else -1 xx<-X[i,2] yy<-y[cw$edge[i,2]] a<-(xx-c)/(yy-b)^2 curve(d*sqrt((x-c)/a)+b,from=X[i,1],to=X[i,2],add=TRUE,lwd=lwd[i],lty=lty[i]) } # plot tip labels for(i in 1:n) if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=offset,font=ftype,cex=fsize) PP<-list(type=type,use.edge.length=if(type=="phylogram") TRUE else FALSE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,font=ftype,cex=fsize, adj=0,srt=0,no.margin=FALSE,label.offset=offset,x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=length(cw$tip.label),Nnode=cw$Nnode,edge=cw$edge, xx=sapply(1:(length(cw$tip.label)+cw$Nnode),function(x,y,z) y[match(x,z)],y=X,z=cw$edge), yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } phytools/R/mcmcBM.R0000644000176200001440000001012011746536303013617 0ustar liggesusers# function # written by Liam J. Revell 2011 mcmcBM<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) a<-mean(xbar) intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T) prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV) pr.mean<-c(1000,rep(0,n+1),1000) pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[length(pr.mean)]^2) # populate control list con=list(sig2=sig2,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,a,xbar,intV){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T) return(pp) } # compute C C<-vcv.phylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; xbar<-con$xbar; intV<-con$intV L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV) Pr<-log.prior(sig2,a,xbar,intV) # store X<-matrix(NA,ngen/con$sample+1,n+5,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,"var","logLik"))) X[1,]<-c(0,sig2,a,xbar,intV,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(n+3) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV) Pr.prime<-log.prior(sig2.prime,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,intV,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV) Pr.prime<-log.prior(sig2,a.prime,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,intV,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j>1&&j<=(n+1)) { k<-j-1 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV) Pr.prime<-log.prior(sig2,a,xbar.prime,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,intV,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j>(n+1)){ # update var intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(intV.prime<0) intV.prime<--intV.prime L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime) Pr.prime<-log.prior(sig2,a,xbar,intV.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV.prime,L.prime) intV<-intV.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/make.era.map.R0000644000176200001440000000364112564235635014735 0ustar liggesusers# function creates a mapped tree in which the mappings are based on eras defined by "limits" # written by Liam J. Revell 2011, 2013, 2015 make.era.map<-function(tree,limits,...){ ## set tolerance if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-5 # check if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") H<-nodeHeights(tree) # compute node heights if(limits[1]>tol){ warning("first value in limits should be zero.") limits[1]<-0 } while(limits[length(limits)]>max(H)){ warning("last value in limits should be less than the total tree height.") limits<-limits[1:(length(limits)-1)] } if(is.null(names(limits))) names(limits)<-1:length(limits) limits[length(limits)+1]<-max(H) maps<-list() # ok, now go through the edges of the tree for(i in 1:nrow(tree$edge)){ s<-1 while((H[i,1]>=(limits[s]-tol)&&H[i,1]limits[e]&&H[i,2]<=(limits[e+1]+tol))==FALSE) e<-e+1 maps[[i]]<-vector() if(s==e){ maps[[i]][1]<-tree$edge.length[i] names(maps[[i]])[1]<-names(limits)[s] } else { maps[[i]][1]<-limits[s+1]-H[i,1] for(j in (s+1):e) maps[[i]][j-s+1]<-limits[j+1]-limits[j] maps[[i]][e-s+1]<-H[i,2]-limits[e] names(maps[[i]])<-names(limits)[s:e] } } tree$maps<-maps # now construct the matrix "mapped.edge" (for backward compatibility) allstates<-vector() for(i in 1:nrow(tree$edge)) allstates<-c(allstates,names(tree$maps[[i]])) allstates<-unique(allstates) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(allstates), dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")), state=allstates)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i, names(tree$maps[[i]])[j]]+tree$maps[[i]][j] class(tree)<-c("simmap",setdiff(class(tree),"simmap")) tree } phytools/R/anc.trend.R0000644000176200001440000000534313201660663014343 0ustar liggesusers## this function estimates ancestral traits with a trend ## written by Liam J. Revell 2011, 2013, 2015, 2017 anc.trend<-function(tree,x,maxit=2000){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ## check if tree is ultrametric if(is.ultrametric(tree)) cat("Warning: the trend model is generally non-identifiable for ultrametric trees.\n") # preliminaries # set global tol<-1e-8 # check to make sure that C will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") # compute C D<-dist.nodes(tree) ntips<-length(tree$tip.label) Cii<-D[ntips+1,] C<-D; C[,]<-0 counts<-vector() for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 dimnames(C)[[1]][1:length(tree$tip)]<-tree$tip.label dimnames(C)[[2]][1:length(tree$tip)]<-tree$tip.label C<-C[c(1:ntips,(ntips+2):nrow(C)),c(1:ntips,(ntips+2):ncol(C))] # sort x by tree$tip.label x<-x[tree$tip.label] # function returns the negative log-likelihood likelihood<-function(theta,x,C){ a<-theta[1] u<-theta[2] sig2<-theta[3] y<-theta[4:length(theta)] logLik<-dmnorm(x=c(x,y),mean=(a+diag(C)*u), varcov=sig2*C,log=TRUE) return(-logLik) } # get reasonable starting values for the optimizer a<-mean(x) sig2<-var(x)/max(C) # perform ML optimization result<-optim(par=c(a,0,sig2,rep(a,tree$Nnode-1)),likelihood, x=x,C=C,method="L-BFGS-B",lower=c(-Inf,-Inf,tol,rep(-Inf,tree$Nnode-1)), control=list(maxit=maxit)) # return the result ace<-c(result$par[c(1,4:length(result$par))]) names(ace)<-c(as.character(tree$edge[1,1]), rownames(C)[(length(tree$tip.label)+1):nrow(C)]) obj<-list(ace=ace,mu=result$par[2],sig2=result$par[3], logL=-result$value,convergence=result$convergence, message=result$message) class(obj)<-"anc.trend" obj } ## print method for "anc.trend" ## written by Liam J. Revell 2015, 2017 print.anc.trend<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using anc.trend:\n") Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) cat("\nParameter estimates:\n") cat(paste("\tmu",paste(rep(" ",digits),collapse=""),"\tsig^2", paste(rep(" ",max(digits-3,1)),collapse=""),"\tlog(L)\n",sep="")) cat(paste("\t",round(x$mu,digits),"\t",round(x$sig2,digits),"\t", round(x$logL,digits),"\n"),sep="") if(x$convergence==0) cat("\nR thinks it has converged.\n\n") else cat("\nR thinks function may not have converged.\n\n") } ## logLik method for "anc.trend" logLik.anc.trend<-function(object,...){ lik<-object$logL attr(lik,"df")<-length(object$ace)+2 lik } phytools/R/brownie.lite.R0000644000176200001440000001151112561706173015067 0ustar liggesusers# this function fits two or more evolutionary rates for a continuous trait on the tree # based on O'Meara et al. (2006) # written by Liam J. Revell 2011/2012 brownie.lite<-function(tree,x,maxit=2000,test="chisq",nsim=100,se=NULL,...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-matchDatatoTree(tree,x,"x") x<-x[tree$tip.label] if(!is.null(se)) se<-matchDatatoTree(tree,se,"se") else { se<-rep(0,length(x)) names(se)<-names(x) } n<-length(x) # number of species p<-ncol(tree$mapped.edge) # number of states C1<-vcv.phylo(tree) a<-as.numeric(colSums(solve(C1))%*%x/sum(solve(C1))) sig<-as.numeric(t(x-a)%*%solve(C1)%*%(x-a)/n) # single rate model model1<-optim(c(sig,a),fn=lik.single,y=x,C=C1,se=se,control=list(maxit=maxit),hessian=TRUE,method="L-BFGS-B",lower=c(0,-Inf)) logL1<--model1$value sig1<-model1$par[1] a1<-model1$par[2] vcv1<-solve(model1$hessian); rownames(vcv1)<-c("sig","a"); colnames(vcv1)<-rownames(vcv1) # multiple rate model C2<-multiC(tree) s<-c(rep(sig1,p),a1) l<-c(rep(0.0001*sig1,p),-Inf) model2<-optim(s,fn=lik.multiple,y=x,C=C2,se=se,control=list(maxit=maxit),hessian=TRUE,method="L-BFGS-B",lower=l) logL2<--model2$value while(logL21&&rotate){ pca<-phyl.pca(tree,X[tree$tip.label,]) obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1) X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec } if(search=="heuristic"){ trees<-list() ee<-c(root.node,tree$edge[,2]) for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1]) class(trees)<-"multiPhylo" lik.edge<-function(tree,XX,rotate){ if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE)) sum(ll) } logL<-sapply(trees,lik.edge,XX=X,rotate=rotate) if(plot){ ll<-logL[2:length(logL)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(logL[2:length(logL)],1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } edge<-ee[which(logL==max(logL))] } lik.tree<-function(position,tip,tree,edge,XX,rt,rotate){ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge) else tree<-bind.tip(tree,tip,where=edge,position=position) if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE)) sum(ll) } if(search=="heuristic"){ ee<-edge if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent")) if(edge>length(tree$tip.label)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2]) } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2]) ee<-intersect(ee,constraint) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree, edge=ee[i],XX=X,rt=root.node,rotate=rotate,maximum=TRUE) else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i], XX=X,rt=root.node,rotate=rotate,maximum=TRUE) } logL<-sapply(fit,function(x) x$objective) if(search=="exhaustive"&&plot){ ll<-sapply(fit,function(x) x$objective) ll<-ll[2:length(ll)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(ll,1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } fit<-fit[[which(logL==max(logL))]] edge<-ee[which(logL==max(logL))] mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum) mltree$logL<-fit$objective if(!quiet) cat("Done.\n") mltree } yetiREML<-function(tree,X,quiet,tip,root.node,constraint,plot,search){ if(!quiet){ cat("---------------------------------------------------------------\n") cat("| **Warning: method=\"REML\" has not been thoroughly tested. |\n") cat("| Use with caution.** |\n") cat("---------------------------------------------------------------\n\n") } if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using REML. Please wait....\n",sep="")) if(search=="heuristic"){ trees<-list() ee<-c(root.node,tree$edge[,2]) for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1]) class(trees)<-"multiPhylo" lik.edge<-function(tree,XX){ tree<-multi2di(tree) YY<-apply(XX[tree$tip.label,],2,pic,phy=tree) vcv<-t(YY)%*%YY/nrow(YY) E<-eigen(vcv)$vectors ##a<-apply(XX,2,function(x,tree) ace(x,tree,type="continuous",method="pic")$ace[1],tree=tree) ##S<-(X-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%E ##ZZ<-apply(S,2,pic,phy=tree) ZZ<-YY%*%E vars<-diag(t(ZZ)%*%ZZ/nrow(ZZ)) ll<-vector() for(i in 1:ncol(ZZ)) ll[i]<-sum(dnorm(ZZ[,i],mean=0,sd=sqrt(vars[i]),log=TRUE)) sum(ll) } logL<-sapply(trees,lik.edge,XX=X) if(plot){ ll<-logL[2:length(logL)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(logL[2:length(logL)],1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } edge<-ee[which(logL==max(logL))] } lik.tree<-function(position,tip,tree,edge,XX,rt){ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge) else tree<-bind.tip(tree,tip,where=edge,position=position) tree<-multi2di(tree) YY<-apply(XX,2,pic,phy=tree,scaled=FALSE) vcv<-t(YY)%*%YY/nrow(YY) sum(dmnorm(YY,mean=rep(0,ncol(YY)),varcov=vcv,log=TRUE)) } if(search=="heuristic"){ ee<-edge if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent")) if(edge>length(tree$tip.label)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2]) } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2]) ee<-intersect(ee,constraint) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE) else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE) } logL<-sapply(fit,function(x) x$objective) if(search=="exhaustive"&&plot){ ll<-sapply(fit,function(x) x$objective) ll<-ll[2:length(ll)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(ll,1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } fit<-fit[[which(logL==max(logL))]] edge<-ee[which(logL==max(logL))] mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum) mltree$logL<-fit$objective if(!quiet) cat("Done.\n") mltree } phytools/MD50000644000176200001440000003307213202062445012446 0ustar liggesusers9f322e8fa0139b3d2e887bb8beca2efb *DESCRIPTION e3ee557853b528a3957d56f1b4a079d0 *NAMESPACE ee8f279c7051fd15e5f3b69a78b13d42 *R/add.everywhere.R 00125e455cd6c2a9a162f414c82b31d3 *R/add.random.R 30f5b1a58539aec4b00e952018bed1d8 *R/add.species.to.genus.R f0df86c98d2fd0c6d76f49ca3172d129 *R/allFurcTrees.R f1b04dd672234dbaa538ed81128c98d4 *R/anc.Bayes.R c6db742b446f38c7c86504917f38272a *R/anc.ML.R 227c5163b6303989b36dbe9d50a7f53b *R/anc.trend.R c55f0fece713fbc45b33079be15116c0 *R/ancThresh.R bc3139a0d0a2b4bef405deaae471973c *R/backbonePhylo.R 407a8eda9599282efeb717410e2028f2 *R/bd.R 403f6c3609b1b82650665a0a04eeba87 *R/bmPlot.R 97f2cdd07a3595bb221fe3e8618e23c6 *R/branching.diffusion.R 6e14486536afe403240be0ac32bb55e3 *R/brownie.lite.R ffdd534a6c94d07b4ce58c7ae23c3a12 *R/brownieREML.R 23041be17a8649500816f415c7be2308 *R/collapseTree.R 1001c3a0359677faf03cd3912d5aacd5 *R/compare.chronograms.R be284dbd922c8e640b06f22aeea30eb6 *R/consensus.edges.R 68a21244d41c2e62759f84fdef32eb10 *R/contMap.R 6d0a63f22957b3ac4ff7e52bc54d1dd2 *R/cophylo.R ece9154811c9dafff59917deb9acab13 *R/cospeciation.R 3792931067053330a2d723861a43c40f *R/densityMap.R 41e1a34a8e376e9811df795dd5c7552e *R/densityTree.R 285cba23251473079aca3438e0f2ae00 *R/dotTree.R 69b6d14462faeaf904236868259f6e7c *R/drop.tip.simmap.R 00b980b1a6af6880330cfb00cb9b2282 *R/estDiversity.R 1c597d646176b3277a8b0b231f791ca2 *R/evol.rate.mcmc.R 868cab31eaeca1f3cf672e02fa12367a *R/evol.vcv.R 7fce29a2380742242da78258aebc5835 *R/evolvcv.lite.R 164c5aba763c4823fae1a2747cbbdde8 *R/exhaustiveMP.R 0c94431c709b011b1a19a5238b7a3352 *R/export.as.xml.R 9350aabf7ef37f0106accab137eca290 *R/fancyTree.R 3de0353dd6102f6b93a69edbabd14a30 *R/fastAnc.R 1fb690b492fa00b02e86eaf49b5e48b6 *R/fastBM.R fd4043fe4370b493b19344fc752bcdf5 *R/fitBayes.R 350a3fce5519e4b03cb5acfc01d2c55d *R/fitDiversityModel.R 236eb656a503c8c6cef2b6c476f9f647 *R/fitMk.R 2e794826087ce98675c88ac57b1afa53 *R/fitPagel.R 14efc2d387e2360f9f37721f7a6b77a6 *R/locate.fossil.R 36eed593b2ed2f89c1dfdb8d37bc047d *R/locate.yeti.R e41cd28e97c6101b3e0c7c4b955abb1a *R/ls.consensus.R bacc73c39e4d2b4149bd1795531aa6f9 *R/ltt.R e6f7e2cc99e35ae5f094ce4e2c5fe841 *R/ltt95.R 07c37a4c09941dfa8088c4eb91ef5c4a *R/make.era.map.R 19ae2b9108863abe6fe1bd661a69e19e *R/make.simmap.R b535cd4a22f407601477a0c787a8f869 *R/map.overlap.R 746ca01035baf52f94704cb916bd8e20 *R/map.to.singleton.R bf6c23b046ed30ee9e9183582aceb070 *R/mcmcBM.R 659b234e9ff4b00daa511a06f72d53d2 *R/mcmcBM.full.R 9fc1c1054aa693a9ad32044d21e9f8c4 *R/mcmcLambda.R fc4256396ce1f5ddb507ba23411de327 *R/mrp.supertree.R 7e33687b42d9ee02d52ae36834f4c122 *R/multi.mantel.R b0a7ce4dbb6e426d2aa1315c30ea9ce8 *R/multiRF.R 861e9b7abaf0ae0ec1c712b1176b2bc6 *R/optim.phylo.ls.R 4251fbfa33b24cedd655a575878bee3a *R/paintSubTree.R e9e01ad2df33334424ddb0453603c336 *R/pbtree.R 6f36e57da63ae80801b696355963c55d *R/pgls.Ives.R 0a3f71e1a3714c0fc5ed5fce53b9aa54 *R/phenogram.R 93cdbb83a29c009a6381af932cb78b87 *R/phyl.RMA.R 3cbec3ddb43718bf824e1b4b5b1bb92b *R/phyl.cca.R bd4da491297a9551360b5b0f361bbee1 *R/phyl.pairedttest.R f489cc46a3084533493e7d2dff93472e *R/phyl.pca.R 17d0e8f613fafc8cf7e0a719120dd9cd *R/phyl.resid.R 9265547de9fc901a0e0af7d58706b142 *R/phylANOVA.R 5f9b57848acd0490c9c4842be5d1e1be *R/phylo.heatmap.R f3265e161476c0c2640a416e22ca388e *R/phylo.to.map.R 153f94b487776dcbe9423b5507b324a0 *R/phylomorphospace.R 808ecaff96a106ea4656b73469c0324e *R/phylomorphospace3d.R 88e81eb2a2b9844e2694fb586524bfd8 *R/phylosig.R e33f55e3b5f7397f8c40678aee95569a *R/plotBranchbyTrait.R 6aed422c3ef54dd7180e45bd400245f0 *R/plotSimmap.R a58e6ab65dca2e69dde3266c9d05e51e *R/plotTree.errorbars.R 381d0fdc229e41ed1ba89d9b6c0d7da5 *R/plotTree.wBars.R e7561a8816b5c347add2e44718311157 *R/ratebystate.R 7261be7cfca4d3837fede235a02c66d7 *R/ratebytree.R 5f808f6878e031af61d4042b0dcbcb5e *R/rateshift.R 10aa4276f62187281eaa23d509df6f58 *R/read.newick.R 8d676810a59c68f20f5fc37bfe9b841a *R/read.simmap.R 12ccdaef8c21e222bfbe7f946de5514b *R/rerootingMethod.R ba26eefe861f14105c46ee13652c5b66 *R/resolveNodes.R 9bb4ea1e15eaeba8b3ea0f4ffc3c9255 *R/roundPhylogram.R d8a6bb753f6779a1dd49e769b18775a0 *R/sim.corrs.R d697c6e91f3041682671cb5f8db8818d *R/sim.history.R f83f44a29df59f5ff489e0120c4c328b *R/sim.rates.R 5ae6a2a091d203ecc04ad6081e11293d *R/skewers.R 606ad5a902660277dce5f3ef7fed7461 *R/splitplotTree.R c8bfa07dd3238d97fcaafe5a369e5e89 *R/starTree.R 0567456c325cbac2c305158ffa05df91 *R/strahlerNumber.R 447734ac15b7770e5024af04220dcd1a *R/threshBayes.R 7e547545cd50de19581af1e1c179e967 *R/treeSlice.R c83cb56994fa6eaa102a870b5d005b08 *R/utilities.R 1b4554bf48441cd340449ea0360bcbb8 *R/write.simmap.R 67b049f3e083513ff41ab9ca2bd940b5 *R/writeAncestors.R 65bf87a538f44806311e8914317b242c *R/writeNexus.R 3ab25de6b1e5d2b15860347db6d973d5 *data/anoletree.rda 0eb3bef3466bd6d264c669571621c2d1 *inst/CITATION a42234316b9c07cea61f6dc37aa855e1 *man/add.arrow.Rd 77fe3499abcd34af02fc571931597b79 *man/add.color.bar.Rd 4c61574818477466c1e568cc917535b5 *man/add.everywhere.Rd 0dad38ab36dfc6171120c7a224f7532a *man/add.random.Rd 54b5cce6e4c6f9cdcce89a82bdc7da36 *man/add.simmap.legend.Rd 107516e7cc218b2ac851551a122b720d *man/add.species.to.genus.Rd fa8cb1ee2a166a10032c51b707478324 *man/aic.w.Rd ddbaa1f624e77bd0b5c8be0fb07b407a *man/allFurcTrees.Rd 85936328bf79f82b91cf3bc471435be1 *man/anc.Bayes.Rd f939ffa214d08b6d1b92a2f90ea5112a *man/anc.ML.Rd 42b510e0e3d422a7f6444f6714ccb36b *man/anc.trend.Rd 9ac79b1dc9310be258548c6e8920fa2a *man/ancThresh.Rd 9ee43b3984459b93625cb3171605821e *man/anoletree.Rd 5401106ec92900c68ed09e53a5b07d3c *man/applyBranchLengths.Rd 9438d11405f55849b8b13173e0aa677f *man/as.multiPhylo.Rd 3e59cf4772028c0afc738956ca2d9d72 *man/ave.rates.Rd 68be8a968b68910972815c5e610818cd *man/averageTree.Rd 4c391c3b9f17f1a0e0c8c2bd04da9048 *man/bd.Rd af6f23faf7f0ecb3c466875b900379aa *man/bind.tip.Rd 03055c413de00dafb1073b21281d165a *man/bind.tree.simmap.Rd cc14a92f9406c1cd8e2ad5204bdd226f *man/bmPlot.Rd af944211704ace15627339af01988499 *man/branching.diffusion.Rd 824377a34400a62869f6a0ed1d86c52d *man/brownie.lite.Rd f2d030a482fbf47b134a82612b7817e7 *man/brownieREML.Rd abeb701a5213e15d9e24816563654492 *man/cladelabels.Rd 0f1e1addf1457ffa1a6a2241b516f2aa *man/collapse.to.star.Rd d860a425bca88fdba3651f80d5100fee *man/collapseTree.Rd 987d8540202b55e971529542f2b12f5a *man/compare.chronograms.Rd 8134029f04090ff83a7a8d4b3b92da56 *man/consensus.edges.Rd c26dcd996d2c5d86a8cfb43206921fe4 *man/contMap.Rd b92e5d59971e2644948b3144e42ca05e *man/cophylo.Rd 317b82dc60100850b36380cbc1bc0414 *man/cospeciation.Rd 1c53948802e8f694b01440e03a198dbb *man/countSimmap.Rd 44b463769214182e756294911bf65ff9 *man/density.multiSimmap.Rd 473862be45bc652c0389ec2c0754f473 *man/densityMap.Rd e37396af91b60fbd5d4761e632d6d230 *man/densityTree.Rd ae007bd9a1d1e3eb349e739bd3fd5bbc *man/describe.simmap.Rd 22a091511c91853a24929280592e3151 *man/di2multi.simmap.Rd fa1a86c9c436d6a78de5a5762d0f81fe *man/dotTree.Rd c92235efc1cf6791a2871a0b59bf94b1 *man/drop.clade.Rd 139cf35fd81a07386ea5489a3c8a549e *man/drop.leaves.Rd 4dbacec8bf2b24739708948c5c6f2251 *man/drop.tip.contMap.Rd 0f4c4d6f030921fe8f033e54a5ba2226 *man/drop.tip.simmap.Rd ddcd0b3224754d09a211b6e3e8514819 *man/edgeProbs.Rd 6c00e1009e2f8fb0684f9169cc4347ab *man/estDiversity.Rd 925393ffab907bc5693992d93bddcbbb *man/evol.rate.mcmc.Rd 540e9f4aa0ce27faeed1f4a7945749c1 *man/evol.vcv.Rd 766f946ebf98e312547c576d5412d0d2 *man/evolvcv.lite.Rd e93d92ff11f1f830540896a8129603e8 *man/exhaustiveMP.Rd 45729cc9dfdd0f4f158b82aba2e35797 *man/expand.clade.Rd 22001f60bdc699b30ab0250e61eb879d *man/expm.Rd 24fbe29405d7d63b20381cbe63c3685f *man/export.as.xml.Rd 60822881cc6b40b5d764d1fe26bfefba *man/fancyTree.Rd a175a7386cec6984d78031de56350d55 *man/fastAnc.Rd 4b4c57d045a77d6038356712712083d6 *man/fastBM.Rd 8054a9de57c13610d28e3e832b9aea91 *man/fastMRCA.Rd 2aecfd3a3e42ff5a6187e142af8bfe90 *man/findMRCA.Rd 9d730cf1622b491b3712bdd3d857f8cb *man/fit.bd.Rd 49ed43ad08cbd76688cea935958535d2 *man/fitBayes.Rd fd6dfbcd9836f3d550d058f2946c4fc9 *man/fitDiversityModel.Rd b4eb17f4a35656aaf0b7d5c0b85cce84 *man/fitMk.Rd bea2ad13789c51fcb577038d9319a4aa *man/fitPagel.Rd e292601c1c799d10f98b7b34608592e2 *man/force.ultrametric.Rd 0fb00f64019835a6cf7d510df62c1cc1 *man/gammatest.Rd 88ad5870c14512c74ed6c88688cb9367 *man/genSeq.Rd ce2d83c87228d4d36e5d3793841f9968 *man/geo.legend.Rd 5a4045e1e1a45a93828388e5619da248 *man/get.treepos.Rd 6ca10ad3d8ae7823a3ebebeaaa903a26 *man/getCladesofSize.Rd c0c1d5e26dc66625ca962d1b1a9e3fb1 *man/getDescendants.Rd 0f66e89c8d5de9f7906cfc629dbde129 *man/getExtant.Rd bb47201dbb86e33244d79ed06b53bace *man/getSisters.Rd 50941930ec6026a6fb9b0020a7e9e3e3 *man/getStates.Rd 8b8dc22bbb4f27f8643c92132893220f *man/labelnodes.Rd 882bbf621c5c8e6c0922c21cf5308d67 *man/ladderize.simmap.Rd c2a04357ebedc51867f98d3e24ef0d66 *man/lambda.transform.Rd 633387cd5519193a2e183285e7e4fb79 *man/likMlambda.Rd 6f8d9fe13ce8560d4e1dcfcabceb0cd9 *man/linklabels.Rd 3149b5b7a824f424f799ab3e522d6850 *man/locate.fossil.Rd d274dca0554874d3a3476906e281093a *man/locate.yeti.Rd a09a3cd5616557bd09ba88e990addd40 *man/ls.tree.Rd 164517a355a60693d56b4ba8e52ccb18 *man/ltt.Rd c8a084cfa70fc7ac4d490f417464f366 *man/ltt95.Rd 6d740cef8fb4052ed7f5bbcfa2a04ff5 *man/make.era.map.Rd 96d5c8d0131da1b48028859c2a466ac2 *man/make.simmap.Rd be50a7f1d10a39f31540435c910608f4 *man/map.overlap.Rd 24dd9c40965fe5929fc5f43392ff7111 *man/map.to.singleton.Rd 7bc0bf4a400013d8506a144b98663d09 *man/mapped.states.Rd f9c95d7c4652d4817305122c51ceb3ce *man/markChanges.Rd 9327c748a5fc71e19d97b336959cea8e *man/matchNodes.Rd e566946585ec51d6df130403eac7b996 *man/mergeMappedStates.Rd b0292289c5c0bdea68bd39cba4e51fcb *man/midpoint.root.Rd f440b9606b045b5ccf5466afe4c30ca2 *man/minRotate.Rd d3a51d0c0191486546c6c67e9456b0a5 *man/minSplit.Rd 434ad8f86e0b41f3078f91a33ab2370d *man/modified.Grafen.Rd 8fd67c7bee19ff3ec51d70d15811f15a *man/mrp.supertree.Rd 73a2a40506cc9e62da97a20c7e74a1b8 *man/multi.mantel.Rd 5caa16465c09c6c2840f712fab95d08e *man/multiC.Rd 3c941d1cbd831b77c07e82845a0bff29 *man/multiRF.Rd 771381f4158bb262fd0a9c7df8c33508 *man/nodeHeights.Rd b8061afef967e33d70e5646761eea00e *man/nodelabels.cophylo.Rd ee79b7944822d46d87eaf91cae11d477 *man/optim.phylo.ls.Rd 63d57fedac44429aea25ebf22f53c772 *man/orderMappedEdge.Rd 342aa020929fb830ffbfb869be45a526 *man/paintSubTree.Rd 4aec9a1fefe5f96ac6652a0e5fcc63eb *man/paste.tree.Rd f5c03b1a3eeba0ee10d31e06c0dbae64 *man/pbtree.Rd 15b7eb28339e9434bd8fcf3e493d943d *man/pgls.Ives.Rd 735e181c4a63b8a7888a137a6f08c163 *man/phenogram.Rd f333aaf7288b2a3a7bba9fdb23c41f74 *man/phyl.RMA.Rd 3d17ac3e055a980bca3c14b258fa47ec *man/phyl.cca.Rd 804ec3000422b5f2e1f30d80f114b8b2 *man/phyl.pairedttest.Rd ce49878deb460e417a875e63b45e25b7 *man/phyl.pca.Rd 38cdeda5e6c9e2cc9a3131ef1ee321ba *man/phyl.resid.Rd 2f54dd0b2b5ce5d36193c97b1a611921 *man/phyl.vcv.Rd 31064c35f9f1f368c0bd38c3e2a009dd *man/phylANOVA.Rd b816f2e3fac3e259d0f1f57baf626678 *man/phylo.heatmap.Rd a5d27821336d48d6dc44595026f0994e *man/phylo.to.map.Rd 929da1bd71e71af5ce25243d9516c14e *man/phylo.toBackbone.Rd 3a1b3861ce38f29feca5081c7acc4908 *man/phyloDesign.Rd a1f7f9d8cdd43c5872156128d1596294 *man/phylomorphospace.Rd b82dd727b2a6717a6fefab297a491ab3 *man/phylomorphospace3d.Rd 18a569e5bf535e689d85ded39eb166a6 *man/phylosig.Rd b1215539c6b3d560e8b0782d290197cc *man/phytools-package.Rd aecc4ccca42174f15c6280dbb5aa13fe *man/plot.backbonePhylo.Rd 674746269036e9bf5645e31bab29207e *man/plotBranchbyTrait.Rd cf7911a80ce4148ea610f1b9105a104f *man/plotSimmap.Rd b36ef27480457d0dc3f32c490e997a7d *man/plotThresh.Rd 7abaec7aa366e41647df0bf3073a36ef *man/plotTree.Rd 028fb0ca902c0cf9ffcdc47ad85da56e *man/plotTree.errorbars.Rd 41e493dcd031566263d3208834f882b8 *man/plotTree.wBars.Rd 9c8297109561037f067dd7d469f12acb *man/posterior.evolrate.Rd 9f409f4328ac4802d1700eec2233361b *man/posthoc.Rd 4bfa72a7ac47c3e185164f8c35dd5e13 *man/print.backbonePhylo.Rd 290d33851c41fa14071fbf4a03fdab8c *man/ratebystate.Rd ae9589a66cf69dfa1cae3434abcb7082 *man/ratebytree.Rd 1ec56f1e5610a932300c356e7b1242d1 *man/rateshift.Rd 83b256d15cc236468fc5a08c4c99e411 *man/read.newick.Rd 6cc642b69b90cc39e37a97e90792dc0f *man/read.simmap.Rd 0a719edd23de05fb878911f9cf05367e *man/reorder.backbonePhylo.Rd 1b9465c231435640da167fc86f10de30 *man/reorderSimmap.Rd 66b1bb2aaeca6af053fd7102d51bc93f *man/rep.phylo.Rd 3af87269dc3bca7472fdba1c179cbdba *man/reroot.Rd a78caf77645c2aee01642551aa4cffab *man/rerootingMethod.Rd 7fb2034ee0d06ddd28baf54a19a5df31 *man/rescaleSimmap.Rd e136bc897dd8258ec0038da1fda579aa *man/resolveNode.Rd e1d563fcfc4085113c43b6191046463f *man/rotateNodes.Rd 62ccf8e731d76584828667850f3e4d5c *man/roundBranches.Rd 113dfd2e24ee88ec929f865a41b014ee *man/roundPhylogram.Rd 582c0539a965268cb3783ec1cfc69341 *man/rstate.Rd 56d1e0ab7594a041e03a96cf512b7c56 *man/sampleFrom.Rd 4ff599d27cce8dd9f6a61b1b83167c36 *man/setMap.Rd cdb9901fa0e51ebb9ede03b79d569d43 *man/sim.corrs.Rd 41192c407722bf7018c3b90750b84e1a *man/sim.history.Rd d4619609a325632ef2c834f485c505b0 *man/sim.ratebystate.Rd 246a5aaa7168a0ff7cc9168d4395d4b5 *man/sim.rates.Rd e0716598bfe6497b75aac3a5de7d1d1a *man/skewers.Rd 8afbcc3a0809d9abc1337996402b395f *man/splitEdgeColor.Rd f0b7c55fe94d87a63fcc473557ba356c *man/splitTree.Rd c4c25d51cb5afc0a3ca9e8c50aa4f8a5 *man/splitplotTree.Rd e3ebd622b81458023c71dc8b846bc8bc *man/starTree.Rd e3cb564ff8ac467e211b63893e5bd8ab *man/strahlerNumber.Rd 0b0799df20ba1704886813ac53e62843 *man/threshBayes.Rd 4c943bdc70f92faf2626a05b4dd5737a *man/threshDIC.Rd 1f469e57b425d3d1368c1b5a20f6677e *man/threshState.Rd 75b7d2745c01bd834c7b1b8523b9859e *man/to.matrix.Rd fd4b7e0ad5c598fbc1d33cd733a49164 *man/treeSlice.Rd 4f2a39ca94120586ad59463cc247bf83 *man/untangle.Rd 8698e88dd7441c86162d8ab4eddf3439 *man/vcvPhylo.Rd 58a800384eddd90f48ea26c6f515c1fb *man/write.simmap.Rd 9ae66799d04b136a287a1038d6f70fd7 *man/writeAncestors.Rd 81b95726f7c7c8b1308d35fc5a9e9d2e *man/writeNexus.Rd phytools/DESCRIPTION0000644000176200001440000000364013202062445013642 0ustar liggesusersPackage: phytools Version: 0.6-44 Date: 2017-11-11 Title: Phylogenetic Tools for Comparative Biology (and Other Things) Author: Liam J. Revell Maintainer: Liam J. Revell Depends: R (>= 3.2.0), ape (>= 4.0), maps Imports: animation, clusterGeneration, coda, combinat, graphics, grDevices, MASS, methods, mnormt, msm, nlme, numDeriv, phangorn (>= 2.3.1), plotrix, scatterplot3d, stats, utils Suggests: geiger, rgl ZipData: no Description: A wide range of functions for phylogenetic analysis. Functionality is concentrated in phylogenetic comparative biology, but also includes a diverse array of methods for visualizing, manipulating, reading or writing, and even inferring phylogenetic trees and data. Included among the functions in phylogenetic comparative biology are various for ancestral state reconstruction, model-fitting, simulation of phylogenies and data, and multivariate analysis. There are a broad range of plotting methods for phylogenies and comparative data which include, but are not restricted to, methods for mapping trait evolution on trees, for projecting trees into phenotypic space or a geographic map, and for visualizing correlated speciation between trees. Finally, there are a number of functions for reading, writing, analyzing, inferring, simulating, and manipulating phylogenetic trees and comparative data not covered by other packages. For instance, there are functions for randomly or non-randomly attaching species or clades to a phylogeny, for estimating supertrees or consensus phylogenies from a set, for simulating trees and phylogenetic data under a range of models, and for a wide variety of other manipulations and analyses that phylogenetic biologists might find useful in their research. License: GPL (>= 2) URL: http://github.com/liamrevell/phytools Packaged: 2017-11-12 01:45:28 UTC; liamj Repository: CRAN Date/Publication: 2017-11-12 15:13:41 UTC NeedsCompilation: no phytools/man/0000755000176200001440000000000013201723663012711 5ustar liggesusersphytools/man/markChanges.Rd0000644000176200001440000000205212563202312015413 0ustar liggesusers\name{markChanges} \alias{markChanges} \title{Add marked changes to a plotted tree with mapped discrete character} \usage{ markChanges(tree, colors=NULL, cex=1, lwd=2, plot=TRUE) } \arguments{ \item{tree}{an object of class \code{"simmap"}.} \item{colors}{a named vector of colors used to plot the stochastically mapped character on the tree.} \item{cex}{expansion factor for line height.} \item{lwd}{line width.} \item{plot}{logical value indicating whether the changes should be plotted or not.} } \description{ This function adds the reconstructed changes to a plotted tree with a stochastically mapped discrete character. } \value{ This function returns (invisibly) a matrix containing the x & y coordinates of the marked changes. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/nodeHeights.Rd0000644000176200001440000000337612656150131015447 0ustar liggesusers\name{nodeHeights} \alias{nodeHeights} \alias{nodeheight} \title{Compute the heights above the root of each node} \usage{ nodeHeights(tree, ...) nodeheight(tree, node, ...) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{node}{for \code{nodeheight}, the node for which we want to compute a height above the root (or including the root edge, for \code{root.edge=TRUE}).} \item{...}{optional arguments - presently only \code{root.edge}, a logical value indicating whether or not to include the root edge length in the calculation of node heights.} } \description{ \code{nodeHeights} computes the height above the root for all nodes in the tree. \code{nodeheight} computes the height above the root for a single node. } \details{ The function \code{nodeHeights} also gives a handy way to get the total length of the tree from the root to the heighest tip which will be given by \code{max(nodeHeights(tree))}. Generally speaking, \code{nodeHeights} will be faster if the heights of all or a large proportion of nodes is needed, wherease \code{nodeheight} will be faster if the height of one or a small number of nodes are needed. } \value{ Either a matrix of the same dimensions as \code{tree$edge} containing the height above the root of each node in \code{edge} (for \code{nodeHeights}); or a single positive number (for \code{nodeheight}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{vcvPhylo}} } \examples{ tree<-rtree(10) X<-nodeHeights(tree) } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/posterior.evolrate.Rd0000644000176200001440000000277512147207406017061 0ustar liggesusers\name{posterior.evolrate} \alias{posterior.evolrate} \title{Analysis of the posterior sample from evol.rate.mcmc} \usage{ posterior.evolrate(tree, ave.shift, mcmc, tips, showTree=FALSE) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{ave.shift}{mean or median shift-point from the posterior sample (see \code{\link{minSplit}}.} \item{mcmc}{matrix \code{$mcmc} from \code{evol.rate.mcmc} (probably with burnin excluded).} \item{tips}{list of stips in state sig(1)^2 for each sampled generation of MCMC.} \item{showTree}{optional logical value indicating whether or not to plot the stretched and shrunken tree generated by the pre-processing algorithm implemented in this function (default is \code{FALSE}).} } \description{ This fucntion takes a phylogenetic tree, an average split position, and a raw MCMC output from \code{evol.rate.mcmc} and returns a posterior sample of evolutionary rates rootward (\eqn{\sigma(1)^2}) and tipward (\eqn{\sigma(2)^2}) from the average split. } \value{ A matrix containing the posterior sample of evolutionary rates and shift-points between rates. } \references{ Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/cophylo.Rd0000644000176200001440000000644313173402644014665 0ustar liggesusers\name{cophylo} \alias{cophylo} \alias{plot.cophylo} \title{Creates a co-phylogenetic plot} \usage{ cophylo(tr1, tr2, assoc=NULL, rotate=TRUE, ...) \method{plot}{cophylo}(x, ...) } \arguments{ \item{tr1}{object of class \code{"phylo"}.} \item{tr2}{object of class \code{"phylo"}.} \item{assoc}{matrix containing the tip labels in \code{tr1} to match to the tip labels in \code{tr2}. Note that not all labels in either tree need to be included; and, furthermore, one label in \code{tr1} can be matched with more than one label in \code{tr2}, or vice versa.} \item{rotate}{logical argument indicating whether nodes on both trees should be rotated to attempt to match in vertical position.} \item{x}{in the case of \code{plot.cophylo}, an object of class \code{"cophylo"} to be plotted.} \item{...}{optional arguments to be passed to \code{\link{tipRotate}}, or, in the case of \code{plot.cophylo}, to the internally used tree plotting function, \code{phylogram}. \code{phylogram} takes similar arguments to \code{\link{plotSimmap}}, such as \code{fsize}, \code{ftype}, \code{lwd}, and \code{pts}, though not all options from \code{plotSimmap} and \code{plotTree} are available. If \code{fsize} is supplied as a vector, different size fonts for the left & right facing trees may be used. In addition, the optional argument \code{scale.bar}, which should be a vector containing the lengths of the scale bars desired for the right & left trees, will add scale bars to the plot when supplied to \code{plot.cophylo}. If either tree contains polytomies, the \code{cophylo} argument \code{rotate.multi} should be set to \code{TRUE}. If curved linking lines are desired, the \code{plot.cophylo} argument \code{link.type} should be set to \code{"curved"}. Other arguments for the \code{plot} method include \code{link.col}, \code{link.lty}, and \code{link.lwd}, which can be supplied as a scalar or a vector in which the order of the elements corresponds to the order of the associations in \code{assoc}. Finally, \code{edge.col}, a list consisting of two vectors (\code{left} and \code{right}) can be used to specify the edge colors of the two left & right plotted trees. Note that the edge order is the same as in the \emph{rotated} trees, assuming that a rotation has been performed on \code{x}.} } \description{ This function creates an object of class \code{"cophylo"} or, in the case of \code{plot.cophylo}, plots that object. The function can (optionally) first attempt to rotate the nodes of both trees to optimize vertical matching of tips. } \details{ If no matrix of associations, \code{assoc}, is provided, then \code{cophylo} will look for exact matches of tip labels between trees. } \value{ An object of class \code{"cophylo"} which includes the following components or a pair of plotted facing phylogenies with links between tips as specified in \code{assoc}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophyloplot}}, \code{\link{plotSimmap}} } \examples{ tr1<-pbtree(n=26,tip.label=LETTERS) tr2<-pbtree(n=26,tip.label=sample(LETTERS)) obj<-cophylo(tr1,tr2) plot(obj) } \keyword{phylogenetics} \keyword{plotting} phytools/man/expand.clade.Rd0000644000176200001440000000302513115121314015513 0ustar liggesusers\name{expand.clade} \alias{expand.clade} \alias{plot.expand.clade} \title{Expands (or contracts) the tip-spacing of a given clade or clades} \usage{ expand.clade(tree, node, factor=5) \method{plot}{expand.clade}(x, ...) } \arguments{ \item{tree}{tree an object of class \code{"phylo"} or \code{"simmap"}.} \item{node}{node index or vector of node indices.} \item{factor}{expansion factor for the tip-spacing of the taxa descended from node or nodes in \code{node}.} \item{x}{for \code{plot} method, an object of class \code{"expand.clade"}.} \item{...}{optional arguments to be passed to \code{plotTree} or \code{plotSimmap}, depending on the class of \code{x$tree}.} } \description{ The purpose of this function is to compute a custom tip-spacing for users who want to expand or contract the tip-spacing of the descendant taxa from a given node or nodes. } \value{ The function returns an object of class \code{"expand.clade"} which consists of the (possibly re-ordered) tree and a numerical vector with the calculated tip spacing based on the expansion factor specified by the user. This object can be plotted using the S3 \code{plot} method for the object class; or it can be plotted simplying by calling a standard plotting function on the tree & tip spacings. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/brownie.lite.Rd0000644000176200001440000000646113066526546015622 0ustar liggesusers\name{brownie.lite} \alias{brownie.lite} \title{Likelihood test for rate variation in a continuous trait} \usage{ brownie.lite(tree, x, maxit=2000, test="chisq", nsim=100, se=NULL, ...) } \arguments{ \item{tree}{a phylogenetic tree in modified \code{"phylo"} format (see \code{\link{read.simmap}}, \code{\link{make.simmap}}, or \code{\link{paintSubTree}}).} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{test}{an optional string indicating the method for hypothesis testing - options are \code{"chisq"} or \code{"simulation"}.} \item{nsim}{number of simulations (only used if \code{test="simulation"}).} \item{se}{a vector containing the standard errors for each estimated mean in \code{x}.} \item{...}{optional arguments.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then fits the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This is also the basic model implemented in Brian O'Meara's \emph{Brownie} software. } \details{ Sampling error in the estimation of species means can also be accounted for by assigning the vector \code{se} with the species specific sampling errors for \code{x}. } \value{ An object of class \code{"brownie.lite"} containing the following components: \item{sig2.single}{is the rate for a single rate model - this is usually the "null" model.} \item{a.single}{is the estimated state at the root node for the single rate model.} \item{var.single}{variance on the single rate estimator - obtained from the Hessian.} \item{logL1}{log-likelihood of the single-rate model.} \item{k1}{number of parameters in the single rate model (always 2).} \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates from the multi-rate model.} \item{a.multiple}{is the estimated state at the root node for the multi-rate model.} \item{var.multiple}{\emph{p} x \emph{p} variance-covariance matrix for the \emph{p} rates - the square-roots of the diagonals should give the standard error for each rate.} \item{logL.multiple}{log-likelihood of the multi-rate model.} \item{k2}{number of parameters in the multi-rate model (\emph{p}+1).} \item{P.chisq}{P-value for a likelihood ratio test against the \eqn{\chi^2} distribution; or} \item{P.sim}{P-value for a likelihood ratio test agains a simulated null distribution.} \item{convergence}{logical value indicating if the likelihood optimization converged.} } \references{ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922--933. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownieREML}}, \code{\link{evol.vcv}}, \code{\link{ratebytree}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/add.simmap.legend.Rd0000644000176200001440000000257612464424310016461 0ustar liggesusers\name{add.simmap.legend} \alias{add.simmap.legend} \title{Add legend to stochastically mapped tree} \usage{ add.simmap.legend(leg=NULL, colors, prompt=TRUE, vertical=TRUE, ...) } \arguments{ \item{leg}{states for the discrete character in the order of \code{colors}.} \item{colors}{colors for the legend in the order of \code{leg}, or, if \code{leg=NULL}, named vector of colors in which \code{names(colors} are the states of the mapped discrete character.} \item{prompt}{logical value indicating whether the location of the legend should be obtained interactively (i.e., by clicking in the plotting area).} \item{vertical}{logical value indiciating whether to plot the legend vertically (if \code{TRUE}) or horizontally.} \item{...}{optional arguments including: \code{x} x-coordinate of the legend (if \code{prompt=FALSE}); \code{y} y-coordinate of the legend; and \code{shape} which can be \code{shape="square"}, the default, or \code{shape="circle"}.} } \description{ This function adds a legend (by default, interactively) to a plotted stochastic character mapped tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/ave.rates.Rd0000644000176200001440000000173612464424722015103 0ustar liggesusers\name{ave.rates} \alias{ave.rates} \title{Average the posterior rates} \usage{ ave.rates(tree, shift, tips, sig1, sig2, ave.shift, showTree=TRUE) } \arguments{ \item{tree}{a tree.} \item{shift}{the shift point for this sample.} \item{tips}{tip names tipward of \code{shift}.} \item{sig1}{rate 1.} \item{sig2}{rate 2.} \item{ave.shift}{average shift from all samples.} \item{showTree}{logical value indicating whether to plot the rate-stretched tree.} } \description{ Primarily used internally by \code{\link{posterior.evolrate}}. } \value{ A list of the rates. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/anc.Bayes.Rd0000644000176200001440000000500513201673647015011 0ustar liggesusers\name{anc.Bayes} \alias{anc.Bayes} \title{Bayesian ancestral character estimation} \usage{ anc.Bayes(tree, x, ngen=10000, control=list()) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{a}: starting for the state at the root node; \code{y}: starting values for the states at all internal nodes excluding the root (should be labeled with node numbers); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{a}, \code{y}, note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean} (but the variance is not used for \code{sig2}); \code{prop}: variances on the normal proposal distributions in the same order as \code{pr.mean}; \code{sample}: sample frequency from the MCMC.} } \description{ This function uses Bayesian MCMC to sample from the posterior distribution for the states at internal nodes in the tree. } \value{ An object of class \code{"anc.Bayes"} including at least two components: \item{mcmc}{a data frame with rows \code{ngen/sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled either \code{sig2} or by the node number of the internal node.} \item{tree}{our input phylogeny.} } \details{ The \code{print} method also returns (invisibly) a vector of estimated ancestral states based on a user-supplied burn-in (or 20% of the number of generations of MCMC, if no burn-in is provided). The object class \code{plot} method by default plots a likelihood profile from the MCMC. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.ML}}, \code{\link{anc.trend}}, \code{\link{evol.rate.mcmc}}, \code{\link{fastAnc}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree,sig2=2) # simulate using fastBM obj<-anc.Bayes(tree,x,ngen=10000) # sample ancestral states print(obj,printlen=20) ## estimates } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/phylANOVA.Rd0000644000176200001440000000406313201657415014745 0ustar liggesusers\name{phylANOVA} \alias{phylANOVA} \title{Phylogenetic ANOVA and post-hoc tests} \usage{ phylANOVA(tree, x, y, nsim=1000, posthoc=TRUE, p.adj="holm") } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{a vector containing the groups.} \item{y}{a vector containing the response variable (continuously valued).} \item{nsim}{an integer specifying the number of simulations (including the observed data).} \item{posthoc}{a logical value indicating whether or not to conduct posthoc tests to compare the mean among groups.} \item{p.adj}{method to adjust P-values for the posthoc tests to account for multiple testing. Options same as \code{\link{p.adjust}}.} } \description{ This function performs the simulation-based phylogenetic ANOVA of Garland et al. (1993) and (optionally) conducts all posthoc comparisons of means among groups (also obtaining the P-values by phylogenetic simulation). } \details{ Uses a little bit of code from \code{phy.anova} in the "geiger" package as well as \code{\link{pairwise.t.test}}. } \value{ An object of class \code{"phylANOVA"} containing the following elements: \item{F}{F from observed data.} \item{Pf}{P-value for F from simulation.} \item{T}{matrix of t-values.} \item{Pt}{matrix of multiple test corrected P-values from posthoc t-tests.} } \references{ Garland, T., Jr., A. W. Dickerman, C. M. Janis, & J. A. Jones. (1993) Phylogenetic analysis of covariance by computer simulation. \emph{Systematic Biology}, \bold{42}, 265-292. Harmon, L. J., J. T. Weir, C. D. Brock, R. E. Glor, W. Challenger. (2008) GEIGER: investigating evolutionary radiations. \emph{Bioinformatics}, 24, 129-131. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anova}}, \code{\link{pairwise.t.test}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{simulation} phytools/man/paste.tree.Rd0000644000176200001440000000152012464432435015254 0ustar liggesusers\name{paste.tree} \alias{paste.tree} \title{Paste two trees together} \usage{ paste.tree(tr1, tr2) } \arguments{ \item{tr1}{receptor tree.} \item{tr2}{donor clade.} } \description{ Primarily internal function for \code{\link{posterior.evolrate}}; can be used to graft a clade into a receptor tree, at the "sticky tip" labeled with \code{"NA"}. } \details{ The donor clade needs to have a root edge, even if it is zero length. } \value{ A tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tr1<-rtree(10) tr2<-rtree(10) tr1$tip.label[1]<-"NA" tr2$root.edge<-0 tr3<-paste.tree(tr1,tr2) } \keyword{phylogenetics} \keyword{utilities} phytools/man/branching.diffusion.Rd0000644000176200001440000000252313066526257017133 0ustar liggesusers\name{branching.diffusion} \alias{branching.diffusion} \title{Animation of branching random diffusion} \usage{ branching.diffusion(sig2=1, b=0.0023, time.stop=1000, ylim=NULL, smooth=TRUE, pause=0.02, record=NULL, path=NULL) } \arguments{ \item{sig2}{variance of BM process.} \item{b}{birthrate for branching process.} \item{time.stop}{number of generations to run.} \item{ylim}{y limits (for plotting).} \item{smooth}{no longer used.} \item{pause}{pause (in s) between generations.} \item{record}{filename for video file output (no video if \code{NULL}).} \item{path}{full path to file for video rendering (by default is \code{C:/Program Files/ffmpeg/bin/ffmpeg.exe}).} } \description{ This function creates an animation of branching random diffusion (i.e., BM with speciation). } \value{ An animated plot and (optionally) a recorded video file. For animation to be recorded to file, the function requires the package "animation" as well as a video renderer. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{bmPlot}}, \code{\link{fastBM}} } \keyword{phylogenetics} \keyword{animation} \keyword{plotting} \keyword{simulation} phytools/man/fitDiversityModel.Rd0000644000176200001440000000370612464426200016651 0ustar liggesusers\name{fitDiversityModel} \alias{fitDiversityModel} \title{Fit diversity-dependent phenotypic evolution model} \usage{ fitDiversityModel(tree, x, d=NULL, showTree=TRUE, tol=1e-6) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector with tip values for a continuously distributed trait.} \item{d}{a vector containing the inferred historical diversity at each node in the tree - if \code{d=NULL} (the default) function will treat the diversification as if it occurred in a single geographic area.} \item{showTree}{optional logical value indicating whether to plot the tree transformation implied by the model.} \item{tol}{some small value by which \code{d} is incremented during rescaling of \code{psi} for optimization. If R thinks your matrices are singular during optimization, try increasing \code{tol} slightly.} } \description{ This function fits a diversity-dependent phenotypic evolution model (based on Mahler et al. 2010). } \value{ A list with the following components: \item{logL}{log-likelihood of the fitted model.} \item{sig0}{estimated starting value for the rate at the root of the tree.} \item{psi}{the estimated rate of change in the rate associated with the addition of a lineage.} \item{vcv}{a matrix with the variances and covariance of the estimated parameters (from the Hessian).} } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. 2010. Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{estDiversity}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/getCladesofSize.Rd0000644000176200001440000000146412464426315016264 0ustar liggesusers\name{getCladesofSize} \alias{getCladesofSize} \title{Get all subtrees larger than or equal to a specified size} \usage{ getCladesofSize(tree, clade.size=2) } \arguments{ \item{tree}{is an object of class \code{"phylo"}.} \item{clade.size}{subtree size.} } \description{ This function gets all subtrees that cannot be further subdivided into two reciprocally monophyletic subtrees of size \code{>= clade.size}. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}}, \code{\link{getDescendants}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/get.treepos.Rd0000644000176200001440000000111413053071604015430 0ustar liggesusers\name{get.treepos} \alias{get.treepos} \alias{getnode} \title{Internal functions} \usage{ get.treepos(message=TRUE, ...) getnode(...) } \arguments{ \item{message}{argument.} \item{...}{optional arguments.} } \description{ Internally used function. } \value{ A list for \code{get.treepos} and a node number for \code{getnode}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/evol.rate.mcmc.Rd0000644000176200001440000000470613201660601016014 0ustar liggesusers\name{evol.rate.mcmc} \alias{evol.rate.mcmc} \title{Bayesian MCMC method for identifying exceptional phenotypic diversification in a phylogeny} \usage{ evol.rate.mcmc(tree, x, ngen=10000, control=list(), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{ngen}{an optional integer value indicating the number of generations for the MCMC.} \item{control}{a list of control parameters containing the following elements: \code{sig1}: starting value for \eqn{\sigma(1)^2}; \code{sig2}: starting value for \eqn{\sigma(2)^2}; \code{a}: starting value for a; \code{sd1}: standard deviation for the normal proposal distribution for \eqn{\sigma(1)^2}; \code{sd2}: standard deviation for the normal proposal distribution for \eqn{\sigma(2)^2}; \code{kloc}: scaling parameter for tree move proposals - \eqn{1/\lambda} for the reflected exponential distribution; \code{sdlnr}: standard deviation on the log-normal prior on \eqn{\sigma(1)^2/\sigma(2)^2}; \code{rand.shift}: probability of proposing a random shift in the tree (improves mixing); \code{print}: print frequency for the MCMC; \code{sample}: sample frequency.} \item{...}{other optional arguments.} } \description{ This function takes a phylogenetic tree and data for a single continuously valued character and uses a Bayesian MCMC approach to identify the phylogenetic location of a shift in the evolutionary rate through time. } \details{ Default values of \code{control} are given in Revell et al. (2012). } \value{ An object of class \code{"evol.rate.mcmc"} consisting of at least the following elements: \item{mcmc}{results from the MCMC run.} \item{tips}{list of stips in rate \eqn{\sigma(1)^2} for each sampled generation of MCMC (to polarize the rate shift).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings. (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/cospeciation.Rd0000644000176200001440000000375113066527020015664 0ustar liggesusers\name{cospeciation} \alias{cospeciation} \alias{plot.cospeciation} \alias{print.cospeciation} \title{Conducts a statistical test of cospeciation between two trees} \usage{ cospeciation(t1, t2, distance=c("RF","SPR"), method=c("simulation","permutation"), assoc=NULL, nsim=100, ...) \method{plot}{cospeciation}(x, ...) \method{print}{cospeciation}(x, ...) } \arguments{ \item{t1}{object of class \code{"phylo"}.} \item{t2}{object of class \code{"phylo"}.} \item{distance}{distance method to compare trees.} \item{method}{method to use (simulation of pure-birth trees, or permutation of tip labels on a fixed tree) to obtain a null distribution of tree distances via \code{distance}.} \item{assoc}{matrix containing the tip labels in \code{t1} to match to the tip labels in \code{t2}. Note that not all labels in either tree need to be included; however, unlike \code{cophylo}, one label in \code{t1} cannot be matched with more than one label in \code{t2}, nor vice versa. If \code{NULL} then an exact match of tip labels will be sought.} \item{nsim}{number of simulations or permutations.} \item{x}{for \code{plot} and \code{print} methods, an object of class \code{"cospeciation"}.} \item{...}{optional arguments.} } \description{ This function conducts a test for cospeciation based on tree distance, applying a distance metric selected by the user. Note that this method should be prone to be quite liberal as the null hypothesis is no similarity between trees! } \value{ An object of class \code{"cospeciation"}, which includes the test-statistic, the null distribution, and a p-value for the test of the null hypothesis of no topological similarity between the two trees. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/locate.fossil.Rd0000644000176200001440000000347612464426537015771 0ustar liggesusers\name{locate.fossil} \alias{locate.fossil} \title{Locate a fossil lineage in a tree using continuous characters} \usage{ locate.fossil(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix with continuous character data.} \item{...}{optional arguments including \code{time.constraint} which can be a scalar (positive height above the root of the fossil or negative time before present) or a vector (age range of fossil, either positive or negative); \code{edge.constraint}, which is equivalent to \code{constraint} in \code{\link{locate.yeti}}; \code{plot}, \code{rotate}, and \code{quiet}, which have the same interpretation (and defaults) as the equivalent arguments in \code{\link{locate.yeti}}.} } \description{ This function uses ML to place a fossil lineage into a tree using continuous traits. } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Felsenstein, J. (2002) Quantitative characters, phylogenies, and morphometrics. In: MacLeod, N. and P. Forey (Eds.) \emph{Morphology, Shape and Phylogeny} (pp. 27-44). Taylor and Francis, London. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (In press) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{maximum likelihood} phytools/man/averageTree.Rd0000644000176200001440000000240113066526150015430 0ustar liggesusers\name{averageTree} \alias{averageTree} \alias{ls.consensus} \alias{minTreeDist} \title{Compute an average tree from a set of trees and related operations} \usage{ averageTree(trees, start=NULL, method="quadratic.path.difference", tol=1e-12, quiet=FALSE, ...) ls.consensus(trees, start=NULL, tol=1e-12, quiet=FALSE, ...) minTreeDist(tree, trees, method="quadratic.path.difference", ...) } \arguments{ \item{trees}{object of class \code{"multiPhylo"}.} \item{tree}{object of class \code{"phylo"}. For \code{minTreeDist} the tree on which to find the edge lengths that minimize the distance to the phylogenies in \code{trees}.} \item{start}{starting tree for optimization.} \item{method}{distance criterion for minimization. Options are \code{"symmetric.difference"}, \code{"branch.score.difference"}, \code{"path.difference"}, and \code{"quadratic.path.difference"}.} \item{tol}{tolerance value for optimization.} \item{quiet}{logical value indicating whether to run "quietly" or not.} \item{...}{other arguments to be passed internally.} } \description{ These functions compute average trees or consensus trees by various criteria. } \value{ An object of class \code{"phylo"} with edge lengths. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} phytools/man/countSimmap.Rd0000644000176200001440000000352412464425323015505 0ustar liggesusers\name{countSimmap} \alias{countSimmap} \title{Counts the number of character changes on a SIMMAP style tree or set of trees} \usage{ countSimmap(tree, states=NULL, message=TRUE) } \arguments{ \item{tree}{a single tree or a set of trees with a mapped discrete character (e.g, see \code{\link{make.simmap}} or \code{\link{read.simmap}}.} \item{states}{optional argument with the states for the mapped character. If not provided, these will be computed from the tree. This is useful if averaging across many trees, some of which may lack certain states.} \item{message}{optional logical argument indicating whether or not to return an informative message about the function output.} } \description{ This function takes a tree or a set of trees with a mapped discrete character (SIMMAP style, e.g., see \code{\link{make.simmap}} or \code{\link{read.simmap}}), and computes the total number of character changes as well as the number of character changes between all states. } \value{ A list with up to three elements: \code{N} is an integer value giving the total number of character changes on the tree; \code{Tr} gives the number of of transitions between row and column states (or a matrix containing both \code{N} and the transitions between states, in rows, for an object of class \code{"multiPhylo"}); and (optionally) \code{message} contains an explanatory message about the function output. } \examples{ tree<-pbtree(n=100,scale=1) Q<-matrix(c(-2,1,1,1,-2,1,1,1,-2),3,3) colnames(Q)<-rownames(Q)<-c("A","B","C") mtree<-sim.history(tree,Q) countSimmap(mtree,states=rownames(Q)) } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ls.tree.Rd0000644000176200001440000000134612464426611014563 0ustar liggesusers\name{ls.tree} \alias{ls.tree} \title{Least squares branch lengths for a given tree} \usage{ ls.tree(tree, D) } \arguments{ \item{tree}{phylogeny.} \item{D}{distance matrix.} } \description{ Computes the least squares branch lengths conditioned on a topology and distance matrix. Internal function for \code{\link{optim.phylo.ls}}. } \details{ Do not use unless you know what you're doing. } \value{ A tree with branch lengths. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{least squares} phytools/man/writeAncestors.Rd0000644000176200001440000000327113066534572016227 0ustar liggesusers\name{writeAncestors} \alias{writeAncestors} \title{Write a tree to file with ancestral states and (optionally) CIs at nodes} \usage{ writeAncestors(tree, Anc=NULL, file="", digits=6, format=c("phylip","nexus"), ...) } \arguments{ \item{tree}{a phylogenetic tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{Anc}{a vector of ancestral states, a list containing the ancestral states and 95-percent confidence intervals (as from \code{\link{fastAnc}} or \code{\link{ace}}, or a list of such results.} \item{file}{an optional string with the filename for output.} \item{digits}{an integer indicating the number of digits to print for branch lengths and ancestral character values.} \item{format}{a string indicating whether to output the result in simple Newick (i.e., \code{"phylip"}) or Nexus format.} \item{...}{additional arguments including \code{x}: a vector of character values, in which case ancestral states are estimated internally using \code{fastAnc}; and \code{CI}: a logical value indicating whether or not to estimate 95-percent confidence intervals.} } \description{ This function writes a tree to file with ancestral character states and (optionally) 95-percent confidence intervals stored as node value.. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \value{ A file, string, or vector of strings. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fastAnc}}, \code{\link{write.tree}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/findMRCA.Rd0000644000176200001440000000315413027773741014576 0ustar liggesusers\name{findMRCA} \alias{findMRCA} \title{Get the MRCA of a set of taxa} \usage{ findMRCA(tree, tips=NULL, type=c("node","height")) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{tips}{a vector containing a set of tip labels.} \item{type}{either \code{"node"} to return the node of the MRCA; or \code{"height"} to return the height above the root of the MRCA of \code{tips}.} } \description{ This function returns the most recent common ancestor (node number) for a set of taxa. If \code{tips=NULL} will be redundant with \code{\link{mrca}} (for \code{type="node"}) or \code{\link{vcv.phylo}}, but much slower (for \code{type="height"}). } \details{ If \code{tips==NULL} will return the result of a normal function call to \code{\link{mrca}}. If \code{tips=NULL} will return a matrix equal to \code{\link{vcv.phylo}}. From \code{phytools 0.5-66} \code{findMRCA} uses \code{\link{getMRCA}} in the ape package internally, which results in a big speed-up. } \value{ The node number of the MRCA, or a matrix of node numbers (if \code{tips==NULL}) - for \code{type="node"}; or the height of the MRCA, or a matrix of heights (if \code{tips==NULL}) - for \code{type="height"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ tree<-pbtree(n=20) anc<-findMRCA(tree,c("t1","t10","t15")) } \keyword{phylogenetics} \keyword{utilities} phytools/man/anc.trend.Rd0000644000176200001440000000337013201722504015050 0ustar liggesusers\name{anc.trend} \alias{anc.trend} \title{Ancestral character estimation with a trend} \usage{ anc.trend(tree, x, maxit=2000) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.} } \description{ This function estimates the evolutionary parameters and ancestral states for Brownian evolution with directional trend. } \details{ Note that this will generally only work and produce sensible results for a phylogeny with some non-contemporary tips (i.e., a tree with some fossil species). The function uses \code{\link{optim}} with \code{method=} \code{"L-BFGS-B"}; however optimization is only constrained for the \code{sig2} which must be >0. } \value{ An object of class \code{"anc.trend"} with the following components: \item{ace}{a vector with the ancestral states.} \item{mu}{a trend parameter per unit time.} \item{sig2}{the variance of the BM process.} \item{logL}{the log-likelihood.} \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{optim}} } \examples{ tree<-rtree(20) x<-fastBM(tree,mu=2) # simulate using fastBM with a trend (m!=0) anc.trend(tree,x) # fit model & estimate ancestral states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/threshState.Rd0000644000176200001440000000165512464427133015510 0ustar liggesusers\name{threshState} \alias{threshState} \title{Computes value for a threshold character from a liability and thresholds} \usage{ threshState(x, thresholds) } \arguments{ \item{x}{liability.} \item{thresholds}{a named vector containing the thresholds.} } \description{ Primarily to be used internally by \code{\link{ancThresh}}; can also be used to simulate threshold traits. } \value{ A discrete character value. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}}, \code{\link{threshDIC}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} phytools/man/phyl.vcv.Rd0000644000176200001440000000255312517470425014762 0ustar liggesusers\name{phyl.vcv} \alias{phyl.vcv} \title{Compute evolutionary VCV matrix for a tree & dataset} \usage{ phyl.vcv(X, C, lambda) } \arguments{ \item{lambda}{value for \eqn{\lambda} transformation.} \item{X}{data matrix.} \item{C}{matrix containing the height above the root of each pair of species in the tree. Typically this will have been produced by calling \code{\link{vcv.phylo}}.} } \description{ Primarily an internal function for \code{\link{phyl.pca}}; this can be used to compute the phylogenetic trait variance-covariance matrix given a phylogenetic VCV, lambda, and a data matrix. Should not be confused with \code{\link{vcv.phylo}} in the "ape" package (although one of the objects returned is the output of \code{vcv.phylo}). } \details{ Do not use unless you know what you're doing. } \value{ A list containing three elements, as follows: \code{C}, the matrix \code{vcv.phylo} transformed by \code{lambda}; \code{R}, the among trait variance-covariance matrix for the data in \code{X}; and \code{alpha}, a vector of ancestral states at the root node of the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/rateshift.Rd0000644000176200001440000000435413066533644015206 0ustar liggesusers\name{rateshift} \alias{rateshift} \alias{plot.rateshift} \alias{likSurface.rateshift} \title{Find the temporal position of one or more rate shifts} \usage{ rateshift(tree, x, nrates=1, niter=10, method="ML", ...) \method{plot}{rateshift}(x, ...) likSurface.rateshift(tree, x, nrates=2, shift.range=NULL, density=20, plot=TRUE, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. For \code{plot} method, \code{x} is an object of class \code{"rateshift"}.} \item{nrates}{number of rates.} \item{niter}{number of iterations of optimization routine to ensure convergence.} \item{method}{optimization method. Can be \code{"ML"} (maximum likelihood) or \code{"REML"} (restricted maximum likelihood).} \item{...}{optional arguments. In the case of the \code{plot} method, these will be passed to \code{\link{plotSimmap}}. For \code{rateshift}, optional arguments include: \code{tol}, tolerance; \code{plot} & \code{print}, logical values indicating whether to plot or print the progress of the optimization (default to \code{FALSE}); \code{quiet}, logical argument indicating whether to suppress all notifications (defaults to \code{FALSE}); \code{minL}, numeric value; and \code{fixed.shift}, either a vector of fixed shift points, or a logical value.} \item{shift.range}{for \code{likSurface.rateshift}.} \item{density}{for \code{likSurface.rateshift}.} \item{plot}{logical argument for \code{likSurface.rateshift}. If \code{plot=FALSE} then the surface is returned.} } \description{ Function finds the location of one or more rate shifts. \code{likSurface.rateshift} plots the likelihood surface (which is sometimes quite rugged). } \value{ A fitted object of class \code{"rateshift"}, or, in the case of \code{likSurface.rateshift}, a likelihood surface for the shift points. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/bd.Rd0000644000176200001440000000123113020602613013550 0ustar liggesusers\name{bd} \alias{bd} \title{Convert object of class "birthdeath" to raw birth & death rates} \usage{ bd(x) } \arguments{ \item{x}{object of class \code{"birthdeath"}.} } \description{ This function converts an object of class \code{"birthdeath"} to a vector with the ML birth & death rates. } \value{ A vector. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} phytools/man/orderMappedEdge.Rd0000644000176200001440000000240712517456367016247 0ustar liggesusers\name{orderMappedEdge} \alias{orderMappedEdge} \title{Order the columns of mapped.edge to match across trees} \usage{ orderMappedEdge(trees, ordering=NULL) } \arguments{ \item{trees}{object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{ordering}{ordering for the columns of \code{$mapped.edge}. If \code{NULL}, then an alphabetical order is assumed. Options are \code{"alphabetical"}, \code{"numerical"}, or any specific ordering of the mapped traits (e.g., \code{c("A","B","C")}.} } \description{ This function takes a modified object of class \code{"multiPhylo"} with a mapped discrete character (e.g., see \code{\link{read.simmap}} and sorts the columns of each \code{tree$mapped.edge} to have the same state ordering. This is handy if we want to, for instance, run \code{brownie.lite} on a set of mapped trees, and then average the fitted parameter values across trees. The function also works for a single tree. } \value{ A modified object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/splitTree.Rd0000644000176200001440000000170612464427305015163 0ustar liggesusers\name{splitTree} \alias{splitTree} \title{Split tree at a point} \usage{ splitTree(tree, split) } \arguments{ \item{tree}{phylogenetic tree.} \item{split}{split encoded as a list with two elements: \code{node}: the node number tipward of the split; and \code{bp}: the position along the branch to break the tree, measured from the rootward end of the edge.} } \description{ Primarily an internal function for \code{\link{posterior.evolrate}}, this function splits the tree at a given point, and returns the two subtrees as an object of class \code{"multiPhylo"}. } \details{ Probably do not use this unless you can figure out what you are doing. } \value{ Two trees in a list. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/writeNexus.Rd0000644000176200001440000000140212464426713015360 0ustar liggesusers\name{writeNexus} \alias{writeNexus} \title{Write a tree to file in Nexus format} \usage{ writeNexus(tree, file="") } \arguments{ \item{tree}{object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{file}{file name for output.} } \description{ This function writes one or multiple phylogenetic trees to file in NEXUS format. Redundant with \code{ape::\link{write.nexus}}. } \value{ Trees written to file. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{write.simmap}}, \code{\link{write.nexus}} } \keyword{phylogenetics} \keyword{input/output} phytools/man/bmPlot.Rd0000644000176200001440000000640412517426542014446 0ustar liggesusers\name{bmPlot} \alias{bmPlot} \title{Simulates and visualizes discrete-time Brownian evolution on a phylogeny} \usage{ bmPlot(tree, type="BM", anc=0, sig2=1/1000, ngen=1000, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{type}{the type of plot to create. See Description.} \item{anc}{the ancestral value for the root node.} \item{sig2}{the BM rate (variance of the Brownian evolution process).} \item{ngen}{number of generations for the simulation: will rescale the tree to this total length.} \item{...}{arguments to be passed to different methods.} } \description{ This function conducts discrete-time Brownian motion simulation on an input tree, plots the outcome, and returns the tip and internal node states to the user as a named vector. The function will first rescale and round the branch lengths to integer length, if they are not already in integer values. If integer branch lengths are provided, the user should also set \code{ngen=max(nodeHeights(tree))}. For \code{type="threshold"} the visualization is of the threshold model (Felsenstein 2012), in which the evolving character is liability and the segments of evolution are colored by their value for the threshold trait. If \code{type="threshold"} is used, the function requires at least one addition input: \code{thresholds}, a vector containing the ordered thresholds between states. The user can also provide the colors for plotting in \code{colors}. Note that one more color than threshold should be provided as one threshold implies two states; two thresholds, three states; etc. If no value for \code{colors} is provided, the function will recycle a set of four colors up to the number of times required by \code{thresholds}. Finally, the optional argument \code{return.tree=TRUE} will tell the function to return a list with the tip and note states and an object of class \code{"phylo"} with (for \code{type="threshold"}), the state for the threshold model through time mapped on the branches of the tree in discrete time. } \value{ This function conducts and plots discrete time Brownian simulation and returns a vector containing the simulated states at internal nodes and tips of the tree. It also returns, by default (although this can be turned off) a tree with the branch lengths in discrete time and with a mapped discrete character (for \code{type="threshold"}). } \references{ Felsenstein, J. 2012. A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{pbtree}}, \code{\link{phenogram}}, \code{\link{threshBayes}} } \examples{ # plot BM simulation on 20 taxon tree tree<-pbtree(n=20) x<-bmPlot(tree) # plot simulation of a threshold character tree<-pbtree(n=20) x<-bmPlot(tree,type="threshold",thresholds=c(0,1,2)) } \keyword{phylogenetics} \keyword{plotting} \keyword{simulation} phytools/man/splitplotTree.Rd0000644000176200001440000000321313201721503016040 0ustar liggesusers\name{splitplotTree} \alias{splitplotTree} \alias{plotTree.splits} \title{Plots a phylogeny in two columns} \usage{ splitplotTree(tree, fsize=1.0, ftype="reg", lwd=2, split=NULL, new.window=FALSE) plotTree.splits(tree, splits=NULL, file=NULL, fn=NULL, ...) } \arguments{ \item{tree}{an object of class "phylo".} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{split}{relative vertical position for splitting the tree (between 0 & 1).} \item{new.window}{whether or not to plot the split tree in a new window. If \code{FALSE} then the tree will be plotted in two columns within the same plotting window.} \item{splits}{for \code{plotTree.splits} relative positions (from 0 to 1) to split the tree across pages or devices.} \item{file}{filename if saving to a PDF file is desired. Otherwise will plot to the default plotting device.} \item{fn}{function to be executed on each plotted page. For instance, might be: \code{function()} \code{cladelabels()} if clade labels are desired.} \item{...}{other arguments to be passed to \code{\link{plotTree}}.} } \description{ Function plots a tree in two columns or windows. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/applyBranchLengths.Rd0000644000176200001440000000155412464424706017003 0ustar liggesusers\name{applyBranchLengths} \alias{applyBranchLengths} \title{Applies the branch lengths of a reference tree to a target} \usage{ applyBranchLengths(tree, edge.length) } \arguments{ \item{tree}{target tree.} \item{edge.length}{number of digits for rounding. Passed to \code{\link{round}}.} } \description{ This function applies the set of branch lengths from a reference tree to a target tree while reconciling any mappings (as in \code{\link{read.simmap}}) with the new branch lengths. } \value{ A tree with branch lengths, or modified \code{"phylo"} object with a mapped discrete character. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/getSisters.Rd0000644000176200001440000000241313066530303015330 0ustar liggesusers\name{getSisters} \alias{getSisters} \title{Get the sister node number, label, or set of nodes for a node or tip} \usage{ getSisters(tree, node, mode=c("number","label")) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{node}{a node number, tip number, node label, or tip label.} \item{mode}{an optional string indicating whether to return the node or tip number(s) or the node or tip label(s), if available.} } \description{ This function takes a tree and node or tip number of label and returns the number or label of the sister or sisters to that node or tip. } \value{ If \code{mode="number"} this function returns an integer or vector containing the node number of numbers of the sister node or tip. If \code{mode="label"} that this function returns a list containing up to two vectors: one for the node numbers of labels of sister nodes (if available); and the other containing the tip labels of the sister tips. } \seealso{ \code{\link{getDescendants}}, \code{\link{Siblings}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/add.species.to.genus.Rd0000644000176200001440000000464313201723460017125 0ustar liggesusers\name{add.species.to.genus} \alias{add.species.to.genus} \alias{genus.to.species.tree} \title{Add species to genus on a phylogeny or bind simulated species subtrees to a backbone genus tree} \usage{ add.species.to.genus(tree, species, genus=NULL, where=c("root","random")) genus.to.species.tree(tree, species) } \arguments{ \item{tree}{an object of class \code{"phylo"}. In the case of \code{genus.to.species.tree} this should be a genus-level backbone tree.} \item{species}{string contain species name in the format \code{"Genus_species"} or \code{"Genus species"}.} \item{genus}{for \code{add.species.to.genus}, optional argument containing the genus to which \code{species} is to be attached. If \code{NULL} then \code{genus} will be extracted from \code{species}.} \item{where}{for \code{add.species.to.genus}, the location to attach \code{species} to the tree. \code{where=} \code{"root"} will cause the species to be attached to the MRCA of all members of \code{genus}. \code{where="random"} will cause \code{species} to be attached at random to the subtree descended from the MRCA of all members of \code{genus}.} } \description{ \code{add.species.to.genus} adds an additional species to a genus on a phylogeny. \code{genus.to.species.tree} simulates pure-birth subtrees and then binds them at a random height along the terminal edge leading to each corresponding genus on a genus-level backbone tree. } \details{ For \code{add.species.to.genus}, if \code{genus} contains only one species and \code{where="root"}, then \code{species} will be attached midway along the branch leading to the one species. If \code{where="random"} then \code{species} will be added at a random position along the edge. If \code{genus} cannot be found in the tree, then the original tree is returned and a warning printed. If the tree is not ultrametric, then the resultant tree may not contain branch lengths and a warning will be printed. If \code{genus} is non-monophyletic then \code{species} will be attached to the most inclusive group containing members of \code{genus} and a warning will be printed. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.random}}, \code{\link{bind.tip}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ladderize.simmap.Rd0000644000176200001440000000157112464426420016435 0ustar liggesusers\name{ladderize.simmap} \alias{ladderize.simmap} \title{Ladderize a tree with a mapped discrete character} \usage{ ladderize.simmap(tree, right=TRUE) } \arguments{ \item{tree}{an object of class \code{"phylo"} with a mapped discrete character.} \item{right}{a logical specifying how the tree should be ladderized.} } \description{ This function "ladderizes" an object of class \code{"phylo"} with a mapped discrete character. For more information, please see \code{\link{ladderize}}. } \value{ An object of class \code{"phylo"} with a mapped discrete character. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{ladderize}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/getExtant.Rd0000644000176200001440000000221612464426344015152 0ustar liggesusers\name{getExtant} \alias{getExtant} \alias{getExtinct} \title{Returns a list of the extant or extinct lineages in a tree containing non-contemporaneous tips} \usage{ getExtant(tree, tol=1e-8) getExtinct(tree, tol=1e-8) } \arguments{ \item{tree}{a phylogeny stored as an object of class \code{"phylo"} with some tips that are non-contemporaneous (i.e., end before the present).} \item{tol}{a tolerance value to account for numerical imprecision.} } \description{ The function \code{getExtant} takes a tree as input and returns a vector containing the names of all the tips that have a height above the root that is equal (to a degree of numerical precision determined by \code{tol}) to the height of the highest tip. \code{getExtinct} returns the complement. } \value{ A vector with the tip names of extant or extinct species in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodeHeights}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/add.arrow.Rd0000644000176200001440000000304213201722271015052 0ustar liggesusers\name{add.arrow} \alias{add.arrow} \title{Add an arrow pointing to a tip or node on the tree} \usage{ add.arrow(tree=NULL, tip, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, \code{"contMap"}, or \code{"densityMap"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.} \item{tip}{label of tip or tip or node number. If \code{tree=NULL} then the tip or node number must be supplied.} \item{...}{optional arguments to control the shape and size of the arrow including: its length (\code{arrl}) in the units of the plot; the length of the arrowhead (\code{hedl}); the total angle between the wings in the arrowhead (\code{angle}); the line width for the plotted lines (\code{lwd}); the offset from the tip or end of tip label, in character widths (\code{offset}); and the color (\code{col}).} } \description{ This function adds an arrow to a plotted tree. } \details{ This function presently works for radial (\code{type="fan"}) and right facing square phylograms (\code{type=} \code{"phylogram"}). Trees can be plotted using phytools function \code{plotTree}, \code{plotSimmap}, \code{contMap}, \code{densityMap}, and ape S3 method \code{plot.phylo}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/minRotate.Rd0000644000176200001440000000336212753627777015172 0ustar liggesusers\name{minRotate} \alias{minRotate} \alias{tipRotate} \title{Rotates all nodes of the tree to minimize the difference in order with a vector} \usage{ minRotate(tree, x, ...) tipRotate(tree, x, ...) } \arguments{ \item{tree}{tree.} \item{x}{numeric vector.} \item{...}{optional arguments to be used by \code{tipRotate}. Presently optional arguments can be \code{fn}, function to be used to compute the distance between the order of the tip labels in \code{tree} and the numeric vector \code{x} (presently \code{fn=function(x) x^2} by default); \code{methods}, the methods of tree traversal (can be \code{"pre"}, \code{"post"}, or \code{c("pre","post")}, for pre-, post-, or both pre- and post-order tree traversal); \code{rotate.multi}, whether to rotate multifurcations in all possible ways using \code{rotate.multi} (defaults to \code{FALSE}); and \code{print}, a logical argument specifying whether to print the search progress or to behave quietly. Only the option \code{print} is available for \code{minRotate}.} } \description{ This function rotates all the nodes of the tree to try and minimize the different between the order of the tips and the rank-order of a numeric vector \code{x} or (in the case of \code{tipRotate} the actual integer vector, \code{x}. } \details{ Primarily designed to be used internally by \code{\link{phylo.to.map}}, in the case of \code{minRotate}, or \code{\link{cophylo}}, in the case of \code{tipRotate}. } \value{ A object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/plotTree.Rd0000644000176200001440000000174212464431027015002 0ustar liggesusers\name{plotTree} \alias{plotTree} \title{Plots rooted phylogenetic tree} \usage{ plotTree(tree, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format; or multiple trees as an object of class \code{"multiPhylo"}.} \item{...}{optional arguments.} } \description{ This function plots a rooted phylogram. Arguments in \code{...} are passed to \code{\link{plotSimmap}}, with the exception of optional argument \code{color} which is used to determine the plotted color of the branch lengths of the tree. } \value{ This function plots a rooted phylogram. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plot.phylo}}, \code{\link{plotSimmap}} } \examples{ tree<-pbtree(n=25) plotTree(tree,color="blue",ftype="i") } \keyword{phylogenetics} \keyword{plotting} phytools/man/phyloDesign.Rd0000644000176200001440000000171312517471505015473 0ustar liggesusers\name{phyloDesign} \alias{phyloDesign} \title{Compute design matrix for least squares analyses} \usage{ phyloDesign(tree) } \arguments{ \item{tree}{phylogenetic tree.} } \description{ Primarily an internal function for \code{\link{optim.phylo.ls}}, this function creates a design matrix for least squares phylogenetic analysis. } \details{ This function returns a matrix containing the edges in the tree (in columns) and pairs of tip node numbers (in rows). Values in the matrix are either \code{1} if the edge is on the shortest path between the two tips; and \code{0} otherwise. Probably do not use unless you know what you're doing. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{least squares} phytools/man/sim.rates.Rd0000644000176200001440000000357513061416345015117 0ustar liggesusers\name{sim.rates} \alias{sim.rates} \alias{multiOU} \title{Brownian or OU simulation with multiple evolutionary regimes} \usage{ sim.rates(tree, sig2, anc=0, nsim=1, internal=FALSE, plot=FALSE) multiOU(tree, alpha, sig2, theta=NULL, a0=NULL, nsim=1, internal=FALSE, ...) } \arguments{ \item{tree}{is a stochastic map format phylogenetic tree in modified \code{"phylo"} format (e.g., see \code{\link{make.simmap}}).} \item{sig2}{a named vector containing the rates for each state; names should be states in \code{mtree}.} \item{anc}{optional value for the root state.} \item{nsim}{number of simulations.} \item{internal}{logical value indicating whether to return states at internal nodes.} \item{plot}{logical value indicating whether or not to visual the rate heterogeneity (default value is \code{FALSE}.} \item{alpha}{single value or vector of values of the OU alpha parameter.} \item{theta}{single value or vector of values of the OU theta parameter.} \item{a0}{optional value of the root state. Defaults to zero.} \item{...}{optional arguments.} } \description{ The function \code{sim.rates} conducts BM simulation on a tree with multiple rates. The function \code{multiOU} conducts multi-regime OU simulations on the tree under a range of conditions. } \details{ \code{multiOU} uses a difference equation approximation of the OU process. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} phytools/man/rotateNodes.Rd0000644000176200001440000000403112760461620015466 0ustar liggesusers\name{rotateNodes} \alias{rotateNodes} \alias{rotate.multi} \alias{allRotations} \title{Rotates a node or set of nodes in a phylogenetic tree} \usage{ rotateNodes(tree, nodes, polytom=c(1,2), ...) rotate.multi(tree, node) allRotations(tree) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{nodes}{either a single node number to rotate, a vector of node numbers, or the string \code{"all"}.} \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy (see \code{\link{rotate}}).} \item{node}{a single node to rotate (in the case of \code{rotate.multi}).} \item{...}{optional arguments.} } \description{ The function \code{rotateNodes} is a simple wrapper for \code{\link{rotate}} which rotates a set of nodes or all nodes. The function \code{rotate.multi} finds all possible rotations around a multifurcating node, given by \code{node}. This will be an object of class \code{"multiPhylo"}, assuming that the node specified is indeed a multifurcation. The function \code{allRotations} computes all possible rotated trees for a given input phylogeny. For a binary tree, this is generally two raised to the power of the number of internal nodes (so a very large number, if \emph{N} is even modest in size). } \details{ All three functions also address the problem that the product of multiple rotations from \code{\link{rotate}} can be non-compliant with the implicit \code{"phylo"} standard because the tip numbers in \code{tree$edge} are not in numerical order \code{1:n} for \code{n} tips. } \value{ An object of class \code{"phylo"} (i.e., a phylogenetic tree), in the case of \code{rotateNodes}, or an object of class \code{"multiPhylo"} for \code{rotate.multi} or \code{allRotations}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ltt95.Rd0000644000176200001440000000317513066530626014173 0ustar liggesusers\name{ltt95} \alias{ltt95} \alias{plot.ltt95} \title{Creates a (1-\eqn{\alpha})-percent CI for a set of LTTs} \usage{ ltt95(trees, alpha=0.05, log=FALSE, method=c("lineages","times"), mode=c("median","mean"), ...) \method{plot}{ltt95}(x, ...) } \arguments{ \item{trees}{is an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.} \item{alpha}{confidence level.} \item{log}{logical value indicating whether or not to plot on the log-scale.} \item{method}{plot the CI on the number of lineages given time (\code{"lineages"}); or on times given a number of lineages (\code{"times"}).} \item{mode}{plot the median or mean LTT.} \item{x}{object of class \code{"ltt95"} for plotting method.} \item{...}{optional arguments to be used by \code{ltt95} or the plotting method. So far, \code{res} gives the number of time-steps (defaults to \code{res=100}. \code{xaxis} (\code{"standard"}, \code{"negative"}, or \code{"flipped"}) determines the scale (time from the root, time back from the present, or time from the present) of the x-axis of the plot.} } \description{ This function computes LTT plots for a set of trees & plots a (1-\eqn{\alpha})-percent CI by various methods. } \details{ This function creates a plot and invisibly returns an object of class \code{"ltt95"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification analysis} phytools/man/contMap.Rd0000644000176200001440000001037313066526740014613 0ustar liggesusers\name{contMap} \alias{contMap} \alias{plot.contMap} \alias{errorbar.contMap} \title{Map continuous trait evolution on the tree} \usage{ contMap(tree, x, res=100, fsize=NULL, ftype=NULL, lwd=4, legend=NULL, lims=NULL, outline=TRUE, sig=3, type="phylogram", direction="rightwards", plot=TRUE, ...) \method{plot}{contMap}(x, ...) errorbar.contMap(obj, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.contMap}, an object of class \code{"contMap"}.} \item{res}{resolution for gradient plotting. Larger numbers indicate a finer (smoother) gradient.} \item{fsize}{relative font size - can be a vector with the second element giving the font size for the legend.} \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, this can be a vector with the second element giving font type for the legend.} \item{lwd}{line width for branches. Can be a single integer number or a vector. In the latter case, the second number will be taken to be the desired legend width.} \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.} \item{lims}{range for the color map. By default, this will be \code{c(min(x),max(x))}, and should always include this range.} \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.} \item{sig}{the number of decimal places to show on the legend limits.} \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.} \item{direction}{plotting direction for \code{type="phylogram"}.} \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"contMap"} will be returned without plotting.} \item{obj}{object of class \code{"contMap"}.} \item{...}{optional arguments for \code{plot.contMap} which include all the arguments of \code{contMap} except for \code{tree}, \code{x}, \code{res}, and \code{lims}. Also \code{method}, \code{"fastAnc"}, \code{"anc.ML"}, or \code{"user"} (for user-supplied states) specifying which function to use for ancestral state estimation; \code{hold} specifies whether or not to hold output to graphical device before plotting (defaults to \code{hold=TRUE}); and \code{anc.states} a vector containing some or multiple ancestral user-supplied ancestral states at nodes. Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work. Optional arguments for \code{errorbar.contMap} include \code{x}, a vector containing the original trait values mapped onto the tree (otherwise these will be obtained from \code{obj}), \code{scale.by.ci}, a logical argument (defaulting to \code{TRUE}) that determines whether or not the length of the error bars will be scaled by the CI width, and \code{lwd}, which detemines the line width of the plotted error bars.} } \description{ Function plots a tree with a mapped continuous character. The mapping is accomplished by estimating states at internal nodes using ML with \code{\link{fastAnc}}, and the interpolating the states along each edge using equation [2] of Felsenstein (1985). \code{errorbar.contMap} adds error bars to an existing plot. } \value{ Plots a tree. An object of class \code{"contMap"} is returned invisibly. \code{errorbar.contMap} adds colorful error bars to a plotted tree. } \references{ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.ML}}, \code{\link{densityMap}}, \code{\link{fastAnc}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/di2multi.simmap.Rd0000644000176200001440000000220513020601273016204 0ustar liggesusers\name{di2multi.simmap} \alias{di2multi.simmap} \title{Collapse branches of zero length to polytomy in stochastic map style tree} \usage{ \method{di2multi}{simmap}(phy, ...) } \arguments{ \item{phy}{object of class \code{"simmap"} containing a stochastically mapped discrete character.} \item{...}{optional argument \code{tol}, length below which edges should be treated as having zero length.} } \description{ This function collapses branches of zero length (or, more specifically, branches with length shorter than \code{tol}) to create a polytomy in a stochastic-map style tree. } \details{ This function should theoretically perform similarly to \code{\link{di2multi}} in ape. } \value{ A tree with a stochastically mapped discrete character } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{di2multi}}, \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} phytools/man/linklabels.Rd0000644000176200001440000000250213071021460015306 0ustar liggesusers\name{linklabels} \alias{linklabels} \title{Function to add tip labels to a plotted tree with linking lines} \usage{ linklabels(text,tips,link.type=c("bent","curved","straight"), ...) } \arguments{ \item{text}{text string or vector to be used as labels.} \item{tips}{node numbers (indices) for the tips to be labeled.} \item{link.type}{manner in which to draw the linking lines.} \item{...}{optional arguments, including \code{cex}, \code{lty}, \code{lwd}, and \code{col}.} } \description{ Function adds tip labels to a plotted tree by drawing curved, bent, or straight linking lines. } \details{ The idea underlying this function is that the user should first plot the tree without tip labels, but set the area of the plotting device to be sufficient to accommodate the tip labels once they have been added. The function then can be called to add tip labels connected by linking lines to the tips of the plotted tree. } \value{ This function annotates a plot. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/phyl.cca.Rd0000644000176200001440000000345613201657212014705 0ustar liggesusers\name{phyl.cca} \alias{phyl.cca} \title{Phylogenetic canonical correlation analysis} \usage{ phyl.cca(tree, X, Y, lambda=1.0, fixed=TRUE) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{X}{a data matrix with traits in columns.} \item{Y}{data matrix with traits in columns, to be correlated with \code{X}.} \item{lambda}{optionally, a (fixed) value for \code{lambda}.} \item{fixed}{optionally, a logical value indicating whether or not to estimate \code{lambda} using likelihood.} } \description{ This function performs phylogenetic canonical correlation analysis (e.g., Revell & Harrison 2008; \emph{Bioinformatics}). } \details{ (Optional) joint optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1). } \value{ An object of class \code{"phyl.cca"} containing the following components: \item{cor}{canonical correlations.} \item{xcoef}{coefficients for the canonical variables for \code{X}.} \item{ycoef}{coefficients for the canonical variables for \code{Y}.} \item{xscores}{matrix with the canonical scores for \code{X}.} \item{yscores}{matrix with the canonical scores for \code{Y}.} \item{chisq}{vector of \eqn{\chi^2} values.} \item{p}{P-values for the hypothesis test that the \emph{i}th and all subsequent correlations are zero.} } \references{ Revell, L. J., Harrison, A. S. (2008) PCCA: A program for phylogenetic canonical correlation analysis. \emph{Bioinformatics}, \bold{24}, 1018-1020. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.pca}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} phytools/man/sim.corrs.Rd0000644000176200001440000000307213201721576015122 0ustar liggesusers\name{sim.corrs} \alias{sim.corrs} \title{Multivariate Brownian simulation with multiple correlations and rates} \usage{ sim.corrs(tree, vcv, anc=NULL, internal=FALSE) } \arguments{ \item{tree}{is a phylogenetic tree in 'phylo' format; or a modified 'phylo' tree with a mapped discrete character.} \item{vcv}{is a square covariance matrix or named list of matrices (one for each mapped state on the tree).} \item{anc}{optional vector of values for the root state.} \item{internal}{logical value indicating whether to return states at internal nodes.} } \description{ This function conducts BM simulation on a tree with multiple rates and/or multiple evolutionary correlations between characters. If \code{vcv} is a single matrix, instead of a list of matrices, \code{sim.corrs} will simulate multivariate BM with a single rate matrix. } \value{ A matrix containing the multivariate tip states for the \code{n} species in the tree (and nodes if \code{internal=} \code{TRUE}). } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} phytools/man/mrp.supertree.Rd0000644000176200001440000000573412625632442016027 0ustar liggesusers\name{mrp.supertree} \alias{mrp.supertree} \alias{compute.mr} \title{Matrix representation parsimony supertree estimation} \usage{ mrp.supertree(trees, method=c("pratchet","optim.parsimony"), ...) compute.mr(trees, type=c("phyDat","matrix")) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"} (i.e., a list of trees).} \item{method}{an argument specifying whether to optimize the tree using \code{\link{pratchet}} or \code{\link{optim.parsimony}}.} \item{type}{for \code{compute.mr}, the type of object to return.} \item{...}{optional arguments - mostly to be passed to \code{\link{pratchet}} or \code{\link{optim.parsimony}}.} } \description{ This function estimates the MRP (matrix representation parsimony) supertree from a set of trees (Baum 1992; Ragan 1992). } \details{ Function uses \code{\link{pratchet}} or \code{\link{optim.parsimony}} from the "phangorn" package (Schliep 2011) and \code{\link{prop.part}} from the "ape" package (Paradis et al. 2004). See \code{\link{pratchet}} or \code{\link{optim.parsimony}} for optional arguments, which vary slightly depending on the method. All optional arguments of these methods are available to the user with one exception. The argument \code{tree} in \code{\link{optim.parsimony}} is supplied instead as \code{start}. In addition to being an object of class \code{"phylo"}, \code{start} can also be assigned the string values of \code{"NJ"} or \code{"random"}, in which case either a neighbor-joining or random tree will be used as the starting tree for optimization. The function \code{compute.mr} computes the matrix-representation matrix of the input trees. It is used internally by \code{mrp.supertree}, but can also be used to export an object that can be written to file if desired. } \value{ A \code{"phylo"} or \code{"multiPhylo"} object that is the MP or set of MP MRP trees. In the case of \code{compute.mr}, an object of class \code{"phyDat"} or a matrix. } \references{ Baum, B. R., (1992) Combining trees as a way of combining data sets for phylogenetic inference, and the desirability of combining gene trees. \emph{Taxon}, \bold{41}, 3-10. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Ragan, M. A. (1992) Phylogenetic inference based on matrix representation of trees. \emph{Molecular Phylogenetics and Evolution}, \emph{1}, 53-58. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{inference} \keyword{parsimony} \keyword{supertree} phytools/man/ltt.Rd0000644000176200001440000000464712542606316014020 0ustar liggesusers\name{ltt} \alias{ltt} \title{Creates lineage-through-time plot (including extinct lineages)} \usage{ ltt(tree, plot=TRUE, drop.extinct=FALSE, log.lineages=TRUE, gamma=TRUE, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format, or an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.} \item{plot}{a logical value indicating whether or not to create LTT plot.} \item{drop.extinct}{logical value indicating whether or not to drop extinct tips from the tree.} \item{log.lineages}{logical value indicating whether LTT plot should be on log-linear (default) or linear-linear scale.} \item{gamma}{logical value indicating whether or not to compute eqn{gamma} from Pybus & Harvey (2000; \emph{Proc. Roy. Soc. B}).} \item{...}{other arguments to be passed to plotting methods. See \code{\link{plot.default}}.} } \description{ This function computes LTT plot with extant and extinct lineages, and optionally conducts \eqn{\gamma}-test of Pybus & Harvey (2000). The object returned by \code{ltt} can be plotted or re-plotted using \code{\link{plot}}. } \details{ Although it is calculated here, it's unclear how to interpret the \eqn{\gamma}-statistic if not all the tips in the tree are contemporaneous. } \value{ An object of class \code{"ltt"} which includes the following components: \item{times}{a vector of branching times.} \item{ltt}{a vector of linages.} \item{gamma}{optionally, a value for the gamma-statistic.} \item{p}{two-tailed P-value for the gamma-test.} If \code{tree} is an object of class \code{"multiPhylo"}, then an object of class \code{"multiLtt"} is returned consisting of a list of object of class \code{"ltt"}. } \references{ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{gammatest}}, \code{\link{ltt95}} } \examples{ trees<-pbtree(n=100,scale=100,nsim=10) obj<-ltt(trees,plot=FALSE) plot(obj,log="y",log.lineages=FALSE,main="lineage through time plots") tree<-pbtree(b=1,d=0.25,t=4) obj<-ltt(tree,gamma=FALSE) obj } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification analysis} phytools/man/fit.bd.Rd0000644000176200001440000000352213173513106014345 0ustar liggesusers\name{fit.bd} \alias{fit.bd} \alias{fit.yule} \alias{lik.bd} \alias{print.fit.bd} \title{Fits birth-death (speciation/extinction) model to reconstructed phylogeny} \usage{ fit.bd(tree, b=NULL, d=NULL, rho=1, ...) fit.yule(tree, b=NULL, d=NULL, rho=1, ...) lik.bd(theta, t, rho=1, N=NULL) \method{print}{fit.bd}(x, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{b}{birth (speciation) rate. Presently doesn't do anything as the rate cannot be fixed.} \item{d}{death (extinction) rate. Presently doesn't do anything as the rate cannot be fixed.} \item{rho}{sampling fraction.} \item{theta}{vector of \code{b} and \code{d} for likelihood function.} \item{t}{branching times for calculation of the likelihood.} \item{N}{number of tips in the tree.} \item{x}{object of class \code{"fit.bd"} for \code{print} method.} \item{...}{optional arguments.} } \description{ This function fits a birth-death model to a phylogenetic tree with edge lengths. } \details{ This function duplicates \code{\link{birthdeath}} in ape and \code{make.bd} in the diversitree package. } \value{ \code{fit.bd} generates an object of class \code{"fit.bd"} which can be printed. } \references{ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}} } \keyword{comparative methods} \keyword{diversification} \keyword{phylogenetics} phytools/man/force.ultrametric.Rd0000644000176200001440000000306113066527750016640 0ustar liggesusers\name{force.ultrametric} \alias{force.ultrametric} \title{Forces a phylogenetic tree to be ultrametric} \usage{ force.ultrametric(tree, method=c("nnls","extend")) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{method}{the method to use to force the tree to be ultrametric. Options are \code{"nnls"} (which uses the phangorn function \code{\link{nnls.tree}} internally), or \code{"extend"}.} } \description{ This function forces an object of class \code{"phylo"} to be ultrametric. This is achieved either by using \code{\link{nnls.tree}} from the phangorn package to compute the set of edge lengths that result in a minimized sum-of-squares distance between the patristic distance of the output and input trees (\code{method="nnls"}); or by simply extending all the external edges of the tree to match the external edge with the greatest total height (\code{method="extend"}). Note that neither of these should be treated as formal statistical methods for inferring an ultrametric tree. Rather, this method can be deployed when a genuinely ultrametric tree read from file fails \code{\link{is.ultrametric}} for reasons of numerical precision. } \value{ An ultrametric tree in an object of class \code{"phylo"}. } \seealso{ \code{\link{is.ultrametric}}, \code{\link{nnls.tree}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} phytools/man/phylo.to.map.Rd0000644000176200001440000000543612725070624015542 0ustar liggesusers\name{phylo.to.map} \alias{phylo.to.map} \alias{plot.phylo.to.map} \title{Plot tree with tips linked to geographic coordinates} \usage{ phylo.to.map(tree, coords, rotate=TRUE, ...) \method{plot}{phylo.to.map}(x, type=c("phylogram","direct"), ...) } \arguments{ \item{tree}{an object of class "phylo".} \item{coords}{a matrix containing the latitude (in column 1) and the longitude of all tip species in the tree. The row names should be the same as \code{tree$tip.label}.} \item{rotate}{a logical value indicating whether or not to rotate nodes of the tree to better match longitudinal positions.} \item{x}{for \code{plot.phylo.to.map}, an object of class \code{"phylo.to.map"}.} \item{type}{a string indicating whether to map the tips of the tree onto a geographic map from a square phylogram (\code{type="phylogram"}) or to project the tree directly onto the map (\code{type="direct"}).} \item{...}{optional arguments. For \code{phylo.to.map}, which creates an object of class \code{"phylo.to.map"} and (optionally) plots that object, arguments include: \code{database} and \code{regions} (see \code{\link{map}}), as well as any arguments that should be passed to \code{plot.phylo.to.map} internally. For \code{phylo.to.map}, optional arguments \code{xlim} and \code{ylim}, which control the plot area for the map; \code{fsize} for the font size of plot labels and \code{ftype} for the font type (following \code{\link{plotSimmap}}; \code{split} which controls the proportion of vertical (or horizontal) space for the tree (first) and map, in a vector; \code{psize} the size of the plotted points on the map - or \code{cex.points}, a vector contain the size of the tip points and geographic coordinate points, respectively; \code{from.tip} a logical value indicating whether to plot the linking lines from the tips (if \code{TRUE}) or from the end of the tip label, the default; \code{colors}, a single value or a vector of colors for the points and the linking lines; \code{pch} a single value or a vector of point types; \code{lwd} and \code{lty} for the linking lines; and \code{pts} a logical value indicating whether or not to plot points at the tips of the tree. \code{mar} and \code{asp} are as in \code{\link{par}}.} } \description{ Function plots a tree and tips pointing to coordinates on a global map. } \value{ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (if \code{plot=TRUE}) plots a phylogeny projected onto a geographic map. \code{plot.phylo.to.map} plots on object of class \code{"phylo.to.map"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/fancyTree.Rd0000644000176200001440000001120413066527514015124 0ustar liggesusers\name{fancyTree} \alias{fancyTree} \title{Plots special types of phylogenetic trees} \usage{ fancyTree(tree, type=c("extinction","traitgram3d","droptip","densitymap", "contmap","phenogram95","scattergram"), ..., control=list()) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{type}{the type of special plot to create. See Description.} \item{...}{arguments to be passed to different methods.} \item{control}{a list of control parameters, depending on \code{type}.} } \description{ This function plots different types of phylogenetic trees. If \code{type="extinction"} (or any unambiguous abbreviation) the function will plot a tree in which branches preceding the MRCA of all extant taxa and branches leading only to extnct lineages are plotted with dashed red lines. If \code{type="traitgram3d"} the function will plot a three dimensional traitgram (that is, a projection of the tree into three dimensional morphospace where two dimensions are the phenotypic trait and the third axis is time since the root). In this case, the additional argument \code{X}, a matrix containing the tip values of all species (with species IDs as row names) should be supplied. Optionally, the user can also supply the matrix \code{A}, which contains the ancestral states in the tree with rows labeled by node number. If \code{type="droptip"} the function will create a two panel figure in which the first panel is the tree with lineages to be pruned highlighted; and the second panel is the pruned tree. In this case, the additional argument \code{tip}, the tip name or vector of tip names to be dropped, must be supplied. If \code{type="densitymap"}, a posterior probability density "heat-map" is created based on a set of trees in a \code{"multiPhylo"} object containing a binary [0,1] mapped character. (See \code{\link{densityMap}} for additional optional arguments if \code{type="densitymap"}.) If \code{type="contmap"}, reconstructed continuous trait evolution is mapped on the tree. Again, see \code{\link{contMap}} for additional arguments if \code{type="contmap"}. If \code{type="phenogram95"} a 95-percent phenogram is plotted using transparency to visualize uncertainty at ancestral nodes and along branches. Most of the options of \code{\link{phenogram}} are available. Finally, if \code{type="scattergram"} a phylogenetic scatter plot matrix containing \code{\link{contMap}} style trees on the diagonal and \code{\link{phylomorphospace}} plots in non-diagonal panels is produced. For \code{type="scattergram"} a trait matrix \code{X} must be supplied. The only additional arguments available for this type are \code{fsize}, \code{colors}, and \code{label}. (See \code{\link{phylomorphospace}} for details.) Presently only \code{type="traitgram3d"} uses the list \code{control} which can be supplied the same set of control parameters as \code{\link{phylomorphospace3d}}, as well as the control parameter \code{maxit} which will be passed to \code{\link{anc.ML}}. Finally, the optional argument \code{hold} will be passed to multiple methods if supplied. It is a logical value that indicates whether or not the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). } \value{ This function plots different types of phylogenetic trees. For \code{type="droptip"} the function also returns the pruned tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{phenogram}}, \code{\link{phylomorphospace3d}}, \code{\link{plot.phylo}}, \code{\link{plotSimmap}} } \examples{ # plot tree with extinction set.seed(10) tree<-pbtree(b=1,d=0.4,t=4) fancyTree(tree,type="extinction") \dontrun{ # plot 3D traitgram tree<-pbtree(n=50,scale=10) Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2)) fancyTree(tree,type="traitgram3d",X=Y,control=list(spin=FALSE)) # plot with internal nodes from simulation Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2),internal=TRUE) B<-Y[length(tree$tip)+1:tree$Nnode,]; Y<-Y[1:length(tree$tip),] fancyTree(tree,type="traitgram3d",X=Y,A=B,control=list(simple.axes=TRUE,spin=FALSE)) } # plot with dropped tips tree<-pbtree(n=30) tips<-sample(tree$tip.label)[1:10] pruned<-fancyTree(tree,type="droptip",tip=tips) \dontrun{ # plot 95-percent CI phenogram tree<-pbtree(n=30) x<-fastBM(tree) fancyTree(tree,type="phenogram95",x=x) } } \keyword{phylogenetics} \keyword{plotting} \keyword{utilities} phytools/man/reroot.Rd0000644000176200001440000000344713201721554014517 0ustar liggesusers\name{reroot} \alias{reroot} \title{Re-root a tree along an edge} \usage{ reroot(tree, node.number, position=NULL, interactive=FALSE, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{node.number}{ number of the node descending from the target branch in \code{tree$edge} - this can also be a tip in which case the node number is the index number of the tip in \code{tree$tip.label}.} \item{position}{position along the target edge at which to re-root the tree. If not supplied, then the tree will be re-rooted \emph{at} the node or tip.} \item{interactive}{logical value indicating whether to use interactive mode (defaults to \code{interactive=} \code{FALSE}).} \item{...}{arguments to be passed to \code{plotTree} for \code{interactive=TRUE} only.} } \description{ This function re-roots a phylogenetic tree at an arbitrary position along an edge. } \details{ This function had an error for rootings along edges descended from the root node for phytools<=0.2-47. This should be fixed in the present version. Now uses \code{\link{paste.tree}}, \code{\link{root}}, and \code{\link{splitTree}} internally. Earlier versions also had an error related to node labels. This should be fixed in phytools>=0.4-47. } \value{ A phylogenetic tree in \code{"phylo"} format. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{paste.tree}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/labelnodes.Rd0000644000176200001440000000226613066536233015322 0ustar liggesusers\name{labelnodes} \alias{labelnodes} \title{Function to interactively label nodes of a plotted tree} \usage{ labelnodes(text, node=NULL, interactive=TRUE, shape=c("circle","ellipse", "rect"), ...) } \arguments{ \item{text}{text string or vector to be used as labels.} \item{node}{node numbers (indices) for the labels.} \item{interactive}{logical value indicating whether or not nodes should be supplied interactively. (I.e., by clicking on the nodes.)} \item{shape}{shape to plot around the plotted node label(s).} \item{...}{optional arguments.} } \description{ Function adds node labels to a plotted object of class \code{"phylo"}. The nodes to be labels can be selected interactively by the user (i.e., by clicking on the corresponding nodes of the plotted tree). } \value{ Invisibly returns a vector of the node indices for the labeled nodes. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/multi.mantel.Rd0000644000176200001440000000327112464433046015617 0ustar liggesusers\name{multi.mantel} \alias{multi.mantel} \title{Multiple matrix regression (partial Mantel test)} \usage{ multi.mantel(Y, X, nperm=1000) } \arguments{ \item{Y}{single "dependent" square matrix. Can be either a symmetric matrix of class \code{"matrix"} or a distance matrix of class \code{"dist"}.} \item{X}{a single independent matrix or multiple independent matrices in a list. As with \code{Y} can be a object of class \code{"matrix"} or class \code{"dist"}.} \item{nperm}{number of Mantel permutations.} } \description{ This function conducting a multiple matrix regression (partial Mantel test) and uses Mantel (1967) permutations to test the significance of the model and individual coefficients. It also returns the residual and predicted matrices. } \value{ A list with the following components: \item{r.squared}{multiple R-squared.} \item{coefficients}{model coefficients, including intercept.} \item{tstatistic}{t-statistics for model coefficients.} \item{fstatistic}{F-statistic for the overall model.} \item{probt}{vector of probabilities, based on permutations, for \code{tstatistic}.} \item{probF}{probability of F, based on Mantel permutations.} \item{residuals}{matrix of residuals.} \item{predicted}{matrix of predicted values.} } \references{ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} \keyword{least squares} phytools/man/map.overlap.Rd0000644000176200001440000000353512704764251015437 0ustar liggesusers\name{map.overlap} \alias{map.overlap} \alias{Map.Overlap} \title{Proportional overlap between two mapped character histories on a tree} \usage{ map.overlap(tree1, tree2, tol=1e-6, ...) Map.Overlap(tree1, tree2, tol=1e-06, standardize=TRUE, ...) } \arguments{ \item{tree1}{an object of class \code{"simmap"}.} \item{tree2}{an object of class \code{"simmap"}.} \item{tol}{an optional tolerance value.} \item{standardize}{for \code{Map.Overlap}, a logical value indicating whether or not to standardize overlap by dividing by the summed branch length of the tree.} \item{...}{optional arguments, such as \code{check.equal}, a logical value indicating whether or not to check if \code{tree1} and \code{tree2} match in underlying topology and branch lengths (they should). This value is \code{TRUE} by default, but can be set to \code{FALSE} if \code{tree1} and \code{tree2} are known to be equal to speed up calculation.} } \description{ This function computes the fraction of a stochastic character mapping that is shared between two differently mapped trees. In \code{map.overlap} it will compute a single quantitying giving the overall similarity of the maps, consequently this measure only makes sense of some or all of the states are shared between the two mapped tress. In \code{Map.Overlap} is computed in which the rows are states observed in \code{tree1} and columns give the states for \code{tree2}. } \value{ A numerical value on the interval 0-1, for \code{map.overlap}; or a matrix (\code{Map.Overlap}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/roundPhylogram.Rd0000644000176200001440000000333113066534146016217 0ustar liggesusers\name{roundPhylogram} \alias{roundPhylogram} \title{Plot a round phylogram} \usage{ roundPhylogram(tree, fsize=1.0, ftype="reg", lwd=2, mar=NULL, offset=NULL, direction="rightwards", type="phylogram", xlim=NULL, ylim=NULL, ...) } \arguments{ \item{tree}{an object of class "phylo" or "multiPhylo" containing one or multiple phylogenies.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].} \item{offset}{offset for the tip labels.} \item{direction}{plotting direction. Only the option \code{direction="rightwards"} is presently supported.} \item{type}{plot type. Can be \code{"phylogram"} or \code{"cladogram"}. If \code{type="cladogram"} then the branch lengths are not necessary (and, indeed, are not used).} \item{xlim}{x-limits for the plot.} \item{ylim}{y-limits for the plot.} \item{...}{optional arguments.} } \description{ Function plots one or multiple round phylograms. } \details{ The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plotSimmap}}. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/edgeProbs.Rd0000644000176200001440000000242712620733055015117 0ustar liggesusers\name{edgeProbs} \alias{edgeProbs} \title{Compute the relative frequencies of state changes along edges} \usage{ edgeProbs(trees) } \arguments{ \item{trees}{an object of class \code{"multiSimmap"} containing a sample of trees that are identical in topology & branch lengths with different stochastically mapped character histories.} } \description{ This function computes the relative frequencies of character state changes along edges from a sample of stochastically mapped character histories. This function assumes that all trees in the sample differ only in their mapped histories & not at all in topology or branch lengths. Note that it only asks whether the starting and ending states of the edge differ in a particular way, and thus ignores multiple-hits along a single edge. } \value{ The object that is returned is a matrix with the state changes & the relative frequency of each state change. Rows are in the order of the matrix \code{edge} for any of the mapped trees. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/skewers.Rd0000644000176200001440000000364112464427353014676 0ustar liggesusers\name{skewers} \alias{skewers} \title{Matrix comparison using the method of random skewers} \usage{ skewers(X, Y, nsim=100, method=NULL) } \arguments{ \item{X}{covariance matrix.} \item{Y}{covariance matrix.} \item{nsim}{number of random vectors.} \item{method}{method to generate a null distribution of the random skewers correlation between matrices. If \code{method=NULL} then the correlation will be compared to the correlation between random vectors; however this test has type I error substantially above the nominal level for ostensibly random matrices. Other values of \code{method} will be passed as \code{covMethod} to \code{genPositiveDefMat} for a more robust hypothesis test (see below). Recommended values include \code{"unifcorrmat"}.} } \description{ This function performs the random skewers matrix comparison method of Cheverud (1996; also see Cheverud & Marroig 2007 for more details). In addition, it includes a more robust hypothesis test in which random covariance matrices are simulated under a variety of models, and then the mean correlation between response vectors to random skewers are computed. } \value{ A list with the following components: \item{r}{mean random skewers correlation.} \item{p}{p-value from simulation.} } \references{ Cheverud, J. M. (1996) Quantitative genetic analysis of cranial morphology in the cotton-top (Saguinus oedipus) and saddle-back (S. fuscicollis) tamarins. \emph{J. Evol. Biol.}, \bold{9}, 5--42. Cheverud, J. M. & Marroig, G. (2007) Comparing covariance matrices: Random skewers method compared to the common principal components model. \emph{Genetics & Molecular Biology}, \bold{30}, 461--469. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} phytools/man/add.color.bar.Rd0000644000176200001440000000350413066536410015613 0ustar liggesusers\name{add.color.bar} \alias{add.color.bar} \title{Add color bar to a plot} \usage{ add.color.bar(leg, cols, title=NULL, lims=c(0,1), digits=1, prompt=TRUE, lwd=4, outline=TRUE, ...) } \arguments{ \item{leg}{numerical value for the length of the legend.} \item{cols}{colors for the legend.} \item{title}{text to plot above the bar.} \item{lims}{range for the bar.} \item{digits}{digits for plotted numbers.} \item{prompt}{logical value indicating whether the location of the legend should be obtained interactively.} \item{lwd}{width of the plotted bar.} \item{outline}{logical value indicated whether or not to outline the plotted color bar with a 1 pt line.} \item{...}{optional arguments including: \code{x} x-coordinate of the legend (if \code{prompt=FALSE}); \code{y} y-coordinate of the legend; \code{subtitle} optional legend subtitle; \code{direction} direction of the color bar (i.e., increase from left to right or from right to left); and \code{fsize}, font size for the legend text.} } \description{ This function adds a color bar to a plot created by \code{\link{plotBranchbyTrait}}. A color bar can be added by clicking on a location within the plot (when \code{prompt=TRUE}) or by setting \code{prompt=FALSE} and supplying x & y coordinates for the object. This function is also used internally by S3 methods \code{\link{plot.contMap}} and \code{\link{plot.densityMap}}, as well as by \code{\link{errorbar.contMap}}. } \references{ Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{errorbar.contMap}}, \code{\link{plotBranchbyTrait}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/add.everywhere.Rd0000644000176200001440000000161213066523303016112 0ustar liggesusers\name{add.everywhere} \alias{add.everywhere} \title{Add tip to all edges in a tree} \usage{ add.everywhere(tree, tip.name) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{tip.name}{a string containing the name of the tip to add.} } \description{ This function adds a tip to all branches of the tree and returns a a list of trees as an object of class \code{"multiPhylo"}. } \value{ A list of trees as an object of class \code{"multiPhylo"}. Since the tip can be added to any branch, the length of the list is equal to the number of edges in \code{tree}. } \author{Liam Revell \email{liam.revell@umb.edu}} \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \seealso{ \code{\link{allFurcTrees}}, \code{\link{exhaustiveMP}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/make.era.map.Rd0000644000176200001440000000210313066530713015434 0ustar liggesusers\name{make.era.map} \alias{make.era.map} \title{Create "era" map on a phylogenetic tree} \usage{ make.era.map(tree, limits, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{limits}{a vector containing the temporal limits, in time since the root node of the tree, for the mappings.} \item{...}{optional arguments.} } \description{ This function creates a temporal map on the tree based on \code{limits} provided by the user. } \value{ An object of class \code{"simmap"} with the specified eras mapped as different regimes. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}} } \examples{ tree<-pbtree(n=1000,scale=100) tree<-make.era.map(tree,c(0,25,50,75)) plotSimmap(tree,pts=FALSE,ftype="off") } \keyword{phylogenetics} \keyword{comparative method} phytools/man/mergeMappedStates.Rd0000644000176200001440000000205612464434143016617 0ustar liggesusers\name{mergeMappedStates} \alias{mergeMappedStates} \title{Merge two or more mapped states into one state} \usage{ mergeMappedStates(tree, old.states, new.state) } \arguments{ \item{tree}{a modified object of class \code{"phylo"} or \code{"multiPhylo"} with a mapped discrete character.} \item{old.states}{states to merge.} \item{new.state}{name for new state.} } \description{ This function merges two or mapped states on the tree to get one new state. For instance, one could merge the states \code{"C"}, \code{"G"}, and \code{"T"} to get the state \code{"not-A"}. } \value{ A modified object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} \keyword{utilities} phytools/man/sampleFrom.Rd0000644000176200001440000000155612464427604015322 0ustar liggesusers\name{sampleFrom} \alias{sampleFrom} \title{Sample from a set of distributions} \usage{ sampleFrom(xbar=0, xvar=1, n=1, randn=NULL, type="norm") } \arguments{ \item{xbar}{a named vector of means.} \item{xvar}{a named vector of variances.} \item{n}{a vector containing the sample sizes of each species.} \item{randn}{a range of sample sizes are to be random.} \item{type}{\code{"norm"} is the only distribution implemented so far.} } \description{ Function samples from a set of normal distributions with parameters given in \code{xbar} and \code{xvar}. } \value{ A vector, with labels. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} phytools/man/starTree.Rd0000644000176200001440000000137612464427273015010 0ustar liggesusers\name{starTree} \alias{starTree} \title{Create star phylogeny} \usage{ starTree(species, branch.lengths=NULL) } \arguments{ \item{species}{a list of species.} \item{branch.lengths}{an optional list of branch lengths in the same order as \code{species}.} } \description{ This function creates a star phylogeny. } \details{ Creates a star phylogeny with (optionally) user specified branch lengths. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{stree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/treeSlice.Rd0000644000176200001440000000322713072304613015117 0ustar liggesusers\name{treeSlice} \alias{treeSlice} \title{Slices the tree at a particular point and returns all subtrees, or the tree rootward of the point} \usage{ treeSlice(tree, slice, trivial=FALSE, prompt=FALSE, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{slice}{a real number indicating the height above the root at which to slice the tree.} \item{trivial}{a logical value indicating whether or not to return subtrees with a number of tips less than two (default is \code{FALSE}).} \item{prompt}{logical value indicating whether or not the height of the slice should be given interactively.} \item{...}{for \code{prompt=TRUE}, other arguments to be passed to \code{\link{plotTree}}. In addition, the argument \code{orientation} can be used to specify whether the \code{"tipwards"} subtrees or the \code{"rootwards"} phylogeny are/is to be returned by the function call (using those two argument values, respectively).} } \description{ This function slices a tree at a particular height above the root and returns all subtrees or all non-trivial subtrees (i.e., subtrees with more than 1 taxon). Uses \code{\link{extract.clade}} in the "ape" package. It can also be used to crop the terminal fraction of a tree for \code{orientation="rootwards"}. } \value{ An object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plotTree.errorbars.Rd0000644000176200001440000000220313066533510016772 0ustar liggesusers\name{plotTree.errorbars} \alias{plotTree.errorbars} \title{Plot a tree with error bars around divergence dates} \usage{ plotTree.errorbars(tree, CI, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{CI}{confidence intervals around internal nodes of the tree, measured in time since the present.} \item{...}{optional arguments to be passed to \code{\link{plotTree}}.} } \description{ Plots a tree with error bars around divergence times (nodes). } \details{ The matrix CI show contain (in rows) the lower & upper confidence bounds in time since the present. Optional arguments specific to the error bar plot include \code{gridlines}, \code{bar.lwd},\code{cex} (for the points plotted at nodes), and \code{bar.col}. } \value{ Plots a tree with error bars around internal nodes.. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/fitBayes.Rd0000644000176200001440000000472013201657614014753 0ustar liggesusers\name{fitBayes} \alias{fitBayes} \title{Evolutionary model fitting with intraspecific variability using Bayesian MCMC} \usage{ fitBayes(tree, x, ngen=10000, model="BM", method="reduced", control=list()) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of phenotypic values for individuals; \code{names(x)} should contain the species names (not individual IDs).} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{model}{an evolutionary model: either \code{"BM"} or \code{"lambda"}.} \item{method}{a method: either \code{"reduced"} or \code{"full"}.} \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{lambda}: starting value for the \eqn{\lambda} parameter; \code{a}: starting for the state at the root node; \code{xbar}: starting values for the states at the tips; \code{intV}: starting value for the intraspecific variance (reduced method); or \code{v}: starting value for the vector of intraspecific variances for all species (full method); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{lambda} (if applicable), \code{a}, \code{xbar}, \code{intV} or \code{v} (if applicable), note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean}.} } \description{ This function uses Bayesian MCMC to sample terminal states (species means) as well as evolutionary parameters. } \value{ An object of class \code{"fitBayes"} that includes a matrix (\code{mcmc}) with a number of rows \code{ngen/control$sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled by species (for species means and variances), or by the corresponding evolutionary parameter. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. and R. G. Reynolds. (2012) A new Bayesian method for fitting evolutionary models to comparative data with intraspecific variation. \emph{Evolution}, 66, 2697-2707. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/nodelabels.cophylo.Rd0000644000176200001440000000264612612446276017003 0ustar liggesusers\name{nodelabels.cophylo} \alias{nodelabels.cophylo} \alias{tiplabels.cophylo} \alias{edgelabels.cophylo} \title{Add labels to a plotted "cophylo" object} \usage{ nodelabels.cophylo(..., which=c("left","right")) edgelabels.cophylo(..., which=c("left","right")) tiplabels.cophylo(..., which=c("left","right")) } \arguments{ \item{...}{arguments to be passed to \code{\link{nodelabels}}, \code{\link{edgelabels}}, or \code{\link{tiplabels}}.} \item{which}{argument indicated which of the two plotted trees (the \code{"left"} or \code{"right"} tree) to be used.} } \description{ This function adds node, edge, or tip labels to the plotted trees of a \code{"cophylo"} object. } \details{ Note that the order of tips, edges, and nodes may be different in the object of class \code{"cophylo"} than they are in the original input trees, particularly if \code{cophylo(...,rotate=TRUE)} was used. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}}, \code{\link{edgelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/locate.yeti.Rd0000644000176200001440000000344412464426573015437 0ustar liggesusers\name{locate.yeti} \alias{locate.yeti} \title{Locate a cryptic, recently extinct, or missing taxon on a tree} \usage{ locate.yeti(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix with continuous character data.} \item{...}{optional arguments including: \code{method} (\code{"ML"} or \code{"REML"}, defaults to \code{"ML"}); \code{search} (\code{"heuristic"} or \code{"exhaustive"}, defaults to \code{"heuristic"}); \code{constraint}, a vector containing the daughter node numbers from \code{tree$edge} for each edge to try; \code{plot} a logical argument specifying whether or not to plot the likelihood profile on edges (defaults to \code{FALSE}); \code{rotate} a logical indicating whether or not to rotate the data based on the input tree; and \code{quiet}, which is logical and has an obvious interpretation.} } \description{ This function uses ML (or REML) to place a recently extinct, cryptic, or missing taxon on an ultrametric (i.e., time-calibrated) phylogeny. } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (In press) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{maximum likelihood} phytools/man/fastAnc.Rd0000644000176200001440000000401113136166705014560 0ustar liggesusers\name{fastAnc} \alias{fastAnc} \title{(Reasonably) fast estimation of ML ancestral states} \usage{ fastAnc(tree, x, vars=FALSE, CI=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{vars}{a logical value indicating whether or not to compute variances on the ancestral state estimates. Variances are based on Equation (6) of Rohlf (2001).} \item{CI}{a logical value indicating whether or not to compute 95-percent confidence intervals on state estimates.} \item{...}{optional arguments. Presently this consists of \code{anc.states}, a named vector containing ancestral states to fix. Names should correspond to node numbers in the input tree.} } \description{ This function performs (reasonably) fast estimation of the ML ancestral states for a continuous trait by taking advantage of the fact that the state computed for the root node of the tree during Felsenstein's (1985) contrasts algorithm is also the MLE of the root node. Thus, the function reroots the tree at all internal nodes and computes the contrasts state at the root each time. The function can also (optionally) compute variances or 95-percent confidence intervals on the estimates. } \value{ A named vector containing the states at internal nodes - names are node numbers; or a list containing ancestral state estimates (\code{ace}), variances on the estimates (\code{var}), and/or 95-percent confidence intervals (\code{CI95}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{pic}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree) # simulate using fastBM fastAnc(tree,x) # estimate states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/drop.leaves.Rd0000644000176200001440000000141712464425503015427 0ustar liggesusers\name{drop.leaves} \alias{drop.leaves} \title{Drop all the leaves (tips) from a tree} \usage{ drop.leaves(tree, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{...}{optional arguments. Presently includes only the logical value \code{keep.tip.labels} which tells the function how to labels the tips on the reduced tree.} } \description{ Drops all the leaves from a tree, leaving behind only the structure leading to internal nodes. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/plotSimmap.Rd0000644000176200001440000001213113100245200015303 0ustar liggesusers\name{plotSimmap} \alias{plotSimmap} \alias{plot.simmap} \alias{plot.multiSimmap} \title{Plot stochastic character mapped tree} \usage{ plotSimmap(tree, colors=NULL, fsize=1.0, ftype="reg", lwd=2, pts=FALSE, node.numbers=FALSE, mar=NULL, add=FALSE, offset=NULL, direction="rightwards", type="phylogram", setEnv=TRUE, part=1.0, xlim=NULL, ylim=NULL, nodes="intermediate", tips=NULL, maxY=NULL, hold=TRUE, split.vertical=FALSE, lend=2, asp=NA, plot=TRUE) \method{plot}{simmap}(x, ...) \method{plot}{multiSimmap}(x, ...) } \arguments{ \item{tree}{a modified object of class "phylo" or "multiPhylo" containing a stochastic mapping or set of mappings (e.g., see \code{\link{read.simmap}} & \code{\link{make.simmap}}).} \item{colors}{a vector with names translating the mapped states to colors - see \code{Examples}.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{pts}{logical value indicating whether or not to plot filled circles at each vertex of the tree, as well as at transition points between mapped states. Default is \code{FALSE}.} \item{node.numbers}{a logical value indicating whether or not node numbers should be plotted.} \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].} \item{add}{a logical value indicating whether or not to add the plotted tree to the current plot (\code{TRUE}) or create a new plot (\code{FALSE}, the default).} \item{offset}{offset for the tip labels. Primarily to be used internally by \code{\link{densityMap}}.} \item{direction}{plotting direction. Options are \code{"rightwards"} (the default), \code{"leftwards"}, \code{"upwards"} or \code{"downwards"}. For \code{method="fan"} \code{direction} is ignored.} \item{type}{plot type. Can be \code{"phylogram"}, \code{"fan"}, or \code{"cladogram"}. Only a subset of options are presently available for \code{type="fan"}.} \item{setEnv}{logical value indicating whether or not to set the environment \code{.PlotPhyloEnv}. Setting this to \code{TRUE} (the default) will allow compatibility with ape labeling functions such as \code{\link{nodelabels}}.} \item{part}{value between 0 and 1 for \code{type="fan"} indicating what fraction of the full circular tree to use as plotting area. For instance, \code{part=0.5} will plot a half fan phylogeny. It also affects the axis scaling used.} \item{xlim}{x-limits for the plot.} \item{ylim}{y-limits for the plot.} \item{nodes}{node placement following Felsenstein (2004; pp. 574-576). Can be \code{"intermediate"}, \code{"centered"}, \code{"weighted"}, or \code{"inner"}. So far only works for \code{type="phylogram"}.} \item{tips}{labeled vector containing the vertical position of tips. Normally this will be \code{1:N} for \code{N} tips in the tree.} \item{maxY}{maximum value of y to use before rotating a tree into fan configuration. This will only make a difference if different from \code{Ntip(tree)}.} \item{hold}{logical argument indicating whether or not to hold the output to the graphical device before plotting. Defaults to \code{hold=TRUE}.} \item{split.vertical}{split the color of the vertically plotted edges by the state of the daughter edges. Only applies if the edge state changes exactly at a node.} \item{lend}{line end style. See \code{\link{par}}.} \item{asp}{aspect ratio. See \code{\link{plot.window}}.} \item{plot}{logical value indicating whether or not to actually plot the tree. (See equivalent argument in \code{\link{plot.phylo}}.)} \item{x}{for S3 plotting method, object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{...}{for S3 plotting method, other arguments to be passed to \code{\link{plotSimmap}}.} } \description{ Function plots one or multiple stochastic character mapped trees. } \details{ The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plot.phylo}}. } \value{ Plots a tree. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{densityMap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}} } \examples{ # simulate a mapped tree Q<-matrix(c(-2,1,1,1,-2,1,1,1,-2),3,3) rownames(Q)<-colnames(Q)<-letters[1:3] tree<-sim.history(pbtree(n=100,scale=1),Q) cols<-setNames(c("blue","red","green"),letters[1:3]) # plot the mapping plot(tree,cols,ftype="i",fsize=0.7) } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/strahlerNumber.Rd0000644000176200001440000000243212464427254016205 0ustar liggesusers\name{strahlerNumber} \alias{strahlerNumber} \alias{extract.strahlerNumber} \title{Computes Strahler number for trees and nodes} \usage{ strahlerNumber(tree, plot=TRUE) extract.strahlerNumber(tree, i, plot=TRUE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{i}{order of Strahler number to extract for \code{extract.strahlerNumber}.} \item{plot}{logical value indicating whether to plot the tree with Strahler numbers for node labels.} } \description{ The function \code{strahlerNumber} computes the Strahler number of all nodes and tips in the tree. For more information about Strahler numbers see \url{http://en.wikipedia.org/wiki/Strahler_number}. The function \code{extract.strahlerNumber} extracts all of the most inclusive clades of Strahler number \code{i}. } \value{ Either a vector with the Strahler number for each tip and internal node; or (for \code{extract.strahlerNumber} the set of (most inclusive) subtrees with Strahler number \code{i} as an object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/read.simmap.Rd0000644000176200001440000000544312464430640015406 0ustar liggesusers\name{read.simmap} \alias{read.simmap} \title{Read SIMMAP style trees from file} \usage{ read.simmap(file="", text, format="nexus", rev.order=TRUE, version=1) } \arguments{ \item{file}{name of text file with one or multiple SIMMAP v1.0 or v1.5 style trees.} \item{text}{character string containing the tree. If \code{version=1.5} this argument is ignored. (This format tree can only be read from file in the present version.)} \item{format}{format of the trees: either \code{"phylip"} or \code{"nexus"} - the latter is the default output from SIMMAP. If \code{version=1.5} this argument is ignored.} \item{rev.order}{a logical value indicating whether the states and times along each branch is given (from root to tip) in right-to-left order (if TRUE) or in left-to-right order. If \code{version=1.5} this argument is ignored.} \item{version}{version of SIMMAP for input tree. If the tree(s) was/were simulated in SIMMAP v1.0 or written to file by \code{link{make.simmap}} then \code{version=1.0}; if the tree(s) was/were simulated using SIMMAP v1.5 then \code{version=1.5}.} } \description{ This reads one or multiple SIMMAP style trees from file. } \details{ This function now accepts trees in both SIMMAP v1.0 and SIMMAP v1.5 format. In addition, it can read a more flexible format than is produced by SIMMAP (for instance, multi-character mapped states and more than 7 mapped states). Uses some modified code from \code{\link{read.nexus}} from the "ape" package to read the NEXUS block created by SIMMAP. Also creates the attribute \code{"map.order"} which indicates whether the stochastic map was read in from left to right or right to left. This attribute is used by default by \code{\link{write.simmap}} to write the tree in the same order. } \value{ A modified object of class \code{"phylo"} (or list of class \code{"multiPhylo"}) with the following additional elements: \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.} \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.} } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{read.tree}}, \code{\link{read.nexus}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/evol.vcv.Rd0000644000176200001440000000551313066527342014753 0ustar liggesusers\name{evol.vcv} \alias{evol.vcv} \title{Likelihood test for variation in the evolutionary VCV matrix} \usage{ evol.vcv(tree, X, maxit=2000, vars=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"simmap"}.} \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{vars}{an optional logical value indicating whether or not to estimate the variances of the parameter estimates from the Hessian matrix.} \item{...}{optional arguments.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for an arbitrary number of continuously valued character. It then fits the multiple evolutionary variance-covariance matrix (rate matrix) model of Revell & Collar (2009; \emph{Evolution}). } \details{ This function performs optimization by first optimizing the likelihood with respect to the Cholesky matrices using \code{\link{optim}}. Optimization is by \code{method="Nelder-Mead"}. Using box constraints does not make sense here as they would be applied to the Cholesky matrix rather than the target parameters. May have to increase \code{maxit} for large trees and more than 2 traits. } \value{ An object of class \code{"evol.vcv"} with the following components: \item{R.single}{vcv matrix for the single rate matrix model.} \item{vars.single}{optionally, a matrix containing the variances of the elements of \code{R.single}.} \item{logL1}{log-likelihood for single matrix model.} \item{k1}{number of parameters in the single marix model.} \item{R.multiple}{\code{m} x \code{m} x \code{p} array containing the \code{p} estimated vcv matrices for the \code{p} regimes painted on the tree.} \item{vars.multiple}{optionally, an array containing the variances of the parameter estimates in \code{R.multiple}.} \item{logL.multiple}{log-likelihood of the multi-matrix model.} \item{k2}{number of parameters estimated in this model.} \item{P.chisq}{P-value of the \eqn{\chi^2} test on the likelihood ratio.} \item{convergence}{logical value indicating whether or not the optimization has converged.} } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{brownie.lite}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/print.backbonePhylo.Rd0000644000176200001440000000125112464430742017115 0ustar liggesusers\name{print.backbonePhylo} \alias{print.backbonePhylo} \title{Print method for backbone phylogeny} \usage{ \method{print}{backbonePhylo}(x, ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{...}{optional arguments.} } \description{ Print method for an object of class \code{"backbonePhylo"}. } \value{ Prints to screen. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/posthoc.Rd0000644000176200001440000000076513161575070014671 0ustar liggesusers\name{posthoc} \alias{posthoc} \title{Generic post-hoc test} \usage{ posthoc(x, ...) } \arguments{ \item{x}{an object on which to conduct a post-hoc test.} \item{...}{optional arguments to be passed to method.} } \description{ This function conducts posthoc test. } \details{ So far is only implemented for object class \code{"ratebytree"}. } \value{ An object. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ratebytree}} } \keyword{statistics} phytools/man/bind.tip.Rd0000644000176200001440000000317513066526173014723 0ustar liggesusers\name{bind.tip} \alias{bind.tip} \title{Attaches a new tip to a tree} \usage{ bind.tip(tree, tip.label, edge.length=NULL, where=NULL, position=0, interactive=FALSE, ...) } \arguments{ \item{tree}{receptor tree.} \item{tip.label}{a string containing the species name for the new tip.} \item{edge.length}{edge length for the new tip (a scalar).} \item{where}{node number to attach new tip. If \code{position>0} then then tip will be attached \emph{below} the specified node. Node numbers can also be tips, in which case the new tip will be added along the terminal edge. To find out the tip number for given species with name \emph{"species"} type: \code{which(tree$tip.label=="species"}.} \item{position}{distance \emph{below} node to add tip.} \item{interactive}{logical value indicating whether or not the species should be added interactively. (Defaults to \code{FALSE}.)} \item{...}{arguments to be passed to \code{plotTree} (for \code{interactive=TRUE}.)} } \description{ Functions adds a new tip to the tree. If the tree is ultrametric and no branch length is specified, then \code{edge.length} is scaled so that the tree remains ultrametric after the new tip is added. } \details{ Wrapper function for 'ape' \code{\link{bind.tree}}. Note that \code{interactive=TRUE} works only for right-facing phylograms. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ancThresh.Rd0000644000176200001440000000623113201660041015107 0ustar liggesusers\name{ancThresh} \alias{ancThresh} \title{Ancestral character estimation under the threshold model using Bayesian MCMC} \usage{ ancThresh(tree, x, ngen=10000, sequence=NULL, method="mcmc", model=c("BM","OU","lambda"), control=list(), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{ngen}{number of generations to run the MCMC.} \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical/alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.} \item{method}{only method currently available is \code{"mcmc"}.} \item{model}{model for the evolution of the liability. Options are \code{"BM"} (Brownian motion, the default), \code{"OU"} (Ornstein-Uhlenbeck), or \code{"lambda"} (the lambda model).} \item{control}{list containing the following elements: \code{sample}, the sampling interval; \code{propliab} variance of the proposal distribution for liabilities; \code{propthresh} variance on the proposal distribution for the thresholds; \code{propalpha} variance on the proposal distribution for \code{alpha} (for \code{model="OU"}); \code{pr.anc} prior probability distribution on the ancestral states for each node, in a matrix - not all nodes need to be supplied; \code{pr.th} prior density on the thresholds; \code{burnin} number of generations to exclude for burn-in when plotting posterior probabilities on the tree; \code{plot} logical value indicating whether or not to plot the posterior probabilities; \code{print} logical value indicating whether or not to print the state of the MCMC; \code{piecol} colors for the posterior probabilities plotted as pie charts at internal nodes; and \code{tipcol} which indicates whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.} \item{...}{additional arguments to be passed to \code{\link{plotThresh}} (called internally).} } \description{ This function uses Bayesian MCMC to estimate ancestral states and thresholds for a discrete character under the threshold model from quantitative genetics (Felsenstein 2012). } \details{ \code{print} and \code{plot} S3 methods are now available for the object class \code{"ancThresh"}. } \value{ This function returns an object of class \code{"ancThresh"} containing the posterior sample from our analysis, although with other components. } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{threshBayes}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/matchNodes.Rd0000644000176200001440000000411712667615536015306 0ustar liggesusers\name{matchNodes} \alias{matchNodes} \alias{matchLabels} \title{Matches nodes between two trees} \usage{ matchNodes(tr1, tr2, method=c("descendants","distances"), ...) matchLabels(tr1, tr2) } \arguments{ \item{tr1}{first tree.} \item{tr2}{second tree.} \item{method}{method to use to match nodes between trees. \code{"descendants"} uses the tip species descended from each node; \code{"distances"} uses the distances from the nodes to the tips. Any umambiguous shortening of \code{"descendants"} or \code{"distances"} is allowed.} \item{...}{optional arguments which may or may not be used depending on \code{method}. \code{tol} is a tolerance value for the difference from exact matching that is allowed for \code{method="distances"}. \code{corr}, which is \code{FALSE} by default, indicates whether to match nodes under \code{method="distances"} using the correlation (\code{corr=TRUE}) or the absolute similarity of distances.} } \description{ This function returns a matrix in which the first column contains all the internal nodes for \code{tr1} and the second column contains the matching nodes from \code{tr2}, inasmuch as they can be identified. For \code{method="descendants"}, pairs of matching nodes are defined by sharing all descendant leaves in common. for \code{method="distances"}, nodes are considered to matched if the share the same set of distances (or proportional distances, for optional argument \code{corr=TRUE}) to all tips. \code{matchLabels} is functionally equivalent but matches node (tip) numbers based on the labels only. } \details{ Primarily designed to be used internally by \code{\link{fastAnc}}. } \value{ A matrix in which the first column contains the nodes of \code{tr1} with the second column containing matching nodes in \code{tr2}, with the criterion for matching defined by \code{method}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/phylomorphospace.Rd0000644000176200001440000000624613066533104016602 0ustar liggesusers\name{phylomorphospace} \alias{phylomorphospace} \title{Creates phylomorphospace plot} \usage{ phylomorphospace(tree, X, A=NULL, label=c("radial","horizontal","off"), control=list(), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format, or a modified \code{"phylo"} object with a mapped discrete character.} \item{X}{an \code{n} x 2 matrix of tip values for two characters in \code{n} species.} \item{A}{an optional \code{m} x 2 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{fastAnc}}.} \item{label}{string indicating whether to plot the tip labels in the same direction as the terminal edge (\code{label="radial"}), horizontally \code{label="horizontal"}, or not at all \code{"off"}. \code{label=TRUE} and \code{label=FALSE} are also acceptable, for compatibility with phytools <= 0.3-03.} \item{control}{a list containing the following optional control parameters: \code{col.edge}: a vector of edge colors; and \code{col.node}: a vector of node colors.} \item{...}{optional arguments for plotting, including \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab}, \code{lwd}, \code{colors}, \code{fsize}, and \code{node.by.map}. \code{colors} is only used when there is a mapped discrete character on the tree, in which case \code{control$col.edge} is ignored. \code{fsize} is relative to the default, which is \code{textxy(...,cx=0.75)}. \code{node.by.map} is a logical value (defaults to \code{FALSE} which tells the function whether or not to plot the node colors using the colors of the mapped discrete character. Setting this option to \code{TRUE} will cause \code{control$col.node} to be ignored. \code{node.size} is a vector containing the point size relative to the default (see \code{\link{par}} for plotted internal nodes and tips, respectively. Defaults to \code{node.size=c(1,1.3)}. If only one number is provided it will be recycled. \code{axes} is a logical value indicating whether or not axes should be plotted (see \code{\link{plot.default}}. Finally, \code{add} indicates whether to add the phylmorphospace to the current plot.} } \description{ This function creates a phylomorphospace plot (a projection of the tree into morphospace) for two characters following Sidlauskas (2008; \emph{Evolution}). It will also plot a discrete character mapped on tree. } \value{ This function creates a phylomorphospace plot } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-90. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=25) X<-fastBM(tree,nsim=2) phylomorphospace(tree,X,xlab="trait 1",ylab="trait 2") } \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} phytools/man/consensus.edges.Rd0000644000176200001440000000257212701474445016321 0ustar liggesusers\name{consensus.edges} \alias{consensus.edges} \title{Compute consensus edges for a tree under some criterion} \usage{ consensus.edges(trees, method=c("mean.edge","least.squares"), ...) } \arguments{ \item{trees}{object of class \code{"multiPhylo"} in which the trees must have edge lengths. This could be, for instance, a sample from the posterior distribution of trees in a Bayesian analysis.} \item{method}{method for computing the edge lengths. Could be the mean of all trees in which the edge is present, or it could be the least-squares edge lengths computed on the mean patristic distance matrices from the input phylogenies in \code{trees}. Note that in the latter case the phangorn function \code{nnls.tree} is used and the option \code{rooted} will be set to \code{is.rooted(tree)} for the consensus tree.} \item{...}{optional arguments, the most popular of which is \code{consensus.tree} - a user supplied consensus tree. Another optional argument for \code{method="mean.edge"} is \code{if.absent} which tells the function how to include absent edges in the computation of average edge lengths. Possible values are \code{"zero"} (the default) or \code{"ignore"}.} } \description{ This function computes consensus edge lengths by different methods. } \value{ An object of class \code{"phylo"} with edge lengths. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} phytools/man/multiC.Rd0000644000176200001440000000171213066531254014440 0ustar liggesusers\name{multiC} \alias{multiC} \title{Returns a list with phylogenetic VCV matrix for each mapped state} \usage{ multiC(tree, internal=FALSE) } \arguments{ \item{tree}{a phylogeny with mapped discrete state in a modified object of class \code{"phylo"} (e.g., see \code{\link{read.simmap}}.} \item{internal}{logical value indicating whether or not internal nodes should be returned.} } \description{ This function takes a modified \code{"phylo"} object as input and returns a set of so-called phylogenetic covariance matrices as a list: one for each mapped state. } \value{ A list of matrices. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evolvcv.lite}}, \code{\link{read.simmap}}, \code{\link{vcvPhylo}}, \code{\link{vcv.phylo}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plot.backbonePhylo.Rd0000644000176200001440000000372212742001411016726 0ustar liggesusers\name{plot.backbonePhylo} \alias{plot.backbonePhylo} \title{Plots backbone tree with triangles as clades} \usage{ \method{plot}{backbonePhylo}(x, ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{...}{optional arguments. Includes \code{vscale} (to rescale the vertical dimension in plotting), \code{fixed.height} (logical value to fix the plotted height of subtree triangles), \code{print.clade.size} (logical), \code{fixed.n1} (logical value indicating whether or not to use the fixed triangle height for subtrees containing only one taxon, or to plot as a leaf - defaults to \code{FALSE}), and \code{col} (a single value, or a vector with names, giving the clade colors), as well as \code{xlim}, \code{ylim}, and \code{lwd} (as well as perhaps other standard plotting arguments).} } \description{ Function plots a backbone tree (stored as an object of class \code{"backbonePhylo"}) with triangles as subtrees. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \examples{ ## first create our backbone tree with ## random subtree diversities tree<-phytools:::lambdaTree(pbtree(n=10),lambda=0.5) ## create a translation table ## leaving a couple of single-taxon clades for fun tip.label<-sample(tree$tip.label,8) clade.label<-LETTERS[1:8] N<-ceiling(runif(n=8,min=1,max=20)) ## set crown node depth to 1/2 the maximum depth depth<-sapply(tip.label,function(x,y) 0.5*y$edge.length[which(tree$edge[,2]== which(y$tip.label==x))],y=tree) trans<-data.frame(tip.label,clade.label,N,depth) rownames(trans)<-NULL rm(tip.label,clade.label,N,depth) ## here's what trans looks like trans ## convert obj<-phylo.toBackbone(tree,trans) ## plot plot(obj) } \keyword{phylogenetics} \keyword{plotting} phytools/man/phenogram.Rd0000644000176200001440000001027613066532165015172 0ustar liggesusers\name{phenogram} \alias{phenogram} \title{Plot phenogram (traitgram)} \usage{ phenogram(tree, x, fsize=1.0, ftype="reg", colors=NULL, axes=list(), add=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, with or without a mapped discrete character.} \item{x}{a vector containing the states at the tips \emph{or} the states at all the tips and the internal nodes of the tree.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{colors}{colors for plotting the mapped character (if available) in \code{tree}. If no character is mapped on the tree, then a single color for all the branches of the tree can be provided.} \item{axes}{list of axis dimensions. Items are \code{time} and \code{trait}.} \item{add}{optional logical value indicating whether to add to an open plot. If \code{TRUE}, then new axes will not be plotted.} \item{...}{optional arguments including \code{xlim}, \code{ylim}, \code{log}, \code{main}, \code{sub}, \code{xlab}, \code{ylab}, \code{asp}, \code{type}, \code{lty}, \code{lwd}, \code{offset}, and \code{digits} are as in \code{\link{plot.default}} or \code{\link{par}}. Note that \code{axes} overrides \code{xlim} and \code{ylim}. \code{spread.labels} is a logical value indicating whether or not to minimize tip label overlap (default is \code{TRUE}); \code{spread.cost} is a numeric vector indicating the relative penalty to be used for label overlap and deviance, respectively (if \code{spread.labels=TRUE}); \code{spread.range} is the range over which to (potentially) spread the labels - note that if labels do not overlap, not all of that range will be used; finally, \code{link} is a numeric value by which to offset the tip labels, linking them to the tips with a dashed line (default is \code{0}, if \code{spread.labels=FALSE}, or 10-percent of the total tree length otherwise). The optional argument \code{offsetFudge} "fudges" the computation of label offset in scaling \code{xlim}. It is 1.37, which is the correct fudge in the Windows R GUI, but this may need to be changed in other systems. \code{hold} indicates whether (or not) the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). \code{quiet} suppresses some system messages if set to \code{quiet=TRUE}.} } \description{ Function plots a traitgram (Evans et al. 2009), that is, a projection of the phylogenetic tree in a space defined by phenotype (on the \emph{y} axis) and time (on the \emph{x}). If a discrete character is mapped on the tree this will also be plotted. } \details{ For \code{spread.labels=TRUE} numerical optimization is performed to optimize the distribution of the labels vertically, where the solution depends on the vector \code{spread.cost} containing the cost of overlap (first) and the cost of deviation from the vertical position of the tip. Note that because this is done via numerical optimization, plotting may hang briefly while the best solution is found (especially for large trees). } \value{ Plots a traitgram, optionally with a mapped discrete character, and (invisibly) returns a matrix containing the coordinates of the plotted tip labels. } \references{ Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ \dontrun{ tree<-pbtree(n=20,scale=2) x<-fastBM(tree) phenogram(tree,x) # or, simulate a discrete character history tree<-sim.history(tree,Q=matrix(c(-1,1,1,-1),2,2),anc="1") # simulate in which the rate depends on the state x<-sim.rates(tree,c(1,10)) phenogram(tree,x) # now use spread.labels tree<-pbtree(n=40) x<-fastBM(tree) phenogram(tree,x,spread.labels=TRUE,spread.cost=c(1,0)) } } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/minSplit.Rd0000644000176200001440000000324112464433603015001 0ustar liggesusers\name{minSplit} \alias{minSplit} \title{Finding the minimum (median) split in the posterior sample} \usage{ minSplit(tree, split.list, method="sum", printD=FALSE) } \arguments{ \item{tree}{a phylogeny stored as an object of class \code{"phylo"}.} \item{split.list}{either a matrix with two named columns, \code{"node"} and \code{"bp"}; a \code{$mcmc} matrix from \code{evol.rate.mcmc()}; or the entire raw output from \code{evol.rate.mcmc()}.} \item{method}{an optional string indicating the criterion to minimize: options are \code{"sum"} and \code{"sumsq"}.} \item{printD}{logical specifying whether to print distances to screen (\code{FALSE} by default).} } \description{ This function takes a phylogenetic tree and a list of splits and identifies the split with the smallest summed or summed squared distances to all the other splits. Used to be called \code{min.split()} but was changed to avoid conflict with the generic \code{\link{min}}. } \value{ A list with the following components: \item{node}{node for the minimum split.} \item{bp}{location on the branch leading to \code{node} of the minimum split.} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/densityMap.Rd0000644000176200001440000000731013066527052015321 0ustar liggesusers\name{densityMap} \alias{densityMap} \alias{plot.densityMap} \title{Plot posterior density of stochastic mapping on a tree} \usage{ densityMap(trees, res=100, fsize=NULL, ftype=NULL, lwd=3, check=FALSE, legend=NULL, outline=FALSE, type="phylogram", direction="rightwards", plot=TRUE, ...) \method{plot}{densityMap}(x, ...) } \arguments{ \item{trees}{set of phylogenetic trees in a modified \code{"multiPhylo"} object. Values for a two-state discrete character are mapped on the tree. See \code{\link{make.simmap}} and \code{\link{read.simmap}} for details.} \item{res}{resolution for gradient plotting. Larger numbers indicate a finer (smoother) gradient.} \item{fsize}{relative font size - can be a vector with the second element giving the font size for the legend.} \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, can be a vector with the second element giving font type for the legend.} \item{lwd}{line width for branches. If a vector of two elements is supplied, the second element will be taken to be the desired width of the legend bar.} \item{check}{check to make sure that the topology and branch lengths of all phylogenies in \code{trees} are equal.} \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.} \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.} \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.} \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"densityMap"} will be returned without plotting.} \item{direction}{plotting direction for \code{type="phylogram"}.} \item{x}{for \code{plot.densityMap}, an object of class \code{"densityMap"}.} \item{...}{optional arguments for \code{plot.densityMap}. These include all the arguments of \code{densityMap} except \code{trees} and \code{res}. Additional optional arguments include \code{mar} (margins), \code{offset} (tip label offset), and \code{hold} (whether or not to use \code{dev.hold} to hold output to graphical device before plotting; defaults to \code{hold=TRUE}). Also, the argument \code{states} can be used to 'order' the states on the probability axis (that is, which state should correspond to a posterior probability of 0 or 1). Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work.} } \description{ Function plots a tree with the posterior density for a mapped character from stochastic character mapping on the tree. Since the mapped value is the probability of being in state "1", only binary [0,1] characters are allowed. } \value{ Plots a tree and returns an object of class \code{"densityMap"} invisibly. } \references{ Bollback, J. P. 2006. Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. 2003. Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/optim.phylo.ls.Rd0000644000176200001440000000425313066531370016104 0ustar liggesusers\name{optim.phylo.ls} \alias{optim.phylo.ls} \title{Phylogeny inference using the least squares method} \usage{ optim.phylo.ls(D, stree=NULL, set.neg.to.zero=TRUE, fixed=FALSE, tol=1e-10, collapse=TRUE) } \arguments{ \item{D}{a distance matrix.} \item{stree}{an optional starting tree for the optimization.} \item{set.neg.to.zero}{a logical value indicating whether to set negative branch lengths to zero (default \code{TRUE}).} \item{fixed}{a logical value indicating whether to estimate the topology - if \code{TRUE} only the branch lengths will be computed.} \item{tol}{a tolerance value used to assess whether the optimization has converged.} \item{collapse}{ a logical indicating whether to collapse branches with zero length.} } \description{ This function performs phylogeny inference using least-squares. } \details{ Function uses \code{nni} from the "phangorn" package (Schliep 2011) to conduct NNIs for topology estimation. Since topology optimization is performed using NNIs, converge to the true least-squares topology is not guaranteed. It is consequently probably wise to start with a very good tree - such as a NJ tree. } \value{ An objec of class \code{"phylo"} that (may be) the least-squares tree with branch lengths; also returns the sum of squares in \code{attr(tree,"Q-score")}. } \references{ Cavalli-Sforza, L. L., and A. W. F. Edwards. (1967) Phylogenetic analysis: Modesl and estimation procedures. \emph{American Journal of Human Genetics}, \bold{19}, 233-257. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer. (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{nni}} } \keyword{phylogenetics} \keyword{inference} \keyword{distance matrix} \keyword{least squares} phytools/man/to.matrix.Rd0000644000176200001440000000135712464427052015136 0ustar liggesusers\name{to.matrix} \alias{to.matrix} \title{Convert a character vector to a binary matrix} \usage{ to.matrix(x, seq) } \arguments{ \item{x}{a vector of characters.} \item{seq}{the sequence for the columns in the output matrix.} } \description{ This function takes a vector of characters and computes a binary matrix. Primarily to be used internally by \code{\link{make.simmap}} and \code{\link{rerootingMethod}}. } \value{ A binary matrix of dimensions \code{length(x)} by \code{length(seq)}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/setMap.Rd0000644000176200001440000000207412517711334014435 0ustar liggesusers\name{setMap} \alias{setMap} \title{Set color map for objects of class \code{"contMap"} or \code{"densityMap"}} \usage{ setMap(x, ...) } \arguments{ \item{x}{an object of class \code{"contMap"} or \code{"densityMap"}.} \item{...}{arguments to be passed to \code{\link{colorRampPalette}}. Also, the argument \code{invert} which (if \code{invert=TRUE}) will just flip the current color ramp.} } \description{ Function to change the color map (ramp) in an object of class \code{"contMap"} or \code{"densityMap"}. } \value{ An object of class \code{"contMap"} or \code{"densityMap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/likMlambda.Rd0000644000176200001440000000132012464426446015242 0ustar liggesusers\name{likMlambda} \alias{likMlambda} \title{Likelihood for joint lambda} \usage{ likMlambda(lambda, X, C) } \arguments{ \item{lambda}{scalar, usually on the interval 0,1.} \item{X}{data, in a matrix.} \item{C}{matrix probably returned by \code{\link{vcv.phylo}}.} } \description{ Computes the likelihood. } \details{ Do not use unless you know what you're doing. } \value{ A scalar. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{math} \keyword{comparative method} \keyword{utilities} phytools/man/phyl.pca.Rd0000644000176200001440000000471113066532261014722 0ustar liggesusers\name{phyl.pca} \alias{phyl.pca} \alias{biplot.phyl.pca} \title{Phylogenetic principal components analysis} \usage{ phyl.pca(tree, Y, method="BM", mode="cov", ...) \method{biplot}{phyl.pca}(x, ...) } \arguments{ \item{tree}{phylogeny as an object of class \code{"phylo"}.} \item{Y}{data matrix with traits in columns.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} \item{mode}{is the mode for the PCA: can be \code{"cov"} or \code{"corr"}.} \item{x}{object of class \code{"phyl.pca"} for \code{biplot.phyl.pca}.} \item{...}{for S3 plotting method \code{biplot.phyl.pca}, other arguments to be passed to \code{\link{biplot}}.} } \description{ This function performs phylogenetic PCA (e.g., Revell 2009; \emph{Evolution}). } \details{ If \code{method="lambda"} \eqn{\lambda} is optimized on the interval (0,1) using \code{\link{optimize}}. Optimization method can be set using the option \code{opt} which can take values \code{"ML"}, \code{"REML"}, or \code{"fixed"}. If the last of these is selected than the user should also specify a value of \eqn{\lambda} to use via the argument \code{lambda}. S3 methods (\code{print}, \code{summary}, and \code{biplot}) are modified from code provided by Joan Maspons and are based on the same methods for objects of class \code{"prcomp"}. Function \code{biplot} now permits the argument \code{choices} to be supplied, which should be a vector of length two indicated the two PC axes to be plotted. } \value{ An object of class \code{"phyl.pca"} consisting of a list with some or all of the following components: \item{Eval}{diagonal matrix of eigenvalues.} \item{Evec}{matrix with eigenvectors in columns.} \item{S}{matrix with scores.} \item{L}{matrix with loadings.} \item{lambda}{fitted value of lambda (\code{method="lambda"} only).} \item{logL}{log-likelihood for lambda model (\code{method="logL"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{maximum likelihood} \keyword{comparative method} \keyword{statistics} phytools/man/untangle.Rd0000644000176200001440000000204713066534416015025 0ustar liggesusers\name{untangle} \alias{untangle} \title{Attempts to untangle crossing branches for plotting} \usage{ untangle(tree, method=c("reorder","read.tree")) } \arguments{ \item{tree}{tree as an object of class \code{"phylo"} or \code{"simmap"}.} \item{method}{method to use to attempt to untangle branches. \code{method="reorder"} uses two calls of \code{\link{reorder.phylo}} or \code{\link{reorderSimmap}}; \code{method="read.tree"} writes the tree to a text string and then reads it back into memory using \code{\link{read.tree}}.} } \description{ This function attempts to untangle the branches of a tree that are tangled in plotting with \code{\link{plot.phylo}}, \code{\link{plotTree}}, or \code{\link{plotSimmap}}. } \value{ An object of class \code{"phylo"} or \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/sim.history.Rd0000644000176200001440000000510112714670605015472 0ustar liggesusers\name{sim.history} \alias{sim.history} \title{Simulate stochastic character history under some model} \usage{ sim.history(tree, Q, anc=NULL, nsim=1, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{Q}{a matrix containing the instantaneous transition rates between states. Note that normally this is the \emph{transpose} of the matrix produced by \code{fitDiscrete} in the geiger package or \code{\link{make.simmap}} in phytools; that is to say the transition rate from \code{i -> j} should be given by \code{Q[j,i]}. However, if your matrix is properly conformed (i.e., rows \emph{or} columns sum to 0), then \code{sim.history} will attempt to transpose your matrix correctly & will return an informative message (if \code{message=TRUE}, see below).} \item{anc}{an optional value for the state at the root node; if \code{NULL}, a random state will be assigned. \code{anc} can be a vector of states, in which one of the states will be chosen randomly for each simulation. \code{anc} can be a vector of probabilities with names, in which case a state will be chosen in proportion to the given probabilities.} \item{nsim}{number of simulations.} \item{...}{other optional arguments. Currently only \code{message}, a logical value indicating whether or not to turn on informational messages (defaults to \code{message=TRUE}).} } \description{ This function simulates a stochastic character history for a discretely valued character trait on the tree. The resultant tree is stored as a modified \code{"phylo"} object in stochastic character map (e.g., \code{\link{make.simmap}}) format. } \value{ A modified phylogenetic tree of class \code{"phylo"} (or a modified \code{"multiPhylo"} object, for \code{nsim} > 1) with the following additional elements: \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.} \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.} \item{states}{a vector containing the tip states.} \item{node.states}{a matrix containing the states at internal & terminal nodes (according to the dimensions of \code{edge}).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} phytools/man/threshBayes.Rd0000644000176200001440000000577013201660472015470 0ustar liggesusers\name{threshBayes} \alias{threshBayes} \title{Threshold model using Bayesian MCMC} \usage{ threshBayes(tree, X, types=NULL, ngen=10000, control=list(), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a numeric matrix containing values for a numerically coded discrete character and a continuous character; or two discrete characters. The row names of \code{X} should be species names.} \item{types}{a vector of length \code{ncol(X)} containing the data types for each column of \code{X}, for instance \code{c("discrete","continuous")}.} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{control}{a list of control parameters for the MCMC. Control parameters include: \code{sample}, the sampling interval for the MCMC; \code{propvar}, a vector containing (in this order) proposal variances for the two rates (if the type is \code{"discrete"} this will be ignored), the two ancestral states, and the correlation; \code{propliab}, a single proposal variance for the liabilities; \code{pr.mean}, a vector for the mean of the prior probability distributions for each parameter, in the same order as \code{propvar}; \code{pr.liab}, currently ignored; \code{pr.var}, a vector with variances for the prior densities for each parameter, in the same order as \code{pr.mean} - note that for the rates we use an exponential distribution so the first two means are currently ignored; and \code{pr.vliab} currently ignored.} \item{...}{other optional arguments.} } \description{ This function uses Bayesian MCMC to fit the quantitative genetics threshold model (Felsenstein 2012) to data for two discrete characters or one discrete and one continuous character. } \value{ This function returns an object of class \code{"threshBayes"} consisting of a list with at least the following two elements: \code{par} a matrix containing the posterior sample for the model parameters (evolutionary rates, ancestral states, and correlation); \code{liab} a matrix containing the posterior sample of the liabilities. For continuous characters, the liabilities are treated as known and so the posterior samples are just the observed values. } \details{ The \code{plot} method for the object class \code{"threshBayes"} can be used to plot a posterior density of the correlation coefficient, \emph{r}. } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{bmPlot}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/plotThresh.Rd0000644000176200001440000000372413066533367015353 0ustar liggesusers\name{plotThresh} \alias{plotThresh} \title{Tree plotting with posterior probabilities of ancestral states from the threshold model} \usage{ plotThresh(tree, x, mcmc, burnin=NULL, piecol, tipcol="input", legend=TRUE, ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{mcmc}{list object returned by \code{\link{ancThresh}}.} \item{burnin}{number of generations (not samples) to exclude as burn in; if \code{NULL} then 20 percent of generations are excluded as burn-in.} \item{piecol}{a named vector containing the colors for the posterior probabilities plotted as pie charts at internal nodes.} \item{tipcol}{a string indicating whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.} \item{legend}{logical value or text to be plotted in the legend.} \item{...}{other arguments to be passed to \code{\link{plot.phylo}} - \code{label.offset} should be >0 so that tip labels and species names do not overlap.} } \description{ This function uses the object returned by \code{\link{ancThresh}} to plot the posterior probabilities of ancestral states under the threshold model. It is also called internally by \code{\link{ancThresh}}. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}}, \code{\link{plot.phylo}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/anoletree.Rd0000644000176200001440000000133513164532055015161 0ustar liggesusers\name{anoletree} \alias{anoletree} \title{Phylogeny of Greater Antillean anole ecomorph species with mapped discrete character} \description{ A phylogeny of Greater Antillean anole species with a mapped discrete character - 'ecomorph class.' Data and tree are from Mahler et al. (2010). } \usage{ data(anoletree) } \format{ The data are stored as a modified object of class \code{"simmap"} with a mapped discrete character. (E.g., see \code{\link{read.simmap}}.) } \source{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. } \keyword{datasets} phytools/man/splitEdgeColor.Rd0000644000176200001440000000165612572446464016142 0ustar liggesusers\name{splitEdgeColor} \alias{splitEdgeColor} \title{Split edge colors when descendant edges have different mapped states} \usage{ splitEdgeColor(tree,colors,lwd=2) } \arguments{ \item{tree}{object of class \code{"simmap"}.} \item{colors}{named vector of colors to be used for plotting.} \item{lwd}{width of the plotted lines.} } \description{ This function splits the vertical line colors to match the daughter edges when the daughters have different states. Mostly to be used with trees generated using \code{\link{paintBranches}} or \code{\link{paintSubTree}}. Also used internally by \code{\link{plotSimmap}}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/vcvPhylo.Rd0000644000176200001440000000173512464427003015017 0ustar liggesusers\name{vcvPhylo} \alias{vcvPhylo} \title{Calculates cophenetic (i.e., phylogenetic VCV) matrix} \usage{ vcvPhylo(tree, anc.nodes=TRUE, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{anc.nodes}{logical value indicating whether or not to include ancestral nodes.} \item{...}{optional arguments including \code{internal} (synonym of \code{anc.nodes}) and \code{model} (can be \code{"BM"}, \code{"OU"}, or \code{"lambda"}.} } \description{ This function returns a so-called \emph{phylogenetic variance covariance matrix} (e.g., see \code{\link{vcv.phylo}}), but (optionally) including ancestral nodes and under different evolutionary models. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/phylosig.Rd0000644000176200001440000000634413066533213015044 0ustar liggesusers\name{phylosig} \alias{phylosig} \title{Compute phylogenetic signal with two methods} \usage{ phylosig(tree, x, method="K", test=FALSE, nsim=1000, se=NULL, start=NULL, control=list()) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{vector containing values for a single continuously distributed trait.} \item{method}{method to compute signal: can be \code{"K"} or \code{"lambda"}.} \item{test}{logical indicating whether or not to conduct a hypothesis test of \code{"K"} or \code{"lambda"}.} \item{nsim}{for \code{method="K"}, number of simulations in randomization test.} \item{se}{named vector containing the standard errors for each species.} \item{start}{vector of starting values for optimization of (respectively) sigma^2 and lambda. Only used in \code{method="lambda"} and \code{se!=NULL}.} \item{control}{list of control parameters for multidimensional optimization, implemented in \code{\link{optim}}. Only used in \code{method="lambda"} and \code{se!=NULL}.} } \description{ This function computes phylogenetic signal using two different methods. It can also conduct the hypothesis tests for significant phylogenetic signal, and estimate phylogenetic signal incorporating sampling error following Ives et al. (2007). } \details{ \eqn{\lambda} optimization is performed using \code{\link{optimize}} with the range of lambda set between 0 and the theoretical upper limit of lambda (determined by the relative height of the most recent internal node on the tree). } \value{ If \code{(method="K")}, a list with the following components: \item{K}{value of the K-statistic.} \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.} \item{logL}{log-likelihood, for estimation with sampling error.} \item{P}{optionally, the P-value from the randomization test.} If \code{(method="lambda")}, a list with the following components: \item{lambda}{fitted value of lambda.} \item{sig2}{rate of evolution, for estimation with sampling error.} \item{logL}{log-likelihood.} \item{logL0}{log-likelihood for \code{lambda=0.0}.} \item{P}{P-value of the likelihood ratio test.} \item{convergence}{value for convergence, for estimation with sampling error only. (See \code{\link{optim}}).} \item{message}{message from \code{\link{optim}}, for estimation with sampling error only.} } \references{ Blomberg, S. P., T. Garland Jr., A. R. Ives (2003) Testing for phylogenetic signal in comparative data: Behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717-745. Ives, A. R., P. E. Midford, T. Garland Jr. (2007) Within-species variation and measurement error in phylogenetic comparative biology. \emph{Systematic Biology}, \bold{56}, 252-270. Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401}, 877-884. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=100) x<-fastBM(tree) phylosig(tree,x,method="lambda",test=TRUE) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{simulation} phytools/man/read.newick.Rd0000644000176200001440000000256212635356700015403 0ustar liggesusers\name{read.newick} \alias{read.newick} \title{Robust Newick style tree reader} \usage{ read.newick(file="", text, ...) } \arguments{ \item{file}{name of text file with single Newick style tree or multiple trees, one per line.} \item{text}{character string containing tree.} \item{...}{optional arguments to be passed to \code{\link{scan}}. Note that if the arguments \code{sep} or \code{what} are supplied this could generate an error. Useful optional arguments might include \code{skip} (number of lines to skip) and \code{nlines} (number of lines to read).} } \description{ This function reads a Newick style tree from file. } \details{ This function is almost completely redundant with \code{\link{read.tree}}; however it is 'robust' in that it does not fail if the tree contains so-called 'singles' (nodes with only one descendant). } \value{ An object of class \code{"phylo"}, possibly containing singles (see \code{\link{collapse.singles}}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} } \examples{ tree<-"((Human,Chimp),Gorilla),Monkey);" phy<-read.newick(text=tree) } \keyword{phylogenetics} \keyword{input/output} phytools/man/plotBranchbyTrait.Rd0000644000176200001440000000552513066533261016644 0ustar liggesusers\name{plotBranchbyTrait} \alias{plotBranchbyTrait} \title{Plot branch colors by a quantitative trait or value} \usage{ plotBranchbyTrait(tree, x, mode=c("edges","tips","nodes"), palette="rainbow", legend=TRUE, xlims=NULL, ...) } \arguments{ \item{tree}{an object of class "phylo".} \item{x}{either a vector of states for the edges, tips, or nodes of the tree (for \code{mode="edges"}, \code{"tips"}, and \code{"nodes"}, respectively).} \item{mode}{string indicating plotting mode. \code{mode="edges"}, the default, requires that the mapping state of each edge in the tree should be provided. \code{mode="tips"} takes the tip values and estimates the state at each internal node. The mapped character value along each branch is the average of the nodes subtending that branch. \code{mode="nodes"} similar to \code{"tips"}, except that the node values are provided instead of estimated.} \item{palette}{color palette to translate character values to color. Options are presently \code{"rainbow"} (the default), \code{"heat.colors"}, and \code{"gray"}. \code{palette} can also be a function produced by \code{\link{colorRampPalette}}.} \item{legend}{can be a logical value (\code{TRUE} or \code{FALSE}) or a numeric value greater than 0. In the latter case the numeric value gives the length of the plotted legend, which also acts as a scale bar for the branch lengths of the tree.} \item{xlims}{range for the translation map between trait values and the color map. Should be inclusive of all the values in \code{x}.} \item{...}{other optional arguments to be passed to \code{\link{plot.phylo}} - pretty much all arguments are available. In addition, there \code{plotBranchbyTrait} has the following additional optional arguments: \code{tol} a small tolerance value to be added to the range of \code{x}; \code{prompt} for \code{legend=TRUE}, a logical value indicating whether to prompt for the position of the legend (or not) - the default is to put the legend in the lower left hand size of the plot; \code{title} for \code{legend=TRUE}, the title of the legend; and \code{digits} for \code{legend=TRUE}, the number of digits in the quantitative scale of the legend.} } \description{ Function plots a tree with branches colored by the value for a quantitative trait or probability, by various methods. Unlike most other tree plotting functions in phytools, this function calls \code{\link{plot.phylo}} (not \code{plotSimmap}) internally. } \details{ Note that if \code{prompt=TRUE}, the function will prompt for the position of the legend. } \value{ Plots a phylogeny. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/export.as.xml.Rd0000644000176200001440000000215712464444554015740 0ustar liggesusers\name{export.as.xml} \alias{export.as.xml} \title{Export trees & data in XML format} \usage{ export.as.xml(file, trees, X) } \arguments{ \item{file}{filename for export.} \item{trees}{a phylogenetic tree or trees in \code{"phylo"} or \code{"multiPhylo"} format.} \item{X}{a matrix of class \code{"DNAbin"} or a matrix with discretely valued non-DNA character data.} } \description{ This function exports trees & character data in XML format. } \details{ Can be used to create input file for the program SIMMAP v1.5 (Bollback 2006), also see: \url{http://www.simmap.com}. } \value{ A file. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.nexus}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/rerootingMethod.Rd0000644000176200001440000000512713201660213016345 0ustar liggesusers\name{rerootingMethod} \alias{rerootingMethod} \title{Get marginal ancestral state reconstructions by re-rooting} \usage{ rerootingMethod(tree, x, model=c("ER","SYM"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species, or a matrix containing the prior probability that the tip is in each state. If \code{x} is a vector, then \code{names(x)} should be the species names. If \code{x} is a matrix of prior probabilities, then rownames should be species names, column names should be states for the discrete character, and rows of the matrix should sum to 1.0.} \item{model}{any revsersible model. \code{model=c("ER","SYM")} recommended.} \item{...}{optional arguments. Presently the logical argument \code{tips}. If \code{tips=TRUE}, then the function will also compute the empirical Bayes posterior probabilities of the tips following Yang (2006).} } \description{ This function uses the re-rooting method of Yang et al. (1995) to get the marginal ancestral state estimates for each internal node of the tree using likelihood. This method get the conditional scaled likelihoods for the root node (which is the same as the marginal ancestral state reconstruction for that node) and successively moves the root to each node in the tree. The function can also return the posterior probabilities for the tip nodes of the tree. } \details{ This function calls \code{\link{fitMk}} internally. \code{fitMk} uses some code adapted from \code{ace} in the ape package. \code{print} and \code{plot} methods are now available for the object class. } \value{ An object of class \code{"rerootingMethod"} containing at least the following elements: \item{loglik}{the log-likelihood.} \item{Q}{the fitted transition matrix between states.} \item{marginal.anc}{the marginal ancestral state reconstructions for each node (and, optionally, each tip).} } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Yang, Z., Kumar, S., Nei, M. (1995) A new method of inference of ancestral nucleotide and amino acid sequences. \emph{Genetics}, \bold{141}, 1641-1650. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{bayesian} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/map.to.singleton.Rd0000644000176200001440000000326213066531027016402 0ustar liggesusers\name{map.to.singleton} \alias{map.to.singleton} \alias{plotTree.singletons} \alias{drop.tip.singleton} \alias{rootedge.to.singleton} \title{Converts a mapped tree to a tree with singleton nodes} \usage{ map.to.singleton(tree) plotTree.singletons(tree) drop.tip.singleton(tree, tip) rootedge.to.singleton(tree) } \arguments{ \item{tree}{a modified object of class \code{"phylo"} with a mapped discrete character or (for \code{plotTree.singletons} a tree with singleton nodes.} \item{tip}{a tip label or vector of tip labels.} } \description{ The function \code{map.to.singleton} takes an object of class \code{"phylo"} with a mapped discrete character and converts it to a tree with singleton nodes, in which edge has only one state. The states for each edge are stored in \code{names(tree$edge.length)}. \code{plotTree.singletons} plots a tree with singleton nodes. Finally, \code{drop.tip.singleton} drops tips from the tree leaving ancestral nodes for all remaining tips as singletons. \code{rootedge.to.singleton} converts a tree with a root edge to a tree with a singleton node instead. } \value{ An object of class \code{"phylo"} with singleton nodes. \code{plotTree.singletons} plots a tree. If \code{names(tree$edge.length)!=NULL} it will use a different color from \code{\link{palette}} for each mapped state. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{collapse.singles}}, \code{\link{drop.tip}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/reorder.backbonePhylo.Rd0000644000176200001440000000144512464430556017433 0ustar liggesusers\name{reorder.backbonePhylo} \alias{reorder.backbonePhylo} \title{Reorders a backbone phylogeny} \usage{ \method{reorder}{backbonePhylo}(x, order="cladewise", ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{order}{order. See \code{\link{reorder.phylo}} for possible orderings.} \item{...}{optional arguments.} } \description{ Function reorders an object of class \code{"backbonePhylo"}. } \value{ An object of class \code{"backbonePhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/paintSubTree.Rd0000644000176200001440000000365313066531605015616 0ustar liggesusers\name{paintSubTree} \alias{paintSubTree} \alias{paintBranches} \title{Paint sub-trees with a discrete character} \usage{ paintSubTree(tree, node, state, anc.state="1", stem=FALSE) paintBranches(tree, edge, state, anc.state="1") } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"} or a modified object with mapped character traits.} \item{node}{an integer specifying the node number tipward of which the function should paint the derived state.} \item{edge}{an integer or vector of integers specifying the node or tip numbers of the edges that should be painted in \code{paintBranches}.} \item{state}{a string (or numeric value) specifying the state to paint on the tree tipward of \code{node}.} \item{anc.state}{the ancestral state to use; will only be applied if there are presently no character values mapped on the tree.} \item{stem}{logical or numeric value indicating whether to use the derived state on the stem leading to \code{node} (or not, if \code{stem=FALSE}), or, alternatively, what fraction of the stem should be assigned to the derived clade. Note that for tip clades \code{stem=FALSE} is not allowed.} } \description{ This function maps or "paints" an arbitrary, i.e., user-specified, discrete character history on the tree. \code{paintSubTree} paints the clade downstream of \code{node} with a particular state; whereas \code{paintBranches} paints only a specified branch. } \value{ An object of class \code{"simmap"} that contains the specified paintings as a mapped discrete character. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/phylo.heatmap.Rd0000644000176200001440000000375513201722134015753 0ustar liggesusers\name{phylo.heatmap} \alias{phylo.heatmap} \title{Creates a phylogenetic heat map} \usage{ phylo.heatmap(tree, X, fsize=1, colors=NULL, standardize=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix containing data for multiple continuous characters in which \code{rownames} correspond to the tip labels of the tree.} \item{fsize}{an integer or vector of length 3 containing the font size for the tip labels, the trait labels, and the legend text. (If a single integer is supplied, then the value will be recycled.)} \item{colors}{a vector of colors to be passed to \code{\link{image}}. Can be a function call (e.g., \code{heat.colors(n=} \code{200)[200:1]}).} \item{standardize}{a logical value indicating whether or not to standardize each column of \code{X} to have the same variance & mean prior to analysis.} \item{...}{optional arguments. So far these include: \code{legend}, a logical value indicating whether or not to plot a figure legend (defaults to \code{legend=TRUE}); \code{labels}, a logical value indicating whether or not to plot trait labels (defaults to \code{labels=TRUE}); \code{split}, a numeric vector indicating the fraction of the horizontal dimension to use for the tree & heatmap, respectively (defaults to \code{split=c(0.5,0.5)}); \code{xlim}, \code{ylim}, & \code{mar}, defined as in \code{\link{par}}; and \code{ftype}, \code{lwd}, and \code{pts} as defined in \code{\link{plotSimmap}}.} } \description{ Functions creates a multivariate phylogenetic \code{\link{heatmap}}. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ # simulate tree tree <- pbtree(n=20,scale=1) # simulate continuous character X <- fastBM(tree, nsim=5) phylo.heatmap(tree, X, grid=TRUE) } \keyword{phylogenetics} \keyword{plotting} phytools/man/allFurcTrees.Rd0000644000176200001440000000226112464424344015600 0ustar liggesusers\name{allFurcTrees} \alias{allFurcTrees} \title{Generate all bi- and multifurcating unrooted trees} \usage{ allFurcTrees(n, tip.label=NULL, to.plot=TRUE) } \arguments{ \item{n}{an integer giving the desired number of species.} \item{tip.label}{an optional vector of length n containing the tip names.} \item{to.plot}{an optional logical value indicating whether or not to plot the trees.} } \description{ This function creates all possible unrooted bi- and multifurcating trees and returns a list of trees as an object of class \code{"multiPhylo"}. } \details{ This function should be used with caution for \code{n} greater than about 8, as in this case the number of possible trees is extremely large. } \value{ A list of trees as an object of class \code{"multiPhylo"}. } \references{ Felsenstein, J. 2004. \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.everywhere}}, \code{\link{exhaustiveMP}} } \keyword{phylogenetics} \keyword{inference} phytools/man/exhaustiveMP.Rd0000644000176200001440000000303212464425745015632 0ustar liggesusers\name{exhaustiveMP} \alias{exhaustiveMP} \title{Exhaustive and branch & bound MP optimization} \usage{ exhaustiveMP(data, tree=NULL, method="branch.and.bound") } \arguments{ \item{data}{is a \code{\link{phyDat}} (Schliep 2011) object containing DNA or other data.} \item{tree}{an optional input tree (used only with \code{method="branch.and.bound"}).} \item{method}{an optional string indicatingn method to use: \code{"branch.and.bound"} or \code{"exhaustive"}.} } \description{ This function does exhaustive and branch & bound MP searches. } \details{ Should probably not be used for more than about 8 species (and definitely not more than 10 species). Performs parsimony calculations using \code{\link{parsimony}} in the "phangorn" package (Schliep 2011). } \value{ A \code{"phylo"} or \code{"multiPhylo"} object that is the MP tree or set of MP trees. It also returns the parsimony scores in \code{attr(trees,"pscore")} or \code{attr(trees[[i]],"pscore")} for the ith tree. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{mrp.supertree}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{inference} \keyword{parsimony} phytools/man/write.simmap.Rd0000644000176200001440000000332113066534534015624 0ustar liggesusers\name{write.simmap} \alias{write.simmap} \title{Write a stochastic character mapped tree to file} \usage{ write.simmap(tree, file=NULL, append=FALSE, map.order=NULL, quiet=FALSE) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{file}{an optional filename.} \item{append}{a logical value indicating whether to append to file.} \item{map.order}{a optional value specifying whether to write the map in left-to-right or right-to-left order. Acceptable values are "left-to-right" or "right-to-left" or some abbreviation of either. If not provided, \code{write.simmap} will use \code{attr(tree,"map.order")} if available.} \item{quiet}{logical value indicating whether or not to print a warning message when \code{map.order} is neither specified by a function argument or as an attribute of \code{tree}.} } \description{ This function writes stochastic character mapped trees to file using the Newick style format of SIMMAP v1.0 (Bollback 2006). } \value{ A file or string (if \code{file=NULL}). } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/phyl.pairedttest.Rd0000644000176200001440000000450413066532224016506 0ustar liggesusers\name{phyl.pairedttest} \alias{phyl.pairedttest} \title{Phylogenetic paired t-test} \usage{ phyl.pairedttest(tree, x1, x2=NULL, se1=NULL, se2=NULL, lambda=1.0, h0=0.0, fixed=FALSE) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{x1}{data vector for first trait, or matrix with two traits in columns.} \item{x2}{data vector for second trait (or null if \code{x1} is a matrix).} \item{se1}{standard errors for \code{x1}.} \item{se2}{standard errors for \code{x2}.} \item{lambda}{starting value for Pagel's lambda (or fixed value, if \code{fixed=TRUE}).} \item{h0}{null hypothesis (to be tested) for the mean difference between \code{x1} and \code{x2}.} \item{fixed}{logical value specifying whether or not to optimize lambda.} } \description{ This function conducts a phylogenetic paired t-test, roughly following Lindenfors et al. (2010; \emph{J. Evol. Biol.}). This is not a phylogenetic ANOVA, in which we want to compare the means of different sets of species on the tree. Instead, we are interested in the difference between two characters, or two measures of a character within a species, and we want to know if this difference is significantly different from zero controlling for the phylogenetic non-independence of species. } \details{ Likelihood optimization is performed using \code{\link{optim}} with \code{method="L-BFGS-B"} with box constraints on lambda (0,1). } \value{ A list with the following components: \item{dbar}{phylogenetic mean difference.} \item{se}{standard error of \code{dbar}.} \item{sig2}{estimated evolutionary variance (of the difference).} \item{lambda}{fitted (or fixed) value of lambda.} \item{logL}{log-likelihood of the fitted model.} \item{t.dbar}{t-value (\code{(dbar-h0)/se} where \code{se} is computed from the Hessian).} \item{P.dbar}{P-value.} } \references{ Lindenfors, P., L. J. Revell, and C. L. Nunn (2010) Sexual dimorphism in primate aerobic capacity: A phylogenetic test. \emph{J. Evol. Biol.}, \bold{23}, 1183-1194. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} phytools/man/threshDIC.Rd0000644000176200001440000000325712464427146015033 0ustar liggesusers\name{threshDIC} \alias{threshDIC} \title{Deviance Information Criterion from the threshold model} \usage{ threshDIC(tree, x, mcmc, burnin=NULL, sequence=NULL, method="pD") } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{mcmc}{list object returned by \code{\link{ancThresh}}.} \item{burnin}{number of generations (not samples) to exclude as burn in; if not supplied then 20 percent of generations are excluded.} \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical-alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.} \item{method}{method for computing the effective number of parameters (options are \code{"pD"} and \code{"pV"}).} } \description{ This function computes the Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}. } \value{ A vector containing the mean deviance and deviance for the parameter means, the effective number of parameters, and the DIC. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/make.simmap.Rd0000644000176200001440000001536413061607527015417 0ustar liggesusers\name{make.simmap} \alias{make.simmap} \title{Simulate stochastic character maps on a phylogenetic tree or trees} \usage{ make.simmap(tree, x, model="SYM", nsim=1, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}, or a list of trees as an object of class \code{"multiPhylo"}.} \item{x}{a vector containing the tip states for a discretely valued character, or a matrix containing the prior probabilities of tip states in rows. The names (if \code{x} is a vector) or row names (if \code{x} is a matrix) show match the tip labels of the tree.} \item{model}{a character string containing the model - options as in \code{\link{ace}}.} \item{nsim}{number of simulations. If \code{tree} is an object of class \code{"multiPhylo"}, then \code{nsim} simulations will be conducted per tree.} \item{...}{optional arguments. So far, \code{pi} gives the prior distribution on the root node of the tree - options are \code{"equal"}, \code{"estimated"}, or a vector with the frequencies. If \code{pi="estimated"} then the stationary distribution is estimated by numerically solving \code{pi*Q=0} for \code{pi}, and this is used as a prior on the root. Defaults to \code{pi="equal"} which results in the root node being sampled from the conditional scaled likelihood distribution at the root. \code{message} tells whether or not to print a message containing the rate matrix, \emph{Q} and state frequencies. Defaults to \code{message=TRUE}. For optional argument \code{Q="mcmc"} the mean value of \code{Q} from the posterior sample is printed. \code{tol} gives the tolerance for zero elements in \code{Q}. (Elements less then \code{tol} will be reset to \code{tol}). \code{Q} can be a string (\code{"empirical"} or \code{"mcmc"}), or a fixed value of the transition matrix, \code{Q}. If \code{"empirical"} than a single value of \code{Q}, the most likely value, is used for all simulations. If \code{"mcmc"}, then \code{nsim} values of \code{Q} are first obtained from the posterior distribution for \code{Q} using Bayesian MCMC, then a simulated stochastic character map is generated for each value of \code{Q}. \code{vQ} a single numeric value or a vector containing the (normal) sampling variances for the MCMC. The order of \code{vQ} is assumed to be in the order of the \code{index.matrix} in \code{\link{ace}} for the chosen model. \code{prior} a list containing \code{alpha} and \code{beta} parameters for the gamma prior distribution on the transition rates in \code{Q}. Note that \code{alpha} and \code{beta} can be single values or vectors, if different priors are desired for each value in \code{Q}. As for \code{vQ}, the order of \code{prior} is assumed to be the order of \code{index.matrix} in \code{\link{ace}}. \code{prior} can also be given the optional logical value \code{use.empirical} which tells the function whether or not to give the prior distribution the empirical mean for \code{Q}. If \code{TRUE} then only \code{prior$beta} is used and \code{prior$alpha} is set equal to \code{prior$beta} times the empirical mean of \code{Q}. \code{burnin} and \code{samplefreq} are burn-in and sample frequency for the MCMC, respectively.} } \description{ This function performs stochastic mapping using several methods. For \code{Q="empirical"}, it first fits a continuous-time reversible Markov model for the evolution of \code{x} and then simulates stochastic character histories using that model and the tip states on the tree. This is the same procedure that is described in Bollback (2006), except that simulation is performed using a fixed value of the transition matrix, \code{Q}, instead of by sampling \code{Q} from its posterior distribution. For \code{Q="mcmc"}, it first samples \code{Q} \code{nsim} times from the posterior probability distribution of \code{Q} using MCMC, then it simulates \code{nsim} stochastic maps conditioned on each sampled value of \code{Q}. For \code{Q} set to a matrix, it samples stochastic mappings conditioned on the fixed input matrix. } \details{ Uses code modified from \code{\link{ace}} (by Paradis et al.) to perform Felsenstein's pruning algorithm & compute the likelihood. As of phytools>=0.2-33 \code{x} can be a vector of states or a matrix containing the prior probabilities of tip states in rows. In this case the column names of \code{x} should contain the states, and the row names should contain the tip names. Note that there was a small (but potentially significant) bug in how node states were simulated by \code{make.simmap} in versions of phytools<=0.2-26. Between phytools 0.2-26 and 0.2-36 there was also a bug for asymmetric models of character change (e.g., \code{model="ARD"}). Finally, between phytools 0.2-33 and phytools 0.2-47 there was an error in use of the conditional likelihoods for the root node, which caused the root node of the tree to be sampled incorrectly. All of these issues should be fixed in the present version. \code{Q="mcmc"} and \code{Q} set to a fixed value were introduced to phytools >= 0.2-53. As of the present version of phytools, this method is still somewhat experimental & should be used with caution. If \code{tree} is an object of class \code{"multiPhylo"} then \code{nsim} stochastic maps are generated for each input tree. } \value{ A object of class \code{"simmap"} or \code{"multiSimmap"} which consists of an object of class \code{"phylo"} (or a list of such objects with class \code{"multiPhylo"}), with the following additional elements: \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.} \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.} \item{Q}{the assumed or sampled value of \code{Q}.} \item{logL}{the log-likelihood of the assumed or sampled \code{Q}.} } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{brownieREML}}, \code{\link{countSimmap}}, \code{\link{describe.simmap}}, \code{\link{evol.vcv}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} phytools/man/multiRF.Rd0000644000176200001440000000246413100216452014557 0ustar liggesusers\name{multiRF} \alias{multiRF} \title{Computes Robinson-Foulds distance between a set of trees} \usage{ multiRF(trees,quiet=FALSE,multi2di=FALSE) } \arguments{ \item{trees}{object of class \code{"multiPhylo"} consisting of two or more fully bifurcating, unrooted trees. If trees are rooted, they will be unrooted.} \item{quiet}{logical argument indicating whether or not to run quietly. (Defaults to \code{FALSE}.)} \item{multi2di}{logical argumenet indicating whether or not to resolve multifurcating trees. (Defaults to \code{FALSE}.)} } \description{ Computes the Robinson-Foulds (Robinson & Foulds 1981) distance between a set of trees in an object of class \code{"multiPhylo"}. } \details{ Computes the Robinson-Foulds distance between all phylogenies in an object of class \code{"multiPhylo"}. Uses \code{\link{prop.part}} internally for most of the heavy lifting. } \value{ A matrix containing distances. } \references{ Robinson, D. R., Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131-147. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/fastBM.Rd0000644000176200001440000000347013201722667014363 0ustar liggesusers\name{fastBM} \alias{fastBM} \title{(Reasonably) fast quantitative trait simulation on phylogenies} \usage{ fastBM(tree, a=0, mu=0, sig2=1, bounds=c(-Inf,Inf), internal=FALSE, nsim=1, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{a}{a value for ancestral state at the root node.} \item{mu}{an optional value for the mean of random normal changes along branches of the tree - can be used to simulate a trend if \code{mu!=0}.} \item{sig2}{instantaneous variance of the BM process.} \item{bounds}{a vector with the lower and upper bounds (respectively) for bounded Brownian simulation - by default simulation is unbounded.} \item{internal}{logical value indicating whether or not to return states for internal nodes.} \item{nsim}{number of simulations.} \item{...}{optional arguments \code{alpha} and \code{theta} used for OU simulation. If \code{alpha} is set then \code{mu} and \code{bounds} are ignored with a warning.} } \description{ This function conducts (reasonably) fast quantitative trait simulation on a phylogeny under several different models: Brownian motion (default), BM with a trend (for \code{mu!=0}), bounds (for \code{bounds!=c(-Inf,} \code{Inf)}), and OU. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree, and (optionally) the ancestral states for internal nodes. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{sim.corrs}} } \examples{ tree<-pbtree(n=1000) x<-fastBM(tree,sig2=0.1) # Brownian motion y<-fastBM(tree,mu=1) # with a trend } \keyword{phylogenetics} \keyword{simulation} phytools/man/compare.chronograms.Rd0000644000176200001440000000160313104375602017145 0ustar liggesusers\name{compare.chronograms} \alias{compare.chronograms} \title{Compares to chronograms with precisely matching nodes in a visual manner} \usage{ compare.chronograms(t1, t2, ...) } \arguments{ \item{t1}{object of class \code{"phylo"}.} \item{t2}{object of class \code{"phylo"} that matches \code{t1} precisely in topology & node rotations, but differs in edge lengths.} \item{...}{optional arguments.} } \description{ This function plots two trees, with semi-transparent colors by default, & uses arrows to highlight differences in depth of corresponding nodes between the trees. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/reorderSimmap.Rd0000644000176200001440000000211612564377435016026 0ustar liggesusers\name{reorderSimmap} \alias{reorderSimmap} \title{Reorder edges of a simmap tree} \usage{ reorderSimmap(tree, order="cladewise", index.only=FALSE, ...) } \arguments{ \item{tree}{a modified object of class \code{"phylo"}.} \item{order}{either \code{"cladewise"} or \code{"pruningwise"} (see \code{\link{reorder.phylo}}).} \item{index.only}{logical value indicating whether only an index should be returned.} \item{...}{other arguments.} } \description{ Function returns a reordered modified \code{"phylo"} object by using \code{reorder.phylo} but then sorting the additional elements \code{$mapped.edge} and \code{$maps} to have the same order as \code{$edge}. } \value{ A modified object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{reorder.phylo}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/phylo.toBackbone.Rd0000644000176200001440000000265113201722022016371 0ustar liggesusers\name{phylo.toBackbone} \alias{phylo.toBackbone} \alias{backbone.toPhylo} \title{Converts tree to backbone or vice versa} \usage{ phylo.toBackbone(x, trans, ...) backbone.toPhylo(x) } \arguments{ \item{x}{an object of class \code{"phylo"} (for \code{phylo.toBackbone}); or an object of class \code{"backbonePhylo"} (for \code{backbone.toPhylo}).} \item{trans}{data frame containing the attributes necessary to translate a backbone tree to an object of class \code{"backbonePhylo"}. The data frame should contain the following variables: \code{tip.label}: the tip labels in the input tree (not all need be included); \code{clade.label}: labels for the unobserved subtrees; \code{N}: number of species in each subtree; and \code{depth}: desired depth of each subtree. \code{depth} for each terminal taxon in \code{x} cannot be greater than the terminal edge length for that taxon.} \item{...}{optional arguments.} } \description{ Converts between \code{"phylo"} and \code{"backbonePhylo"}. } \value{ Either an object of class \code{"phylo"} or an object of class \code{"backbonePhylo"}, depending on the method. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plot.backbonePhylo}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/aic.w.Rd0000644000176200001440000000144413021351177014201 0ustar liggesusers\name{aic.w} \alias{aic.w} \title{Computes AIC weights} \usage{ aic.w(aic) } \arguments{ \item{aic}{vector of AIC values for different fitted models. If the vector has names, these names will be inherited by the vector returned by the function.} } \description{ This function computes AIC weights for a set of fitted models. It returns an object of class \code{"aic.w"} which is just a vector which allows it to be automatically printed with a numerical precision of 8 significant digits. } \value{ A vector of AIC weights. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} phytools/man/phytools-package.Rd0000644000176200001440000000152212464431244016453 0ustar liggesusers\name{phytools-package} \alias{phytools-package} \alias{phytools} \docType{package} \title{ phytools: Phylogenetic Tools for comparative biology (and other things) } \description{ \pkg{phytools} provides functions for phylogenetic comparative biology; as well as several other functions for tree inference, manipulation, and analysis that are not implemented in other R packages. The complete list of functions can be displayed with \code{library(help = phytools)}. More information on \pkg{phytools} can be found at \url{http://www.phytools.org} or \url{http://blog.phytools.org}. } \author{ Liam J. Revell Maintainer: Liam J. Revell } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \keyword{package} phytools/man/cladelabels.Rd0000644000176200001440000000462113127211726015435 0ustar liggesusers\name{cladelabels} \alias{cladelabels} \alias{arc.cladelabels} \title{Add labels to subtrees of a plotted phylogeny} \usage{ cladelabels(tree=NULL, text, node, offset=NULL, wing.length=NULL, cex=1, orientation="vertical") arc.cladelabels(tree=NULL, text, node=NULL, ln.offset=1.02, lab.offset=1.06, cex=1, orientation="curved",...) } \arguments{ \item{tree}{an object of class \code{"phylo"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.} \item{text}{desired clade label text.} \item{node}{node number for the most recent common ancestor of members of the clade. For \code{arc.cladelabels} this defaults to \code{NULL} which means that the node of the clade to be labeled should be specified interactively (that is, by clicking on the graphical device).} \item{offset}{offset (as a multiplier of character width) for the label. Defaults to \code{offset=1} if \code{tree} is supplied or \code{offset=8} otherwise.} \item{wing.length}{length of the wings to add to the top & bottom of the label bar (in character widths).} \item{cex}{character expansion factor.} \item{orientation}{orientation of the text. Can be \code{orientation = "vertical"} (the default) or \code{"horizontal"}.} \item{ln.offset}{line offset (as a function of total tree height) for \code{arc.cladelabels}.} \item{lab.offset}{label offset for \code{arc.cladelabels}.} \item{...}{optional arguments for \code{arc.cladelabels}.} } \description{ This function adds clade labels to a plotted tree. } \details{ \code{cladelabels} presently works only for rightward facing plotted phylogenies - but no warning will be returned if your tree does not conform to this requirement! \code{arc.cladelabels} is designed to do a similar thing to \code{cladelabels}, but for plotted fan trees. This function checks to ensure that the most recently plotted tree was plotted with \code{type="fan"} style. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/lambda.transform.Rd0000644000176200001440000000146612517447160016445 0ustar liggesusers\name{lambda.transform} \alias{lambda.transform} \title{Lambda transformation of matrix} \usage{ lambda.transform(lambda, C) } \arguments{ \item{lambda}{scalar, usually (but not necessarily) on the interval 0,1.} \item{C}{matrix probably returned by \code{\link{vcv.phylo}}.} } \description{ Function multiplies the off-diagonals of a square matrix by \code{lambda}. Used internally in \code{\link{phyl.pca}} and other functions. } \details{ Do not use unless you know what you're doing. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{math} \keyword{comparative method} phytools/man/modified.Grafen.Rd0000644000176200001440000000210213066531214016152 0ustar liggesusers\name{modified.Grafen} \alias{modified.Grafen} \alias{node.paths} \title{Computes modified Grafen edge lengths} \usage{ modified.Grafen(tree, power=2) node.paths(tree, node) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{power}{power to raise the depths of each node (in nodes).} \item{node}{node number for \code{node.paths}.} } \description{ This function computes modified Grafen edge lengths in which the length of the edge is determined not by the number of desecendant leaves, but instead by the maximum number of node lengths in the path from the node to any leaf. \code{node.paths} is used internally by \code{modified.Grafen} and computes the set of paths from a node to all tips descended from that node. } \value{ An object of class \code{"phylo"} with edge lengths. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/mapped.states.Rd0000644000176200001440000000152512673645401015760 0ustar liggesusers\name{mapped.states} \alias{mapped.states} \title{Returns a vector, matrix, or list of the mapped states on a tree or set of trees} \usage{ mapped.states(tree, ...) } \arguments{ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.} \item{...}{optional arguments.} } \description{ Computes and orders a vector, matrix, or list of the unique mapped states on a tree or state of trees of class \code{"simmap"} or \code{"multiSimmap"}. } \value{ A vector, matrix, or list. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/as.multiPhylo.Rd0000644000176200001440000000170213066524027015752 0ustar liggesusers\name{as.multiPhylo} \alias{as.multiPhylo} \alias{as.multiPhylo.multiSimmap} \alias{as.multiPhylo.phylo} \title{Conversion to object of class \code{"multiPhylo"}} \usage{ as.multiPhylo(x, ...) \method{as.multiPhylo}{multiSimmap}(x, ...) \method{as.multiPhylo}{phylo}(x, ...) } \arguments{ \item{x}{object to be converted to \code{"multiPhylo"}. Presently an object of class \code{"multiSimmap"}, or an object of class \code{"phylo"}. In the latter case an object of class \code{"multiPhylo"} with length \code{1} is generated.} \item{...}{optional arguments.} } \description{ This function converts between object classes. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/densityTree.Rd0000644000176200001440000000470613100175716015504 0ustar liggesusers\name{densityTree} \alias{densityTree} \alias{make.transparent} \title{Plots a posterior sample of trees} \usage{ densityTree(trees, colors="blue", alpha=NULL, method="plotTree", fix.depth=FALSE, use.edge.length=TRUE, compute.consensus=TRUE, use.gradient=FALSE, show.axis=TRUE, ...) make.transparent(color, alpha) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"} or \code{"multiSimmap"}.} \item{colors}{a color or a named vector of colors in which names correspond to mapped states in an object of class \code{"multiSimmap"}.} \item{alpha}{transparency level for plotted trees which is passed to internally used function, \code{make.transparent}. (\code{0} is fully transparent, which \code{1} is fully opaque.) By default will be one divided by the number of trees.} \item{method}{plotting method to be used internally. Can be \code{"plotTree"} or \code{"plotSimmap"}.} \item{fix.depth}{logical value indicating whether or not to plot trees with a fixed depth or to permit plotted trees to have different depths.} \item{use.edge.length}{logical value indicating whether to use the edge lengths of the input tree. Defaults to \code{use.edge.length=TRUE} unless any input tree edge lengths are \code{NULL}.} \item{compute.consensus}{logical value indicating whether or not to use the tip order from a consensus tree. (Defaults to \code{compute.consensus=TRUE} Defaulted to \code{FALSE} in earlier version of this function.)} \item{use.gradient}{logical value indicating whether to plot all trees slightly offset using a rainbow color gradient. (Defaults to \code{use.gradient=FALSE}.)} \item{show.axis}{logical value indicating whether or not to include a horizontal axis in the plot.} \item{...}{arguments to be passed to \code{plotTree} or \code{plotSimmap}. Some may be ignored if they are incompatible with the method.} \item{color}{in \code{make.transparent}, the color to render transparent.} } \description{ Functions plots a posterior sample of trees, including with mapped discrete characters. \code{make.transparent} is used internally and converts a color to transparent with a certain user-specified \code{alpha} level. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/fastMRCA.Rd0000644000176200001440000000265013136167121014601 0ustar liggesusers\name{fastMRCA} \alias{fastMRCA} \alias{fastHeight} \alias{fastDist} \title{Get the MRCA (or height above the root of the MRCA) of a pair of tip taxa} \usage{ fastMRCA(tree, sp1, sp2) fastHeight(tree, sp1, sp2) fastDist(tree, sp1, sp2) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{sp1}{species name.} \item{sp2}{species name.} } \description{ This function returns the most recent common ancestor (node number) for a pair of taxa; or, in the case of \code{fastHeight}, the height above the root of the MRCA of a pair of taxa; or, in the case of \code{fastDist}, the patristic distance between a pair of taxa. } \details{ This function is mostly redundant with \code{\link{findMRCA}} (or \code{findMRCA(...,type="height")} in the case of \code{fastHeight}) but for very large trees will be considerably faster. (Also see \code{\link{getMRCA}} in the ape package.) } \value{ The node number of the MRCA or the height above the root (for \code{fastHeight}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{getMRCA}}, \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ tree<-pbtree(n=2000) anc<-fastMRCA(tree,"t1","t15") } \keyword{phylogenetics} \keyword{utilities} phytools/man/pgls.Ives.Rd0000644000176200001440000001057013201657340015053 0ustar liggesusers\name{pgls.Ives} \alias{pgls.Ives} \alias{pgls.SEy} \title{Phylogenetic regression with intraspecific sampling error} \usage{ pgls.Ives(tree, X, y, Vx=NULL, Vy=NULL, Cxy=NULL, lower=c(1e-8,1e-8), fixed.b1=NULL) pgls.SEy(model, data, corClass=corBrownian, tree=tree, se=NULL, method=c("REML","ML"), interval=c(0,1000), ...) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{X}{a named vector containing a \emph{single} independent variable (multiple independent variables to be added in future). \code{X} can contain the species means, or a single long vector containing the sample of values for each species. In the latter case the \code{names(X)} will be repeating - all samples from the same species should have the same name.} \item{y}{vector the dependent variable. Can be species means or individual values, as for \code{X}.} \item{Vx}{sampling variances for \code{X}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{X}.} \item{Vy}{sampling variances for \code{y}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{y}.} \item{Cxy}{sampling covariances between \code{X} and \code{y}. This will also be computed from the data if \code{Cxy==NULL}. Note than in this case - but not for the calculation of \code{Vx} and \code{Vy}, the same number of observations and the same ordering must be provided for \code{X} and \code{y}. If this is not the case, then it is assumed that different individuals have been sampled for \code{X} and \code{y} and thus \code{Cxy} is assumed to be zero for all species.} \item{lower}{vector specifying the lower bounds for estimation for \code{sig2x} and \code{sig2y}, respectively. (Must be >0.)} \item{fixed.b1}{fixed regression slope. Usually set to zero for null hypothesis testing.} \item{model}{model to fit. (For \code{pgls.SEy}.)} \item{data}{data frame. (For \code{pgls.SEy}.)} \item{corClass}{correlation structure. (For \code{pgls.SEy}.)} \item{se}{vector of standard errors in y. (For \code{pgls.SEy}.)} \item{method}{optimization method. (For \code{pgls.SEy}.)} \item{interval}{interval over which to perform optimization. (For \code{pgls.SEy}.)} \item{...}{optional arguments. (For \code{pgls.SEy}.)} } \description{ This function fits the phylogenetic regression model with within-species sampling error following Ives et al. (2007). \code{pgls.SEy} fits a simpler model in which only sampling error in \code{y} is taken into account. This function uses \code{\link{gls}} from the nlme package internally for optimization and returns an object of class \code{"gls"} that is compatible with all methods for that object class. } \details{ In the case of \code{pgls.Ives}, only the bivariate regression model is implemented. Note that some problems have been reported with the optimization algorithm for this model, which is simple and thus may fail to find the ML solution. In the case of \code{pgls.SEy} the user can (theoretically) specify any class of linear model permitted by \code{\link{gls}}. } \value{ In the case of \code{pgls.Ives}, an object of class \code{"pgls.Ives"} with the following components: \item{beta}{a vector or matrix of regression coefficients.} \item{sig2x}{fitted BM rate for \code{X}.} \item{sig2y}{fitted BM rate for \code{y}.} \item{a}{fitted ancestral states for \code{X} and \code{y}.} \item{logL}{log-likelihood.} \item{convergence}{a value for convergence. \code{convergence=0} is good; see \code{\link{optim}} for more details.} \item{message}{a message for convergence.} In the case of \code{pgls.SEy}, an object of class \code{"gls"}. } \references{ Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species measurement error in phylogenetic comparative methods. \emph{Systematic Biology}, \bold{56}, 252-270. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{phylosig}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/fitPagel.Rd0000644000176200001440000000571612723356050014744 0ustar liggesusers\name{fitPagel} \alias{fitPagel} \alias{plot.fitPagel} \title{Function to test for correlated evolution of binary traits} \usage{ fitPagel(tree, x, y, method="fitMk", model="ARD", dep.var="xy", ...) \method{plot}{fitPagel}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of phenotypic values for a binary trait for the species in \code{tree}. For S3 \code{plot} method, an object of class \code{"fitPagel"}.} \item{y}{a second binary character for the species in \code{tree}.} \item{method}{function to use for optimization (defaults to \code{method="fitMk"}). Other options are \code{"ace"} to use the \code{\link{ace}} function in ape for optimization, or to \code{"fitDiscrete"} (if the geiger package is installed) to use geiger's \code{fitDiscrete} for optimization.} \item{model}{model of evolution for the individual characters. Can be \code{model="ER"}, \code{"SYM"} (equivalent to \code{"ER"} in this case), and \code{"ARD"}.} \item{dep.var}{dependent variable. If \code{dep.var="xy"} than the rate of subsitution in \code{x} depends on \code{y} & vice versa. If \code{dep.var="x"} than the substitution rate in \code{x} depends on \code{y}, but not the converse. Finally, if \code{dep.var="y"} than the rate of substitution in \code{y} depends on \code{x}, but not the converse.} \item{...}{optional arguments to be passed to \code{\link{fitMk}}, \code{\link{ace}}, or \code{fitDiscrete}. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.sub}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{lwd.by.rate}, a logical argument specifying whether or not to scale arrow line widths in proportion to the estimated rates.} } \description{ This function fit's Pagel's (1994) model for the correlated evolution of two binary characters. \code{plot.fitPagel} plots the fitted models using arrows. } \value{ An object of class \code{"fitPagel"} which contains the optimized matrices under an independence & a dependence model, log-likelihoods, a likelihood ratio, and a P-value for the independence model based on a chi-squared test. \code{plot.fitPagel} creates a plot showing the different fitted models with arrows. } \references{ Pagel, M. (1994) Detecting correlated evolution on phylogenies: A general method for the comparative analysis fo discrete characters. \emph{Proceedings of the Royal Society B}, \bold{255}, 37-45. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/resolveNode.Rd0000644000176200001440000000304512752351115015466 0ustar liggesusers\name{resolveNode} \alias{resolveNode} \alias{resolveAllNodes} \title{Compute all possible resolutions of a node or all nodes in a multifurcating tree} \usage{ resolveNode(tree,node) resolveAllNodes(tree) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{node}{for \code{resolveNode}, the node with a polytomy to resolve.} } \description{ This functions resolves a single multifurcation or all multifurcations in a tree in all possible ways. If the input tree has edge lengths, then the resolutions will use internal edges of zero length. } \details{ For \code{resolveNode} applied to a multifurcation with \emph{n} descendants, the number of resolved trees will be equal to the number of possible rooted trees of \emph{n} taxa. (For instance, three for a trifurcation, 15 for a quadrifurcation, and so on.) For \code{resolveAllNodes} the number of fully resolved trees will be equal to the product of numbers for \code{resolveNode} applied to each multifurcation separately. (For instance, 45 for a tree containing one trifurcation and one quadrifurcation.) } \value{ An object of class \code{"multiPhylo"} - or, if the input tree is already fully resolved, an object of class \code{"phylo"} indentical to \code{tree}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{multi2di}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/bind.tree.simmap.Rd0000644000176200001440000000201112717637451016343 0ustar liggesusers\name{bind.tree.simmap} \alias{bind.tree.simmap} \title{Attaches a new tip to a tree} \usage{ bind.tree.simmap(x, y, where="root") } \arguments{ \item{x}{an object of class \code{"simmap"}. (The receptor tree.)} \item{y}{an object of class \code{"simmap"}. (The tree being grafted.)} \item{where}{node number to attach new tip, or the root node if \code{where="root"}.} } \description{ This function grafts tree \code{y} onto tree \code{x} at node \code{where}. } \details{ This function wraps around \code{\link{bind.tree}} for objects of class \code{"simmap"}; however it presently only allows \code{y} to be grafted at a node of \code{x} and it does not allow \code{y} to possess a root edge. } \value{ An object of class \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/describe.simmap.Rd0000644000176200001440000000435412673645450016264 0ustar liggesusers\name{describe.simmap} \alias{describe.simmap} \alias{summary.simmap} \alias{summary.multiSimmap} \alias{plot.describe.simmap} \title{Summarizes a stochastic mapped tree or set of trees} \usage{ describe.simmap(tree, ...) \method{summary}{simmap}(object, ...) \method{summary}{multiSimmap}(object, ...) \method{plot}{describe.simmap}(x, ...) } \arguments{ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.} \item{object}{object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{x}{for S3 \code{plot} method, an object of class \code{"describe.simmap"}.} \item{...}{optional arguments which include: \code{plot}, a logical value indicating whether or not to plot the posterior probabilities at nodes (default is \code{plot=FALSE}); \code{check.equal}, a logical value indicating whether or not to check if all trees are equal using \code{\link{all.equal.phylo}} (default is \code{check.equal=FALSE}); and \code{message}, a logical indicating whether or not to print an informative message to the screen (default is \code{message=TRUE}).} } \description{ This function summarizes the result of one or more stochastic maps. } \value{ An object of class \code{"describe.simmap"} with the following elements: \item{count}{a matrix containing the number and types of transitions for each tree, if \code{tree} is an object of class \code{"multiSimmap"}.} \item{times}{a matrix containg the times spend in each state on each tree.} \item{ace}{the posterior probabilities of each node being in each state, if \code{tree} is an object of class \code{"multiSimmap"}.} \item{legend}{a vector containing the plot legend, if \code{plot=TRUE}.} if \code{class(tree)="simmap"} then the function simply returns the results of \code{\link{countSimmap}} combined with the states at each node of the tree and a matrix containing the total and relative times spent in each state on the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/drop.tip.contMap.Rd0000644000176200001440000000233412464425536016351 0ustar liggesusers\name{drop.tip.contMap} \alias{drop.tip.contMap} \alias{drop.tip.densityMap} \title{Drop tip or tips from an object of class "contMap" or "densityMap"} \usage{ drop.tip.contMap(x, tip) drop.tip.densityMap(x, tip) } \arguments{ \item{x}{an object of class \code{"contMap"} or \code{"densityMap"}.} \item{tip}{name or names of species to be dropped.} } \description{ This function drops one or multiple tips from an object of class \code{"contMap"} or \code{"densityMap"}. This function is equivalent to \code{\link{drop.tip}} but for an object of this class. } \details{ For more information about objects of class \code{"contMap"} or \code{"densityMap"}, please refer to the documentation pages for \code{\link{contMap}} or \code{\link{densityMap}}, respectively. } \value{ An object of class \code{"contMap"} or \code{"densityMap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{drop.tip.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/midpoint.root.Rd0000644000176200001440000000230413066531153016004 0ustar liggesusers\name{midpoint.root} \alias{midpoint.root} \title{Midpoint root a phylogeny} \usage{ midpoint.root(tree) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} } \description{ This function midpoint roots a rooted or unrooted tree (Farris 1972). } \details{ Midpoint rooting involves locating the midpoint of the longest path between any two tips and putting the root in that location. This function performs the same operation as \code{midpoint} in the phangorn package, but uses no phangorn code internally. } \value{ A phylogenetic tree in \code{"phylo"} format. } \references{ Farris, J. (1972) Estimating phylogenetic trees from distance matrices. \emph{American Naturalist}, \bold{106}, 645-667. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{midpoint}}, \code{\link{reroot}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/phylomorphospace3d.Rd0000644000176200001440000000552613066533150017032 0ustar liggesusers\name{phylomorphospace3d} \alias{phylomorphospace3d} \title{Creates tree-dimensional phylomorphospace plot} \usage{ phylomorphospace3d(tree, X, A=NULL, label=TRUE, control=list(), method=c("dynamic","static"), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{X}{an \code{n} x 3 matrix of tip values for two characters in \code{n} species.} \item{A}{an optional \code{m} x 3 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{anc.ML}}.} \item{label}{logical value indicating whether to print tip labels next to terminal nodes in the plot (presently doesn't do anything, but labels can be dropped using \code{control}).} \item{control}{a list containing the following optional control parameters: \code{spin}: a logical value indicating whether to animate the plot when created; \code{axes}: a logical indicating whether to plot the axes; \code{box}: a logical value indicating whether to plot in box; \code{simple.axes}: logical value indicating whether to replace \code{box} and \code{axes} with simpler axes; \code{lwd}: line widths; \code{ftype}: font type ("off" turns off labels altogether); \code{col.edge} a vector of colors of length \code{nrow(tree$edge)}.} \item{method}{a string either \code{"dynamic"} for a dynamic (animated) plot created using \code{rgl}; or \code{"static"} for a flat 3D plot created using \code{scatterplot3d} and base graphics. The latter has the advantage of being very easy to export in standard format.} \item{...}{optional arguments to be passed to \code{scatterplot3d}. Most options not available. \code{angle} is an important option that does work here.} } \description{ This function creates a phylomorphospace plot for three characters using the 3D visualization package, 'rgl'. } \value{ This function creates a three dimensional phylomorphospace plot. The function returns a function from \code{spin3d} (for \code{method="dynamic"}); or a series of functions from \code{\link{scatterplot3d}} (for \code{method="static"}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=26,tip.label=LETTERS) X<-fastBM(tree,nsim=3) \dontrun{ phylomorphospace3d(tree,X,control=list(spin=FALSE)) } phylomorphospace3d(tree,X,method="static") } \seealso{ \code{\link{fancyTree}}, \code{\link{phenogram}}, \code{\link{phylomorphospace}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} phytools/man/getStates.Rd0000644000176200001440000000173212464426375015160 0ustar liggesusers\name{getStates} \alias{getStates} \title{Get the states at nodes or tips from a mapped tree} \usage{ getStates(tree, type=c("nodes","tips")) } \arguments{ \item{tree}{is a modified object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{type}{mode indicating whether to get states at the nodes (\code{type="nodes"}) or the tips (\code{type="tips"}) of the tree.} } \description{ This function gets the states from the nodes or tips of a mapped tree (e.g., \code{\link{make.simmap}}). } \value{ A named vector (for \code{"phylo"}) or matrix (for \code{"multiPhylo"}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{describe.simmap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/phyl.RMA.Rd0000644000176200001440000000525213066536755014613 0ustar liggesusers\name{phyl.RMA} \alias{phyl.RMA} \alias{coef.phyl.RMA} \alias{plot.phyl.RMA} \title{Phylogenetic reduced major axis (RMA) regression} \usage{ phyl.RMA(x, y, tree, method="BM", lambda=NULL, fixed=FALSE, h0=1.0) \method{coef}{phyl.RMA}(object, ...) \method{plot}{phyl.RMA}(x, ...) } \arguments{ \item{x}{vector with names. In the case of the S3 \code{plot} method \code{x} is an object of class \code{"phyl.RMA"}.} \item{y}{vector with names.} \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} \item{lambda}{value of \code{lambda} for fixed \eqn{\lambda}.} \item{fixed}{logical value indicating whether or not \eqn{\lambda} should be optimized using likelihood.} \item{h0}{null hypothesis for \code{beta}. Defaults to 1.0. Note that a null hypothesis of 0.0 is not allowed.} \item{object}{for \code{coef} method, an object of class \code{"phyl.RMA"}.} \item{...}{optional arguments for S3 methods.} } \description{ This function performs phylogenetic RMA regression. } \details{ Optionally jointly estimates lambda if \code{method="lambda"}. Likelihood optimization of lambda is performed using \code{\link{optimize}} on the interval (0,1). Note that some statistician think there is \emph{never} a condition in which a reduced-major-axis regression should be used. The statistical hypothesis testing is based on Clarke (1980; reviewed in McArdle 1988), which differs from some other implementations of non-phylogenetic major axis regression in R. } \value{ An object of class \code{"phyl.RMA"} consisting of a list with the following components: \item{RMA.beta}{a vector of RMA regression coefficients.} \item{V}{a VCV matrix for the traits.} \item{lambda}{fitted value of lambda (\code{method="lambda"} only).} \item{logL}{log-likelihood (\code{method="lambda"} only).} \item{test}{a vector containing results for hypothesis tests on \code{beta}.} \item{resid}{a vector of residuals for \code{y} given \code{x}.} } \references{ Clarke, M. R. B. (1980) The reduced major axis of a bivariate sample. \emph{Biometrika}, \bold{67}, 441-446. McArdle, B. H. (1988) The structural relationship: Regression in biology. \emph{Can. J. Zool.}, \bold{66}, 2329-2339. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.pca}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} phytools/man/roundBranches.Rd0000644000176200001440000000161613066534104016000 0ustar liggesusers\name{roundBranches} \alias{roundBranches} \title{Rounds the branch lengths of a tree} \usage{ roundBranches(tree, digits) } \arguments{ \item{tree}{an object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}.} \item{digits}{number of digits for rounding. Passed to \code{\link{round}}.} } \description{ This function rounds the branch lengths of a tree or trees and reconciles any mappings for objects of class \code{"simmap"} or \code{"multiSimmap"}. } \value{ An object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}, with rounded edge lengths. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/gammatest.Rd0000644000176200001440000000213113066530075015161 0ustar liggesusers\name{gammatest} \alias{gammatest} \title{Gamma test of Pybus & Harvey (2000)} \usage{ gammatest(x) } \arguments{ \item{x}{an object of class \code{"ltt"} resulting from a call of the function \code{\link{ltt}}.} } \description{ Conducts \eqn{\gamma}-test of Pybus & Harvey (2000). } \details{ Do not use for object returned by \code{ltt(...,gamma=T)}. } \value{ A list containing: \item{gamma}{optionally, a value for the \eqn{\gamma}-statistic.} \item{p}{two-tailed P-value for the \eqn{\gamma}-test.} } \references{ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \examples{ tree<-pbtree(n=200) z<-ltt(tree,gamma=FALSE) g<-gammatest(z) } \keyword{phylogenetics} \keyword{comparative method} \keyword{diversification} phytools/man/genSeq.Rd0000644000176200001440000000247712464426300014432 0ustar liggesusers\name{genSeq} \alias{genSeq} \title{Simulate a DNA alignment on the tree under a model} \usage{ genSeq(tree, l=1000, Q=NULL, rate=1, format="DNAbin", ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{l}{length of desired sequences.} \item{Q}{transition matrix for the simulation. Row and column names \code{c("a","c","g","t")} (although not necessarily in that order, should be provided. If \code{NULL}, a single rate is assumed.} \item{rate}{multiplier for \code{Q}, or a vector for Gamma rate heterogeneity.} \item{format}{format of the output object. Can be \code{"DNAbin"}, \code{"phyDat"}, or \code{"matrix"}.} \item{...}{optional arguments.} } \description{ Simulates DNA sequence on \code{tree} under the specified model. Uses \code{\link{sim.history}} internally. } \value{ An object of class \code{"DNAbin"} or \code{"phyDat"}, or a matrix of nucleotides. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## simulate gamma rate heterogeneity tree<-pbtree(n=26,tip.label=LETTERS) gg<-rgamma(n=100,shape=0.25,rate=0.25) X<-genSeq(tree,l=100,rate=gg) } \keyword{phylogenetics} \keyword{simulation} phytools/man/expm.Rd0000644000176200001440000000071212464425763014163 0ustar liggesusers\name{expm} \alias{expm} \title{Matrix exponential} \usage{ expm(Y) } \arguments{ \item{Y}{a matrix.} } \description{ Wrapper for \code{\link{MatrixExp}} that retains row/column names. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{math} phytools/man/phyl.resid.Rd0000644000176200001440000000451113201722210015245 0ustar liggesusers\name{phyl.resid} \alias{phyl.resid} \title{Phylogenetic size-correction via GLS regression} \usage{ phyl.resid(tree, x, Y, method="BM") } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{vector containing the single independent variable (e.g., size), or matrix with multiple independent variables in columns.} \item{Y}{vector or matrix with one or multiple dependent variables in columns.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} } \description{ This function fits one or multiple phylogenetic regressions (depending on the number of columns in \code{Y}) and computes the residuals. Designed for phylogenetic size correction using GLS regression (e.g., Revell 2009; \emph{Evolution}). } \details{ Optionally fits \eqn{\lambda} for each regression model. Likelihood optimization of \eqn{\lambda} is performed for \code{method=} \code{"lambda"} using \code{\link{optimize}} on the interval (0,1). This function is theoretically redundant with \code{residuals} applied to a \code{"gls"} object class in which the correlation structure is based on \code{corBrownian} or \code{corPagel}; however some users may find this method simpler, and it provides a good way to cross-check your results & make sure that you are using \code{gls} correctly. } \value{ A list with the following components: \item{beta}{a vector or matrix of regression coefficients.} \item{resid}{a vector or matrix of residuals for species.} \item{lambda}{a vector of lambda values (\code{method="lambda"} only).} \item{logL}{a vector of log-likelihoods (\code{method="lambda"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2010) Phylogenetic signal and linear regression on species data. \emph{Methods in Ecology and Evolution}, \bold{1}, 319-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.pca}}, \code{\link{gls}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/anc.ML.Rd0000644000176200001440000000514313150360136014246 0ustar liggesusers\name{anc.ML} \alias{anc.ML} \title{Ancestral character estimation using likelihood} \usage{ anc.ML(tree, x, maxit=2000, model=c("BM","OU","EB"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.} \item{model}{model of continuous character evolution ont he tree. It's possible that only \code{model="BM"} & \code{model="EB"} work in the present version as \code{model="OU"} has not be thoroughly tested & some bugs were reported for an earlier version.} \item{...}{other arguments.} } \description{ This function estimates the evolutionary parameters and ancestral states for Brownian evolution using likelihood. It is also possible (for \code{model="BM"}) to allow for missing data for some tip taxa. } \details{ Because this function relies on a high dimensional numerical optimization of the likelihood function, \code{\link{fastAnc}} should probably be preferred for most purposes. If using \code{\link{anc.ML}}, users should be cautious to ensure convergence. This has been ameliorated in phytools>=0.2-48 by seeding the ML optimization with the result from \code{\link{fastAnc}}. For \code{model="EB"} this should also not be a problem as the numerical optimization is performed for only \code{sig2} and \code{r}, while the ML values of the ancestral states are obtained during every iteration of the optimization algorithmically using the re-rooting method. } \value{ An object of class \code{"anc.ML"} with at least the following four elements (if not more, depending on \code{model}): \item{sig2}{the variance of the BM process.} \item{ace}{a vector with the ancestral states.} \item{logLik}{the log-likelihood.} \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schluter, D., Price, T., Mooers, A. O., and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution} \bold{51}, 1699-1711. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{fastAnc}}, \code{\link{optim}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree) # simulate using fastBM anc.ML(tree,x) # fit model & estimate ancestral states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/fitMk.Rd0000644000176200001440000000424512723613667014271 0ustar liggesusers\name{fitMk} \alias{fitMk} \alias{plot.fitMk} \alias{plot.gfit} \title{Fits Mk model} \usage{ fitMk(tree, x, model="SYM", fixedQ=NULL, ...) \method{plot}{fitMk}(x, ...) \method{plot}{gfit}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of \code{plot.fitMk}, an object of class \code{"fitMk"}.} \item{model}{model. See \code{make.simmap} or \code{ace} for details.} \item{fixedQ}{fixed value of transition matrix \code{Q}, if one is desired.} \item{...}{optional arguments, including \code{pi}, the prior distribution at the root node (defaults to \code{pi="equal"}). For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{show.zeros}, a logical argument specifying whether or not to plot arrows with the ML estimated transition rate is not different from zero (with tolerance specified by the optional argument \code{tol}).} } \description{ This function fits a so-called M\emph{k} model for discrete character evolution. It is primarily designed to be used inside of \code{make.simmap}. Two \code{plot} methods are available. \code{plot.fitMk} plots an object of class \code{"fitMk"} returned by \code{fitMk}. \code{plot.gfit} plots an object of class \code{"gfit"} from geiger's \code{fitDiscrete} function. Both plots portray the fitted model using a graph of arrows connecting states. } \value{ An object of class \code{"fitMk"}. In the case of \code{plot.fitMk}, a plotted M\emph{k} model. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rep.phylo.Rd0000644000176200001440000000212112464430505015114 0ustar liggesusers\name{rep.phylo} \alias{rep.phylo} \alias{rep.multiPhylo} \alias{repPhylo} \title{Replicate a tree or set of trees} \usage{ \method{rep}{phylo}(x, ...) \method{rep}{multiPhylo}(x, ...) repPhylo(tree, times) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{times}{number of times to replicate tree.} \item{x}{for S3 method an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{...}{other arguments for \code{rep} (specifically, \code{times}).} } \description{ S3 method \code{rep} for object of class \code{"phylo"} or \code{"multiPhylo"}. \code{repPhylo} is just an alias for \code{rep.phylo} and \code{rep.multiPhylo}. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=100) trees<-rep(tree,100) } \seealso{ \code{\link{c.phylo}}, \code{\link{rep}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/dotTree.Rd0000644000176200001440000000450413066527167014623 0ustar liggesusers\name{dotTree} \alias{dotTree} \alias{dot.legend} \title{Creates a phylogenetic dot plot} \usage{ dotTree(tree, x, legend=TRUE, method="plotTree", standardize=FALSE, ...) dot.legend(x, y, min, max, Ntip, length=5, prompt=FALSE, method="plotTree", ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{vector of trait values; or a matrix. In the case of \code{dot.legend}, the \emph{x} coordinate of the legend.} \item{legend}{logical value indicating whether or not a legend should be plotted.} \item{method}{tree plotting method to be used internally. Will switch to \code{method="phylogram"} if the number of traits is greater than one. For \code{dot.legend}, it should be the method that was used for the plot.} \item{standardize}{a logical value indicating whether or not to standardize \code{x}, or each column of \code{x}, to have a mean of zero & variance of one prior to analysis.} \item{y}{\emph{y} coordinate of the legend.} \item{min}{minimum value for \code{dot.legend}.} \item{max}{maximum value for \code{dot.legend}.} \item{Ntip}{number of tips in the plotted tree for \code{dot.legend}.} \item{length}{length of legend.} \item{prompt}{logical value indicating whether or not to prompt for legend position.} \item{...}{optional arguments. In the case of \code{dotTree}, these will be passed to \code{\link{plotTree}} or a different internally used plotting function for \code{method="phylogram"}. See \code{\link{phylo.heatmap}} for more detail on these arguments. Other option for \code{dotTree} also include \code{data.type} (\code{"continuous"} or \code{"discrete"}), \code{colors}, \code{length}, for data type \code{"continuous"} the length of the legend in terms of plotted circles, \code{x.space}, the spacing of the columns in the plotted data matrix, and \code{leg.space}, the spacing of the legend dots (again, for \code{data.type="continuous"} only).} } \description{ Creates a plot in which different sized dots/circles represent different tip values for a quantitative trait. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/estDiversity.Rd0000644000176200001440000000517112464425605015707 0ustar liggesusers\name{estDiversity} \alias{estDiversity} \title{Estimate diversity at each node of the tree} \usage{ estDiversity(tree, x, method=c("asr","simulation"), model="ER", ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{x}{a vector containing the biogeographic area for each of the tip taxa.} \item{method}{method for reconstructing ancestral biogeography.} \item{model}{model for ancestral character estimation. In theory, any model from \code{\link{ace}}; however only symmetric models permitted for \code{method="asr"}.} \item{...}{optional arguments. So far, this includes only \code{nsim}, the number of stochastic mappings to conduct using \code{\link{make.simmap}} for \code{method="simulation"}.} } \description{ This function estimates the lineage density at each node in the tree based on a biogeographic model (based on Mahler et al. 2010). } \details{ Two different methods are implemented in the current version. For \code{method="asr"} the state at the current node, and at each position along each co-extant internal edge, is computed as the marginal (empirical Bayesian) ancestral state reconstruction using the re-rooting method of Yang (2006). The lineage density is then computed as the sum of the marginal reconstructions (posterior probabilities) times the summed marginal ancestral reconstructions across co-extant edges. In \code{method="simulation"}, stochastic character mapping is used to generate optional argument \code{nsim} stochastic maps of ancestral biogeography. Then the lineage density at each node is computed as the number of co-existing lineages with the same biogeography as the focal node, averaged acrossed stochastic maps. The importance of this distinction may depend on the degree to which reconstructions at internal nodes are independent, which relates to the distinction between marginal and joint reconstruction (e.g., see Yang 2006). } \value{ A vector containing the estimated lineage density at each node } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitDiversityModel}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rescaleSimmap.Rd0000644000176200001440000000203712464427715016000 0ustar liggesusers\name{rescaleSimmap} \alias{rescaleSimmap} \title{Rescale SIMMAP style tree} \usage{ rescaleSimmap(tree, ...) } \arguments{ \item{tree}{a phylogenetic tree in modified \code{"phylo"} format with a discrete character mapping (e.g., see \code{\link{read.simmap}} or \code{\link{make.simmap}}).} \item{...}{other arguments, such as \code{depth}.} } \description{ This function scales a tree with a mapped discrete character to an arbitrary total height, preserving the relative time spent in each state along each edge. } \details{ Replaces \code{rescaleTree} (now \code{rescale.phylo}) in the 'geiger' package for SIMMAP style trees. } \value{ A phylogenetic tree in modified \code{"phylo"} format. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/evolvcv.lite.Rd0000644000176200001440000000302713066527437015634 0ustar liggesusers\name{evolvcv.lite} \alias{evolvcv.lite} \title{Likelihood test for a shift in the evolutionary correlation between traits} \usage{ evolvcv.lite(tree, X, maxit=2000, tol=1e-10) } \arguments{ \item{tree}{an object of class \code{"simmap"}.} \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{tol}{tolerance value for \code{"L-BFGS-B"} optimization.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for two and only two continuously valued character. It then fits four different evolutionary models: common rates and correlation; different rates, common correlation; different correlations, common rates; no common structure. } \value{ A list with the results summarized for each model. } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rstate.Rd0000644000176200001440000000143012464427623014507 0ustar liggesusers\name{rstate} \alias{rstate} \title{Pick a random state according to a vector of probabilities} \usage{ rstate(y) } \arguments{ \item{y}{vector of probabilities. Must have names & should probably add to \code{1.0}.} } \description{ Primarily an internal function for \code{\link{make.simmap}}. } \details{ This function picks a random element in a vector according to the probability assigned that element. It returns the name. Uses \code{\link{rmultinom}}. } \value{ A character or string. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{math} \keyword{utilities} \keyword{statistics} phytools/man/pbtree.Rd0000644000176200001440000001050213066531647014467 0ustar liggesusers\name{pbtree} \alias{pbtree} \title{Simulate pure-birth or birth-death stochastic tree or trees} \usage{ pbtree(b=1, d=0, n=NULL, t=NULL, scale=NULL, nsim=1, type=c("continuous", "discrete"), ...) } \arguments{ \item{b}{birth rate or speciation rate for \code{type="continuous"}; the probability of speciating per time-step for \code{type="discrete"}.} \item{d}{death rate or extinction rate for \code{type="continuous"}; the probability of going extinct per time-step for \code{type="discrete"}.} \item{n}{desired number of species (i.e., taxa-stop criterion).} \item{t}{total time for simulation (i.e., time-stop criterion).} \item{scale}{if set, rescales tree to have total length \code{scale}.} \item{nsim}{number of simulated trees to return.} \item{type}{string to indicate whether to simulate trees in continuous or discrete time. If the former, then wait times between speciation events are drawn from an exponential distribution; whereas if the latter then wait times comes from a geometric distribution.} \item{...}{optional arguments including \code{ape}, a logical value indicating whether to return nodes in a 'ape' compatible ordering (default is \code{TRUE}); \code{extant.only} a logical value indicating whether or not to return only extant species (defaults to \code{FALSE}); \code{max.count} a numeric value indicating the maximum number of iterations to run is sampling conditioned on both \code{n} and \code{t} (defaults to \code{1e5}); \code{method} gives the method used for simultaneously conditioning on \code{n} and \code{t} - options are \code{"rejection"} and \code{"direct"}; \code{tip.label}, a vector of tip labels (only works for \code{n!=NULL}); and, finally, \code{quiet}, a logical value indicating whether or not to suppress certain message (defaults to \code{FALSE}).} } \description{ This function simulates stochastic birth-death trees. Simulation can be performed conditioning on \code{n}, on \code{t}, or on both simultaneously. If the both, then (for optional argument \code{method="rejection"}) rejection sampling is performed whereby trees are simulated given \code{b} and \code{t} until a tree containing \code{n} taxa is found. The giving-up point can be set using the optional argument \code{max.count}. Simulations can also be performed in continuous time (the default) or discrete time; the difference being that wait times in the continous-time simulation come from the exponential distribution; whereas waiting times in discrete-time simulations come from the geometric distribution. In addition, discrete-time simulations allow for the possibility that multiple speciation events can occur at (exactly) the same time, so long as they are on separate branches. Finally, sometimes for stopping criterion \code{n} in discrete-time there will be a number of tips different from \code{n}. This indicates that the last event contained more than one speciation event, and a warning is printed. \code{method="direct"} is presently experimental. It does not really perform direct sampling; however waiting times & birth or death events are sampled first - with only wait-times consistent with \code{n} and \code{t} being retained. This rejection sampling occurs one layer earlier than for \code{method="rejection"}. This results in a significant (several-fold) speed-up of the code and enables sampling conditioned on \code{n} and \code{t} simultaneously for much higher \code{b} and \code{d}. At the present time, \code{extant.only=TRUE} does not work for this mode, nor does \code{type="discrete"}. Note that if \code{ape=FALSE}, then the function will run faster, and the tree is theoretically compatible with the ape \code{"phylo"} standard; however some downstream errors with functions such as \code{\link{bind.tree}} have been observed. } \value{ A tree or list of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}, respectively. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ # simulate a pure-birth tree with 400 tips, scaled to a length of 1.0 tree<-pbtree(n=400,scale=1) # simulate a pure-birth tree conditioning on n & t tt<-log(50)-log(2) tree<-pbtree(n=50,t=tt) } \keyword{phylogenetics} \keyword{simulation} phytools/man/add.random.Rd0000644000176200001440000000333513201722356015211 0ustar liggesusers\name{add.random} \alias{add.random} \title{Add tips at random to the tree} \usage{ add.random(tree, n=NULL, tips=NULL, edge.length=NULL, order=c("random","input")) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{n}{a number of tips to add to the tree. If \code{NULL}, will use \code{length(tips)}.} \item{tips}{a set of tip names for the added tips. If \code{NULL}, names will be supplied} \item{edge.length}{terminal edge length for the added tips. If \code{NULL}, and \code{is.ultrametric(tree)} \code{==TRUE}, then edge lengths will be assigned to keep the tree ultrametric. Note that if edge lengths are assigned and \code{n>1}, then the asssigned terminal edge lengths are not guaranteed as subsequent random tip addition could occur along the new terminal edge.} \item{order}{addition order for the new tips.} } \description{ This function adds new tips at random to a tree with branch lengths. If no edge lengths are provided, and the tree is ultrametric, then edge lengths are assigned to keep the tree ultrametric. The probability that at new tip is added along any branch is directly proportional to the length of the branch. } \details{ Note that sometimes the resultant tree plotted with \code{\link{plot.phylo}} or \code{\link{plotSimmap}} may display with branches crossing. If so, the tree can be 'untangled' using \code{\link{untangle}}. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{allFurcTrees}}, \code{\link{add.everywhere}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ratebytree.Rd0000644000176200001440000001510213201721533015337 0ustar liggesusers\name{ratebytree} \alias{ratebytree} \alias{posthoc.ratebytree} \title{Likelihood test for rate variation among trees} \usage{ ratebytree(trees, x, ...) \method{posthoc}{ratebytree}(x, ...) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"}.} \item{x}{a list of trait vectors for a continuous trait in which the names of each vectors correspond to the tip labels of \code{trees}. This is not used if \code{type="diversification"}. In the case of \code{posthoc.ratebytree}, an object of class \code{"ratebytree"}.} \item{...}{optional arguments, including the argument \code{type} (\code{"continuous"}, \code{"discrete"}, or \code{"diversification"}), which, if not specified, the function will attempt to ascertain. For continuous character, optional arguments presently include the following: \code{model}, the model of continuous trait evolution (options are \code{"BM"}, the default, \code{"OU"}, and \code{"EB"}); \code{tol}, used as a minimum value for the fitting rates, to prevent problems in optimization; \code{trace}, a logical value indicating whether or not to report progress in the optimization; \code{test}, the method for hypothesis testing (options are \code{"chisq"} and \code{"simulation"}); \code{quiet}, a logical value indicating whether or not to run perfectly quietly; and \code{se}, a list of vectors containing the standard errors for each value of \code{x}. For \code{type="discrete"} the optional arguments are slightly different. The argument \code{model} can be used, but it must assume the values \code{"ER"}, \code{"SYM"}, \code{"ARD"}, or a numeric matrix following \code{\link{ace}}. Finally, for \code{type="diversification"} models are so far \code{model="birth-death"}, \code{"equal-extinction"}, and \code{"equal-specation"}, and \code{"Yule"}. For \code{type=} \code{"diversification"} it is also important to consider supplying the sampling fractions, \code{rho}, which is a vector of values between 0 and 1 of the same length as \code{trees}. If not provided the method will assume a sampling fraction of 1.0 for all trees - which is seldom true of empirical studies. Other optional arguments are not yet available for these two types.} } \description{ This function essentially implements three different methods for comparing the rate or process of evolution between trees: one for continuously-valued traits, a second for discrete characters, and a third for the rate of diversification (speciation & extinction). In all cases, the function takes an object of class \code{"multiPhylo"} containing two or more phylogenies (\code{trees}), and, for the first two analyses, a list of trait vectors (\code{x}). For continuous traits, the function then proceeds to fit two models: one in which the rate (or regime, for models \code{"OU"} and \code{"EB"}) of trait evolution is equal among all trees; and a second in which the rates or regimes can differ between trees. The latter model corresponds to an extension the \emph{censored} approach of O'Meara et al. (2006; Revell et al. \emph{In review}) and should also be related to the method of Adams (2012) for comparing rates among traits. See \code{\link{brownie.lite}} for a different implementation of the \emph{noncensored} approach of O'Meara et al. (2006). For discrete traits, the function instead proceeds to fit two variants of the Mk model (Lewis 2001): one in which the parameters values (transition rates) of the process are free to vary between trees, and a second in which they are fixed to be the same. For diversification alone, the function fits two different diversification (speciation & extinction) models (Nee et al. 1994; Stadler 2012): one in which the birth (speciation) and death (extinction) rates are identical between the trees, and a second in which they are permitted to differ in various ways depending on the value of \code{"model"}. The method \code{posthoc} conducts a post-hoc comparison of parameter estimates between trees in the multi-rate or multi-process model. The parameter that is compared depends on the fitted model. For instance, in \code{model="BM"} posthoc comparison is made of \code{sig2}; if \code{model="OU"} fitted values of \code{alpha} are compared; and so on. The argument \code{p.adjust.method} can be used to specify a method for adjusting P-values for multiple tests following \code{p.adjust} (defaults to \code{p.adjust.method="none"}. } \details{ At present it is not possible to specify different models to fit for the different trees - although if (for instance) character evolution on tree 1 proceeded by a strong \emph{OU} process while character evolution on tree 2 was by \emph{BM}, we would probably reject a constant-process model and tree 2 should show a very low value of \code{alpha}. To compute the standard errors for each fitted paramater value, the function computes the negative inverse of the Hessian matrix at the MLEs; however, if this matrix is computationally singular generalized inverse (\code{\link{ginv}}) will be used instead without warning. The function also conducts a likelihood-ratio test to compare the two models. } \value{ An object of class \code{"ratebytree"} or an object of class \code{"posthoc.ratebytree"} in the case of the method \code{posthoc}. } \references{ Adams, D. C. (2012) Comparing evolutionary rates for different phenotypic traits on a phylogeny using likelihood. \emph{Syst. Biol.}, \bold{62}, 181-192. Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925. Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., Gonzalez-Valenzuela, L. E., Alfonso, A., Castellanos-Garcia, L. A., Guarnizo, C. E., and Crawford, A. J. (In review) Comparing evolutionary rates between trees, clades, & traits. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{fitMk}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/plotTree.wBars.Rd0000644000176200001440000000671013171741672016065 0ustar liggesusers\name{plotTree.wBars} \alias{plotTree.wBars} \alias{plotTree.barplot} \alias{plotTree.boxplot} \title{Plot a tree with bars at the tips} \usage{ plotTree.wBars(tree, x, scale=1, width=NULL, type="phylogram", method="plotTree", tip.labels=FALSE, col="grey", border=NULL, ...) plotTree.barplot(tree, x, args.plotTree=list(), args.barplot=list(), ...) plotTree.boxplot(tree, x, args.plotTree=list(), args.boxplot=list()) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a named vector or matrix of trait values. For \code{plotTree.boxplot}, the names should repeat for multiple observations per species. For \code{plotTree.boxplot} \code{x} can also be supplied as a formula, though in that case the factor levels need to be provided in a valid cladewise order of the tips in \code{tree}. This order doesn't need to correspond with the current order of the tip labels. For \code{plotTree.barplot} \code{x} can be a matrix (or a data frame) in which columns are the values of multiple traits to be simultaneously plotted on the tree.} \item{scale}{scaling factor for the tip bars (relative to the total tree height).} \item{width}{width of the tip bars.} \item{type}{plot type. Can be \code{"phylogram"} or \code{"fan"}.} \item{method}{plotting method to use. Can be \code{"plotTree"} (for \code{\link{plotTree}}) or \code{"plotSimmap"} (for \code{\link{plotSimmap}}).} \item{tip.labels}{argument indicating whether or not tip labels should be plotted. Defaults to \code{tip.labels=FALSE}.} \item{col}{colors of the plotted bars. Can be a single value or a vector with length equal to the number of tips in the tree.} \item{border}{single value specifying the color of the border for the plotted bars. Defaults to \code{border=NULL}, which means that black borders will be plotted.} \item{args.plotTree}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{plotTree}}.} \item{args.barplot}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{barplot}}.} \item{args.boxplot}{in \code{plotTree.boxplot}, arguments to be passed to \code{\link{boxplot}}.} \item{...}{optional arguments to be passed to \code{\link{plotTree}} or \code{\link{plotSimmap}} in the case of \code{plotTree.wBars}. For \code{plotTree.barplot}, the only optional argument is \code{add}. Generally this should not be used; however it can be used to tell the function to draw the tree & barplot, respectively, in the next two open plotting devices - rather than creating a table of figures in the current plotting device.} } \description{ \code{plotTree.wbars} plots a phylogeny in phylogram or fan style with bars at the tips representing the values for a phenotypic trait. \code{plotTree.barplot} creates a split plot in which a right-facing phylogram is on the left, and a bar plot is shown on the right. \code{plotTree.boxplot} creates a split plot in which a right-facing phylogram is on the left, and a box plot is shown on the right. } \value{ Plots a tree with an associated bar plot for a continuously valued character at the tips. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{barplot}}, \code{\link{dotTree}}, \code{\link{plotSimmap}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/ratebystate.Rd0000644000176200001440000000427313201657506015537 0ustar liggesusers\name{ratebystate} \alias{ratebystate} \title{Method for investigating the rate of one trait as a function of the state of another} \usage{ ratebystate(tree, x, y, nsim=100, corr=c("pearson","spearman"), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a continuous character - the dependent variable in the model.} \item{y}{a second continuous trait - the response variable.} \item{nsim}{number of simulations for hypothesis testing.} \item{corr}{correlation method to use. Same as in \code{\link{cor}}.} \item{...}{optional arguments which include \code{sim.method} (\code{"fastBM"} or \code{"sim.corrs"}; see \code{\link{fastBM}} and \code{\link{sim.corrs}}); \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{message} - a logical value indicating whether or not to return \code{corr} and \code{method}; finally \code{logarithm} - indicating whether or not to fit a model in which the variance of Brownian evolution in \code{y} changes as a multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.} } \description{ This function attempts to ask if the rate of a continuous character, \code{y}, depends on the state of a separate continuous trait, \code{x}. This is accomplished by regressing the squared contrasts in \code{y} on the branch or node ancestral estimates of \code{x}. } \value{ This function returns an object of class \code{"ratebystate"} with up to the following four elements: \item{beta}{value of the regression coefficient for square of the contrasts in \code{y} regressed on the ancestral or branch-wise estimated states for \code{x}.} \item{r}{correlation coefficient for \code{corr=corr}.} \item{corr}{string giving the value of \code{corr}.} \item{method}{string giving the value of \code{method}.} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastAnc}}, \code{\link{pic}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/brownieREML.Rd0000644000176200001440000000433613066526605015341 0ustar liggesusers\name{brownieREML} \alias{brownieREML} \title{REML version of brownie.lite} \usage{ brownieREML(tree, x, maxit=2000, ...) } \arguments{ \item{tree}{a phylogenetic tree in modified \code{"phylo"} format (see \code{\link{read.simmap}} and \code{\link{make.simmap}}).} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{...}{optional arguments.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then uses restricted maximum likelihood (REML) to fit the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This function is similar to \code{\link{brownie.lite}} but uses REML (which is faster and unbiased) instead of ML. REML optimization takes advantage of Felsenstein's (1985) contrasts algorithm. } \value{ An object of class \code{"brownieREML"} containing the following components: \item{sig2.single}{is the rate for a single rate model - this is usually the "null" model.} \item{logL1}{log-likelihood of the single-rate model.} \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates from the multi-rate model.} \item{logL2}{log-likelihood of the multi-rate model.} \item{convergence}{numerical value from \code{\link{optim}}.} } \references{ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. 2006. Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{evol.rate.mcmc}}, \code{\link{ratebytree}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/density.multiSimmap.Rd0000644000176200001440000000433513201722605017157 0ustar liggesusers\name{density.multiSimmap} \alias{density.multiSimmap} \alias{plot.changesMap} \title{Computes a posterior distribution for the number and types of changes on the tree} \usage{ \method{density}{multiSimmap}(x, ...) \method{plot}{changesMap}(x, ...) } \arguments{ \item{x}{object of class \code{"multiSimmap"} (see \code{\link{make.simmap}}), or, in the case \code{plot.changesMap}, an object of class \code{"changesMap"} produced via a call to \code{density.multiSimmap}.} \item{...}{optional arguments. For \code{density.multiSimmap} these consist of \code{bw} (bandwidth) & \code{method} (\code{"changes"}, \code{"densityMap"}, or \code{"timings"}).} } \details{ In \code{density.multiSimmap} \code{method="changes"}, the default, results in a posterior distribution of the number & types of changes on the tree. If the package \emph{coda} has been installed, then the function \code{HPD.interval} is used to compute a 95-percent high probability density interval for the number of changes of each type on the tree. Otherwise, the central 95-percent of the posterior sample is returned as an estimate of the 95-percent HPD interval for each change type. The method also computes the full posterior density for each change type using a bandwidth specified by the user. \code{method="densityMap"} computes a standard \code{"\link{densityMap}"} object, and thus only permits binary characters. Finally \code{method="changes"} has not yet been implemented. \code{plot.changesMap} plots the posterior density returned by \code{density.multiSimmap} for \code{method=} \code{"changes"}. } \description{ This function summarizes the result of one or more stochastic maps. } \value{ For \code{method="changes"} \code{density.multiSimmap} returns an object of class \code{"changesMap"}. For \code{method="densityMap"} \code{density.multiSimmap} returns an object of class \code{"\link{densityMap}"}. \code{plot.changesMap} generates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/sim.ratebystate.Rd0000644000176200001440000000350512464427402016323 0ustar liggesusers\name{sim.ratebystate} \alias{sim.ratebystate} \title{Conduct simulation of state dependent rate variation} \usage{ sim.ratebystate(tree, sig2x=1, sig2y=1, beta=c(0,1), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{sig2x}{variance of the Brownian process of evolution for \code{x}.} \item{sig2y}{variance of the Brownian process of evolution for \code{y} when \code{x-min(x)==1} (for \code{logarithm=FALSE}) or \code{x==0} (for \code{logarithm=TRUE}).} \item{beta}{intercept and slope of the relationship between the value of \code{x} and the Brownian rate in \code{y}.} \item{...}{optional arguments which include \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{plot}, a logical value indicating whether or not to plot a phenogram with the branches used for simulation of \code{y} after rescaling by the state of \code{x}; and \code{logarithm}, a logical value indicating whether or not simulate changes in the variance of Brownian evolution for \code{y} as an additive \code{logarithm=FALSE} or multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.} } \description{ This function attempts to simulate two characters under a model in which the rate of evolution for the second (\code{y}) depends on the states for the first \code{x}. See \code{\link{ratebystate}} for more details. } \value{ This function returns a matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{ratebystate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} phytools/man/getDescendants.Rd0000644000176200001440000000223513072304775016142 0ustar liggesusers\name{getDescendants} \alias{getDescendants} \alias{getParent} \title{Get descendant node numbers} \usage{ getDescendants(tree, node, curr=NULL) getParent(tree, node) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{node}{an integer specifying a node number in the tree.} \item{curr}{the set of previously stored node numbers - used in recursive function calls.} } \description{ This function returns the set of node & tip numbers descended from \code{node}. \code{getParent} instead returns the single parent node of a specified node number (or \code{NULL} if \code{node} is already the root). } \value{ The set of node and tip numbers for the nodes and tips descended from \code{node} in a vector, or for \code{getParent} the single node preceding \code{node} in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{Descendants}}, \code{\link{paintSubTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/collapseTree.Rd0000644000176200001440000000226112573356075015635 0ustar liggesusers\name{collapseTree} \alias{collapseTree} \title{Interactive tree visualizer} \usage{ collapseTree(tree, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{...}{optional arguments. These \emph{mostly} match the arguments of \code{\link{plotSimmap}}, but also include the argument \code{drop.extinct} which will (if the input tree is ultrametric) drop any 'extinct' lineages from the tree that is returned by the function.} } \description{ Function creates an interactive visualization of collapsing & expanding clades on the tree. } \details{ Function first plots a fan style tree, and then the user collapses node on the tree by clicking on them. Collapsed nodes are collapsed to the common ancestor of the clade. Nodes that have been collapsed can also be expanded by clicking. } \value{ Returns the final plotted tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/drop.clade.Rd0000644000176200001440000000134612464425470015224 0ustar liggesusers\name{drop.clade} \alias{drop.clade} \title{Drop a clade from a tree} \usage{ drop.clade(tree, tip) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{tip}{set of tips in a clade.} } \description{ Mostly internal function for \code{\link{posterior.evolrate}}; function drops the clade containing the species in \code{tip}. } \details{ Probably should not use unless you know what you're doing. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/collapse.to.star.Rd0000644000176200001440000000143312605223220016363 0ustar liggesusers\name{collapse.to.star} \alias{collapse.to.star} \title{Collapse a subtree to a star phylogeny} \usage{ collapse.to.star(tree, node) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{node}{node for the clade to be collapsed.} } \description{ This function collapses a subtree to a star. If the tree has edge lengths, the function will keep the tips at the same height above the root as in the original tree. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{starTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/geo.legend.Rd0000644000176200001440000000163113104376242015207 0ustar liggesusers\name{geo.legend} \alias{geo.legend} \title{Adds a geological (or other temporal) legend to a plotted tree} \usage{ geo.legend(leg=NULL, colors=NULL, alpha=0.2, ...) } \arguments{ \item{leg}{a matrix with the starting & ending point of each plotted era in rows, & names of the time periods as rownames.} \item{colors}{a vector of colors for the time periods of the rows in \code{leg}.} \item{alpha}{transparency level to apply to \code{colors}.} \item{...}{optional arguments.} } \description{ This function adds a geological (or other temporal) legend to a plotted tree. } \value{ Functions adds a visual element to a plotted tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/drop.tip.simmap.Rd0000644000176200001440000000307712464425555016244 0ustar liggesusers\name{drop.tip.simmap} \alias{drop.tip.simmap} \alias{extract.clade.simmap} \title{Drop tips or extract clade from tree with mapped discrete character} \usage{ drop.tip.simmap(tree, tip) extract.clade.simmap(tree, node) } \arguments{ \item{tree}{a modified object of class \code{"phylo"} (see \code{\link{read.simmap}}).} \item{tip}{name or names of species to be dropped.} \item{node}{node number for the root node of the clade to be extracted.} } \description{ This function drops one or multiple tips from the modified \code{"phylo"} object with a mapped binary or multistate trait (see \code{\link{read.simmap}}) while maintaining the matrix \code{$mapped.edge} and list of mappings by branch \code{maps}. This function is equivalent to \code{\link{drop.tip}} but for a tree with a mapped discrete character. \code{extract.clade.simmap} is functionally equivalent to \code{\link{extract.clade}} but preserves discrete character mappings on the tree. } \value{ A modified object of class \code{"phylo"} containing the elements \code{maps} and \code{$mapped.edge} with the time spent in each state along each edge of the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{drop.tip}}, \code{\link{extract.clade}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities}